diff options
340 files changed, 7871 insertions, 2125 deletions
diff --git a/.gitignore b/.gitignore index ad5204847c..a1c0dc774e 100644 --- a/.gitignore +++ b/.gitignore @@ -2,6 +2,8 @@ *.d *.d.raw *.vio +*.vos +*.vok *.vo *.cm* *.annot @@ -150,6 +152,7 @@ plugins/ssr/ssrvernac.ml # other auto-generated files +kernel/byterun/dune.c_flags kernel/byterun/coq_instruct.h kernel/byterun/coq_jumptbl.h kernel/genOpcodeFiles.exe diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 0ebf69f50f..d415816df2 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -18,7 +18,7 @@ stages: variables: # Format: $IMAGE-V$DATE [Cache is not used as of today but kept here # for reference] - CACHEKEY: "bionic_coq-V2019-09-20-V01" + CACHEKEY: "bionic_coq-V2019-11-05-V01" IMAGE: "$CI_REGISTRY_IMAGE:$CACHEKEY" # By default, jobs run in the base switch; override to select another switch OPAM_SWITCH: "base" @@ -21,9 +21,19 @@ WHAT DO YOU NEED ? - a C compiler + - an IEEE-754 compliant architecture with rounding to nearest + ties to even as default rounding mode (most architectures + should work nowadays) + - for CoqIDE, the lablgtk development files (version >= 3.0.0), and the GTK 3.x libraries including gtksourceview3. + The IEEE-754 compliance is required by primitive floating-point + numbers (Require Import Floats). Common sources of incompatibility + are checked at configure time, preventing compilation. In the, + unlikely, event an incompatibility remains undetected, using Floats + would enable to prove False on this architecture. + Note that num and lablgtk should be properly registered with findlib/ocamlfind as Coq's makefile will use it to locate the libraries during the build. diff --git a/Makefile.build b/Makefile.build index ed4cde2b16..b63d582740 100644 --- a/Makefile.build +++ b/Makefile.build @@ -566,15 +566,15 @@ $(FAKEIDEBYTE): $(FAKEIDECMO) | $(IDETOPBYTE) # votour: a small vo explorer (based on the checker) -VOTOURCMO:=clib/cObj.cmo kernel/uint63.cmo checker/analyze.cmo checker/values.cmo checker/votour.cmo +VOTOURCMO:=clib/cObj.cmo kernel/uint63.cmo kernel/float64.cmo checker/analyze.cmo checker/values.cmo checker/votour.cmo -bin/votour: $(call bestobj, $(VOTOURCMO)) +bin/votour: $(call bestobj, $(VOTOURCMO)) $(LIBCOQRUN) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml, -I checker) -bin/votour.byte: $(VOTOURCMO) +bin/votour.byte: $(VOTOURCMO) $(LIBCOQRUN) $(SHOW)'OCAMLC -o $@' - $(HIDE)$(call ocamlbyte, -I checker) + $(HIDE)$(call ocamlbyte, -I checker $(VMBYTEFLAGS)) ########################################################################### # Csdp to micromega special targets diff --git a/Makefile.checker b/Makefile.checker index 5c55ccf489..90c73a496d 100644 --- a/Makefile.checker +++ b/Makefile.checker @@ -43,7 +43,7 @@ checker/check.cmxa $(LIBCOQRUN) checker/coqchk.mli checker/coqchk.ml $(CODESIGN_HIDE) $@ else $(CHICKEN): $(CHICKENBYTE) - cp $< $@ + rm -f $@ && cp $< $@ endif $(CHICKENBYTE): config/config.cma clib/clib.cma lib/lib.cma kernel/kernel.cma \ diff --git a/Makefile.common b/Makefile.common index 1ad255d156..e392e51153 100644 --- a/Makefile.common +++ b/Makefile.common @@ -149,6 +149,7 @@ RTAUTOCMO:=plugins/rtauto/rtauto_plugin.cmo SYNTAXCMO:=$(addprefix plugins/syntax/, \ r_syntax_plugin.cmo \ int63_syntax_plugin.cmo \ + float_syntax_plugin.cmo \ numeral_notation_plugin.cmo \ string_notation_plugin.cmo) DERIVECMO:=plugins/derive/derive_plugin.cmo diff --git a/Makefile.ide b/Makefile.ide index 39c6c8ad1e..bd72494289 100644 --- a/Makefile.ide +++ b/Makefile.ide @@ -110,7 +110,7 @@ $(COQIDE): $(LINKIDEOPT) $(STRIP_HIDE) $@ else $(COQIDE): $(COQIDEBYTE) - cp $< $@ + rm -f $@ && cp $< $@ endif $(COQIDEBYTE): $(LINKIDE) @@ -119,9 +119,7 @@ $(COQIDEBYTE): $(LINKIDE) -linkpkg -package str,unix,dynlink,threads,lablgtk3-sourceview3 $(IDEFLAGS) $(IDECDEPSFLAGS) $^ ide/coqide_os_specific.ml: ide/coqide_$(IDEINT).ml.in config/Makefile - @rm -f $@ - cp $< $@ - @chmod a-w $@ + rm -f $@ && cp $< $@ && chmod a-w $@ ide/%.cmi: ide/%.mli $(SHOW)'OCAMLC $<' @@ -150,7 +148,7 @@ IDETOPCMX:=$(IDETOPCMA:.cma=.cmxa) # Special rule for coqidetop $(IDETOPEXE): $(IDETOP:.opt=.$(BEST)) - cp $< $@ + rm -f $@ && cp $< $@ $(IDETOP): ide/idetop.ml $(LINKCMX) $(LIBCOQRUN) $(IDETOPCMX) $(SHOW)'COQMKTOP -o $@' diff --git a/Makefile.vofiles b/Makefile.vofiles index 5296ed43ff..97263ed9ea 100644 --- a/Makefile.vofiles +++ b/Makefile.vofiles @@ -49,7 +49,7 @@ endif else NATIVEFILES := endif -LIBFILES:=$(ALLVO:.$(VO)=.vo) $(NATIVEFILES) $(VFILES) $(GLOBFILES) +LIBFILES:=$(ALLVO:.$(VO)=.vo) $(ALLVO:.$(VO)=.vos) $(NATIVEFILES) $(VFILES) $(GLOBFILES) # For emacs: # Local Variables: diff --git a/checker/analyze.ml b/checker/analyze.ml index e145988b4f..4c06f1e250 100644 --- a/checker/analyze.ml +++ b/checker/analyze.ml @@ -107,6 +107,7 @@ end type repr = | RInt of int | RInt63 of Uint63.t +| RFloat64 of Float64.t | RBlock of (int * int) (* tag × len *) | RString of string | RPointer of int @@ -121,6 +122,7 @@ type data = type obj = | Struct of int * data array (* tag × data *) | Int63 of Uint63.t (* Primitive integer *) +| Float64 of Float64.t (* Primitive float *) | String of string module type Input = @@ -279,6 +281,25 @@ let input_intL chan : int64 = (i lsl 56) lor (j lsl 48) lor (k lsl 40) lor (l lsl 32) lor (m lsl 24) lor (n lsl 16) lor (o lsl 8) lor (Int64.of_int p) +let input_double_big chan : float = + Int64.float_of_bits (input_intL chan) + +let input_double_little chan : float = + let i = input_byte chan in + let j = input_byte chan in + let k = input_byte chan in + let l = input_byte chan in + let m = input_byte chan in + let n = input_byte chan in + let o = input_byte chan in + let p = input_byte chan in + let ( lsl ) x y = Int64.(shift_left (of_int x) y) in + let ( lor ) = Int64.logor in + let bits = + (p lsl 56) lor (o lsl 48) lor (n lsl 40) lor (m lsl 32) lor + (l lsl 24) lor (k lsl 16) lor (j lsl 8) lor (Int64.of_int i) in + Int64.float_of_bits bits + let parse_object chan = let data = input_byte chan in if prefix_small_block <= data then @@ -326,9 +347,11 @@ let parse_object chan = | "_j" -> RInt63 (Uint63.of_int64 (input_intL chan)) | s -> Printf.eprintf "Unhandled custom code: %s" s; assert false end + | CODE_DOUBLE_BIG -> + RFloat64 (Float64.of_float (input_double_big chan)) + | CODE_DOUBLE_LITTLE -> + RFloat64 (Float64.of_float (input_double_little chan)) | CODE_DOUBLE_ARRAY32_LITTLE - | CODE_DOUBLE_BIG - | CODE_DOUBLE_LITTLE | CODE_DOUBLE_ARRAY8_BIG | CODE_DOUBLE_ARRAY8_LITTLE | CODE_DOUBLE_ARRAY32_BIG @@ -370,6 +393,11 @@ let parse chan = let () = LargeArray.set memory !current_object (Int63 i) in let () = incr current_object in data, None + | RFloat64 f -> + let data = Ptr !current_object in + let () = LargeArray.set memory !current_object (Float64 f) in + let () = incr current_object in + data, None in let rec fill block off accu = @@ -434,6 +462,7 @@ let instantiate (p, mem) = let obj = match LargeArray.get mem i with | Struct (tag, blk) -> Obj.new_block tag (Array.length blk) | Int63 i -> Obj.repr i + | Float64 f -> Obj.repr f | String str -> Obj.repr str in LargeArray.set ans i obj @@ -453,6 +482,7 @@ let instantiate (p, mem) = Obj.set_field obj k (get_data blk.(k)) done | Int63 _ + | Float64 _ | String _ -> () done; get_data p diff --git a/checker/analyze.mli b/checker/analyze.mli index 029f595959..e579f4896d 100644 --- a/checker/analyze.mli +++ b/checker/analyze.mli @@ -8,6 +8,7 @@ type data = type obj = | Struct of int * data array (* tag × data *) | Int63 of Uint63.t (* Primitive integer *) +| Float64 of Float64.t (* Primitive float *) | String of string module LargeArray : diff --git a/checker/validate.ml b/checker/validate.ml index 178bb4c527..678af9f2d5 100644 --- a/checker/validate.ml +++ b/checker/validate.ml @@ -87,6 +87,7 @@ let rec val_gen v ctx o = match v with | Dyn -> val_dyn ctx o | Proxy { contents = v } -> val_gen v ctx o | Uint63 -> val_uint63 ctx o + | Float64 -> val_float64 ctx o (* Check that an object is a tuple (or a record). vs is an array of value representation for each field. Its size corresponds to the @@ -138,6 +139,10 @@ and val_uint63 ctx o = if not (Uint63.is_uint63 o) then fail ctx o "not a 63-bit unsigned integer" +and val_float64 ctx o = + if not (Float64.is_float64 o) then + fail ctx o "not a 64-bit float" + let print_frame = function | CtxType t -> t | CtxAnnot t -> t diff --git a/checker/values.ml b/checker/values.ml index 9a2028a96b..3882f88391 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -35,6 +35,7 @@ type value = | Proxy of value ref | Uint63 + | Float64 let fix (f : value -> value) : value = let self = ref Any in @@ -147,7 +148,8 @@ let rec v_constr = [|v_fix|]; (* Fix *) [|v_cofix|]; (* CoFix *) [|v_proj;v_constr|]; (* Proj *) - [|Uint63|] (* Int *) + [|Uint63|]; (* Int *) + [|Float64|] (* Int *) |]) and v_prec = Tuple ("prec_declaration", @@ -226,7 +228,7 @@ let v_pol_arity = v_tuple "polymorphic_arity" [|List(Opt v_level);v_univ|] let v_primitive = - v_enum "primitive" 25 + v_enum "primitive" 44 (* Number of "Primitive" in Int63.v and PrimFloat.v *) let v_cst_def = v_sum "constant_def" 0 @@ -300,9 +302,11 @@ let v_ind_pack = v_tuple "mutual_inductive_body" Opt v_bool; v_typing_flags|] -let v_prim_ind = v_enum "prim_ind" 4 +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" 1 +let v_prim_type = v_enum "prim_type" 2 +(* Number of constructors of prim_type in "kernel/cPrimitives.ml" *) let v_retro_action = v_sum "retro_action" 0 [| diff --git a/checker/values.mli b/checker/values.mli index db6b0be250..ec3b91d5dd 100644 --- a/checker/values.mli +++ b/checker/values.mli @@ -39,6 +39,7 @@ type value = (** Same as the inner value, used to define recursive types *) | Uint63 + | Float64 (** NB: List and Opt have their own constructors to make it easy to define eg [let rec foo = List foo]. *) diff --git a/checker/votour.ml b/checker/votour.ml index 97584831e5..fe6c487496 100644 --- a/checker/votour.ml +++ b/checker/votour.ml @@ -101,6 +101,7 @@ struct in fold 0 1 (fun size -> let () = LargeArray.set !sizes p size in k size) | Int63 _ -> k 0 + | Float64 _ -> k 0 | String s -> let size = 2 + (String.length s / ws) in let () = LargeArray.set !sizes p size in @@ -118,6 +119,7 @@ struct match LargeArray.get !memory p with | Struct (tag, os) -> BLOCK (tag, os) | Int63 _ -> OTHER (* TODO: pretty-print int63 values *) + | Float64 _ -> OTHER (* TODO: pretty-print float64 values *) | String s -> STRING s let input ch = @@ -156,6 +158,7 @@ let rec get_name ?(extra=false) = function |Dyn -> "<dynamic>" | Proxy v -> get_name ~extra !v | Uint63 -> "Uint63" + | Float64 -> "Float64" (** For tuples, its quite handy to display the inner 1st string (if any). Cf. [structure_body] for instance *) @@ -261,6 +264,7 @@ let rec get_children v o pos = match v with |Fail s -> raise Forbidden | Proxy v -> get_children !v o pos | Uint63 -> raise Exit + | Float64 -> raise Exit let get_children v o pos = try get_children v o pos diff --git a/configure.ml b/configure.ml index 8e04dc46b2..a53292b4cf 100644 --- a/configure.ml +++ b/configure.ml @@ -456,8 +456,6 @@ let coq_bin_annot_flag = if !prefs.bin_annot then "-bin-annot" else "" let coq_safe_string = "-safe-string" let coq_strict_sequence = "-strict-sequence" -let cflags = "-Wall -Wno-unused -g -O2" - (** * Architecture *) let arch_progs = @@ -917,6 +915,40 @@ let configdir,configdirsuffix = let (_,_,d,s) = select "CONFIGDIR" in d,s let datadir,datadirsuffix = let (_,_,d,s) = select "DATADIR" in d,s +(** * CC runtime flags *) + +let cflags_dflt = "-Wall -Wno-unused -g -O2 -fexcess-precision=standard" + +let cflags_sse2 = ["-msse2"; "-mfpmath=sse"] + +let cflags, sse2_math = + let _, slurp = + (* Test SSE2_MATH support <https://stackoverflow.com/a/45667927> *) + tryrun "cc" (["-march=native"; "-dM"; "-E"] + @ cflags_sse2 + @ [coqtop/"kernel/byterun/coq_interp.h"] (* any file *)) in + if List.exists (fun line -> starts_with line "#define __SSE2_MATH__ 1") slurp + then (cflags_dflt ^ " " ^ String.concat " " cflags_sse2, true) + else (cflags_dflt, false) + +(** Test at configure time that no harmful double rounding seems to + be performed with an intermediate 80-bit representation (x87). + + If this test fails but SSE2_MATH is available, the build can go + further as Coq's primitive floats will use it through a dedicated + external C implementation (instead of relying on OCaml operations) + + If this test fails and SSE2_MATH is not available, abort. + *) +let () = + let add = (+.) in + let b = ldexp 1. 53 in + let s = add 1. (ldexp 1. (-52)) in + if (add b s <= b || add b 1. <> b || ldexp 1. (-1074) <= 0.) + && not sse2_math then + die "Detected non IEEE-754 compliant architecture (or wrong \ + rounding mode). Use of Float is thus unsafe." + (** * OCaml runtime flags *) (** Do we use -custom (yes by default on Windows and MacOS) *) @@ -1176,6 +1208,16 @@ let write_makefile f = let _ = write_makefile "config/Makefile" +let write_dune_c_flags f = + safe_remove f; + let o = open_out f in + let pr s = fprintf o s in + pr "(%s)\n" cflags; + close_out o; + Unix.chmod f 0o444 + +let _ = try write_dune_c_flags "kernel/byterun/dune.c_flags" with _ -> () + let write_macos_metadata exec = let f = "config/Info-"^exec^".plist" in let () = safe_remove f in diff --git a/coq-refman.opam b/coq-refman.opam index 16be422c27..937c4b08d3 100644 --- a/coq-refman.opam +++ b/coq-refman.opam @@ -15,6 +15,8 @@ bug-reports: "https://github.com/coq/coq/issues" dev-repo: "https://github.com/coq/coq.git" license: "Open Publication License" +version: "dev" + depends: [ "dune" { build } "coq" { build & = version } @@ -18,6 +18,8 @@ bug-reports: "https://github.com/coq/coq/issues" dev-repo: "git+https://github.com/coq/coq.git" license: "LGPL-2.1" +version: "dev" + depends: [ "ocaml" { >= "4.05.0" } "dune" { build & >= "1.10.0" } diff --git a/coqide-server.opam b/coqide-server.opam index 5712ca08c2..5da533ea6b 100644 --- a/coqide-server.opam +++ b/coqide-server.opam @@ -18,6 +18,8 @@ bug-reports: "https://github.com/coq/coq/issues" dev-repo: "git+https://github.com/coq/coq.git" license: "LGPL-2.1" +version: "dev" + depends: [ "dune" { build & >= "1.10.0" } "coq" { = version } diff --git a/coqide.opam b/coqide.opam index d680ebb5f4..3e588ed0cf 100644 --- a/coqide.opam +++ b/coqide.opam @@ -16,6 +16,8 @@ bug-reports: "https://github.com/coq/coq/issues" dev-repo: "git+https://github.com/coq/coq.git" license: "LGPL-2.1" +version: "dev" + depends: [ "dune" { build & >= "1.10.0" } "coqide-server" { = version } diff --git a/dev/ci/docker/bionic_coq/Dockerfile b/dev/ci/docker/bionic_coq/Dockerfile index edca83c6ef..1cad46cd89 100644 --- a/dev/ci/docker/bionic_coq/Dockerfile +++ b/dev/ci/docker/bionic_coq/Dockerfile @@ -1,4 +1,4 @@ -# CACHEKEY: "bionic_coq-V2019-09-20-V01" +# CACHEKEY: "bionic_coq-V2019-11-05-V01" # ^^ Update when modifying this file. FROM ubuntu:bionic @@ -39,7 +39,7 @@ ENV COMPILER="4.05.0" # with the compiler version. ENV BASE_OPAM="num ocamlfind.1.8.1 dune.1.11.3 ounit.2.0.8 odoc.1.4.2" \ CI_OPAM="menhir.20190626 ocamlgraph.1.8.8" \ - BASE_ONLY_OPAM="elpi.1.7.0" + BASE_ONLY_OPAM="elpi.1.8.0" # BASE switch; CI_OPAM contains Coq's CI dependencies. ENV COQIDE_OPAM="cairo2.0.6.1 lablgtk3-sourceview3.3.0.beta6" diff --git a/dev/ci/user-overlays/09867-primitive-floats.sh b/dev/ci/user-overlays/09867-primitive-floats.sh new file mode 100644 index 0000000000..a0e9085afd --- /dev/null +++ b/dev/ci/user-overlays/09867-primitive-floats.sh @@ -0,0 +1,12 @@ +if [ "$CI_PULL_REQUEST" = "9867" ] || [ "$CI_BRANCH" = "primitive-floats" ]; then + + unicoq_CI_REF=primitive-floats + unicoq_CI_GITURL=https://github.com/validsdp/unicoq + + elpi_CI_REF=primitive-floats + elpi_CI_GITURL=https://github.com/validsdp/coq-elpi + + coqhammer_CI_REF=primitive-floats + coqhammer_CI_GITURL=https://github.com/validsdp/coqhammer + +fi diff --git a/dev/ci/user-overlays/10358-gares-elpi13.sh b/dev/ci/user-overlays/10358-gares-elpi13.sh deleted file mode 100644 index d2ba9b5ddf..0000000000 --- a/dev/ci/user-overlays/10358-gares-elpi13.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "10358" ] || [ "$CI_BRANCH" = "elpi-13-coq" ]; then - - elpi_CI_REF="elpi-13-coq" - elpi_CI_GITURL=https://github.com/LPCIC/coq-elpi - -fi diff --git a/dev/ci/user-overlays/10738-gares-elpi1.7.sh b/dev/ci/user-overlays/10738-gares-elpi1.7.sh deleted file mode 100644 index 8922badf90..0000000000 --- a/dev/ci/user-overlays/10738-gares-elpi1.7.sh +++ /dev/null @@ -1,6 +0,0 @@ -if [ "$CI_PULL_REQUEST" = "10738" ] || [ "$CI_BRANCH" = "elpi1.7" ]; then - - elpi_CI_REF="coq-master+elpi1.7" - elpi_CI_GITURL=https://github.com/LPCIC/coq-elpi - -fi diff --git a/dev/ci/user-overlays/11051-gares-elpi-1.8.sh b/dev/ci/user-overlays/11051-gares-elpi-1.8.sh new file mode 100644 index 0000000000..7845654375 --- /dev/null +++ b/dev/ci/user-overlays/11051-gares-elpi-1.8.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "11051" ] || [ "$CI_BRANCH" = "elpi-1.8" ]; then + + elpi_CI_REF="coq-master+v1.2" + elpi_CI_GITURL=https://github.com/LPCIC/coq-elpi + +fi diff --git a/dev/doc/critical-bugs b/dev/doc/critical-bugs index 6d90ced12d..0631b3ad59 100644 --- a/dev/doc/critical-bugs +++ b/dev/doc/critical-bugs @@ -112,8 +112,8 @@ Universes component: universe polymorphism summary: universe polymorphism can capture global universes impacted released versions: V8.5 to V8.8 - impacted coqchk versions: V8.5 to current (NOT FIXED) - fixed in: 2385b5c1ef + impacted coqchk versions: V8.5 to V8.9 + fixed in: ec4aa4971f (58e1d0f200 for the checker) found by: Gaëtan Gilbert exploit: test-suite/misc/poly-capture-global-univs GH issue number: #8341 diff --git a/dev/nixpkgs.nix b/dev/nixpkgs.nix index 8736c0f9b8..e7a0ba4f6c 100644 --- a/dev/nixpkgs.nix +++ b/dev/nixpkgs.nix @@ -1,4 +1,4 @@ import (fetchTarball { - url = "https://github.com/NixOS/nixpkgs/archive/31c38894c90429c9554eab1b416e59e3b6e054df.tar.gz"; - sha256 = "1fv14rj5zslzm14ak4lvwqix94gm18h28376h4hsmrqqpnfqwsdw"; + url = "https://github.com/NixOS/nixpkgs/archive/4cd2cb43fb3a87f48c1e10bb65aee99d8f24cb9d.tar.gz"; + sha256 = "1d6rmq67kdg5gmk94wx2774qw89nvbhy6g1f2lms3c9ph37hways"; }) diff --git a/dev/top_printers.ml b/dev/top_printers.ml index aa28bce018..ccb8658eee 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -307,6 +307,8 @@ let constr_display csr = ^(array_display bl)^")" | Int i -> "Int("^(Uint63.to_string i)^")" + | Float f -> + "Float("^(Float64.to_string f)^")" and array_display v = "[|"^ @@ -439,6 +441,8 @@ let print_pure_constr csr = in print_string"{"; print_fix (); print_string"}" | Int i -> print_string ("Int("^(Uint63.to_string i)^")") + | Float f -> + print_string ("Float("^(Float64.to_string f)^")") 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 863d930968..11565b99eb 100644 --- a/dev/vm_printers.ml +++ b/dev/vm_printers.ml @@ -84,6 +84,7 @@ and ppwhd whd = | Vconstr_const i -> print_string "C(";print_int i;print_string")" | Vconstr_block b -> ppvblock b | Vint64 i -> printf "int64(%LiL)" i + | Vfloat64 f -> printf "float64(%.17g)" f | Vatom_stk(a,s) -> open_hbox();ppatom a;close_box(); print_string"@";ppstack s diff --git a/doc/changelog/01-kernel/09867-floats.rst b/doc/changelog/01-kernel/09867-floats.rst new file mode 100644 index 0000000000..56b5fc747a --- /dev/null +++ b/doc/changelog/01-kernel/09867-floats.rst @@ -0,0 +1,13 @@ +- A built-in support of floating-point arithmetic was added, allowing + one to devise efficient reflection tactics involving numerical + computation. Primitive floats are added in the language of terms, + following the binary64 format of the IEEE 754 standard, and the + related operations are implemented for the different reduction + engines of Coq by using the corresponding processor operators in + rounding-to-nearest-even. The properties of these operators are + axiomatized in the theory :g:`Coq.Floats.FloatAxioms` which is part + of the library :g:`Coq.Floats.Floats`. + See Section :ref:`primitive-floats` + (`#9867 <https://github.com/coq/coq/pull/9867>`_, + closes `#8276 <https://github.com/coq/coq/issues/8276>`_, + by Guillaume Bertholon, Erik Martin-Dorel, Pierre Roux). diff --git a/doc/changelog/02-specification-language/10985-about-arguments.rst b/doc/changelog/02-specification-language/10985-about-arguments.rst new file mode 100644 index 0000000000..1e05b0b0fe --- /dev/null +++ b/doc/changelog/02-specification-language/10985-about-arguments.rst @@ -0,0 +1,5 @@ +- The output of the :cmd:`Print` and :cmd:`About` commands has + changed. Arguments meta-data is now displayed as the corresponding + :cmd:`Arguments <Arguments (implicits)>` command instead of the + human-targeted prose used in previous Coq versions. (`#10985 + <https://github.com/coq/coq/pull/10985>`_, by Gaëtan Gilbert). diff --git a/doc/changelog/02-specification-language/10997-unsupport-atts-warn.rst b/doc/changelog/02-specification-language/10997-unsupport-atts-warn.rst new file mode 100644 index 0000000000..43a748b365 --- /dev/null +++ b/doc/changelog/02-specification-language/10997-unsupport-atts-warn.rst @@ -0,0 +1,3 @@ +- The unsupported attribute error is now an error-by-default warning, + meaning it can be disabled (`#10997 + <https://github.com/coq/coq/pull/10997>`_, by Gaëtan Gilbert). diff --git a/doc/changelog/03-notations/09883-numeral-notations-sorts.rst b/doc/changelog/03-notations/09883-numeral-notations-sorts.rst new file mode 100644 index 0000000000..abc5a516ae --- /dev/null +++ b/doc/changelog/03-notations/09883-numeral-notations-sorts.rst @@ -0,0 +1,4 @@ +- Numeral Notations now support sorts in the input to printing + functions (e.g., numeral notations can be defined for terms + containing things like `@cons Set nat nil`). (`#9883 + <https://github.com/coq/coq/pull/9883>`_, by Jason Gross). diff --git a/doc/changelog/06-ssreflect/10022-ssr-under-setoid.rst b/doc/changelog/06-ssreflect/10022-ssr-under-setoid.rst new file mode 100644 index 0000000000..5e005742fd --- /dev/null +++ b/doc/changelog/06-ssreflect/10022-ssr-under-setoid.rst @@ -0,0 +1,28 @@ +- Generalize tactics :tacn:`under` and :tacn:`over` for any registered + relation. More precisely, assume the given context lemma has type + `forall f1 f2, .. -> (forall i, R1 (f1 i) (f2 i)) -> R2 f1 f2`. The + first step performed by :tacn:`under` (since Coq 8.10) amounts to + calling the tactic :tacn:`rewrite <rewrite (ssreflect)>`, which + itself relies on :tacn:`setoid_rewrite` if need be. So this step was + already compatible with a double implication or setoid equality for + the conclusion head symbol `R2`. But a further step consists in + tagging the generated subgoal `R1 (f1 i) (?f2 i)` to protect it from + unwanted evar instantiation, and get `Under_rel _ R1 (f1 i) (?f2 i)` + that is displayed as ``'Under[ f1 i ]``. In Coq 8.10, this second + (convenience) step was only performed when `R1` was Leibniz' `eq` or + `iff`. Now, it is also performed for any relation `R1` which has a + ``RewriteRelation`` instance (a `RelationClasses.Reflexive` instance + being also needed so :tacn:`over` can discharge the ``'Under[ _ ]`` + goal by instantiating the hidden evar.) Also, it is now possible to + manipulate `Under_rel _ R1 (f1 i) (?f2 i)` subgoals directly if `R1` + is a `PreOrder` relation or so, thanks to extra instances proving + that `Under_rel` preserves the properties of the `R1` relation. + These two features generalizing support for setoid-like relations is + enabled as soon as we do both ``Require Import ssreflect.`` and + ``Require Setoid.`` Finally, a rewrite rule ``UnderE`` has been + added if one wants to "unprotect" the evar, and instantiate it + manually with another rule than reflexivity (i.e., without using the + :tacn:`over` tactic nor the ``over`` rewrite rule). See also Section + :ref:`under_ssr` (`#10022 <https://github.com/coq/coq/pull/10022>`_, + by Erik Martin-Dorel, with suggestions and review by Enrico Tassi + and Cyril Cohen). diff --git a/doc/changelog/08-tools/08642-vos-files.rst b/doc/changelog/08-tools/08642-vos-files.rst new file mode 100644 index 0000000000..f612096880 --- /dev/null +++ b/doc/changelog/08-tools/08642-vos-files.rst @@ -0,0 +1,7 @@ +- `coqc` now provides the ability to generate compiled interfaces. + Use `coqc -vos foo.v` to skip all opaque proofs during the + compilation of `foo.v`, and output a file called `foo.vos`. + This feature is experimental. It enables working on a Coq file without the need to + first compile the proofs contained in its dependencies + (`#8642 <https://github.com/coq/coq/pull/8642>`_ by Arthur Charguéraud, review by + Maxime Dénès and Emilio Gallego). diff --git a/doc/sphinx/addendum/extraction.rst b/doc/sphinx/addendum/extraction.rst index 3dc8707a34..9f92fc4c56 100644 --- a/doc/sphinx/addendum/extraction.rst +++ b/doc/sphinx/addendum/extraction.rst @@ -127,20 +127,21 @@ Concerning Haskell, type-preserving optimizations are less useful because of laziness. We still make some optimizations, for example in order to produce more readable code. -The type-preserving optimizations are controlled by the following |Coq| options: +The type-preserving optimizations are controlled by the following |Coq| flags +and commands: .. flag:: Extraction Optimize Default is on. This controls all type-preserving optimizations made on the ML terms (mostly reduction of dummy beta/iota redexes, but also - simplifications on Cases, etc). Turn this option off if you want a + simplifications on Cases, etc). Turn this flag off if you want a ML term as close as possible to the Coq term. .. flag:: Extraction Conservative Types Default is off. This controls the non type-preserving optimizations made on ML terms (which try to avoid function abstraction of dummy - types). Turn this option on to make sure that ``e:t`` + types). Turn this flag on to make sure that ``e:t`` implies that ``e':t'`` where ``e'`` and ``t'`` are the extracted code of ``e`` and ``t`` respectively. @@ -150,7 +151,7 @@ The type-preserving optimizations are controlled by the following |Coq| options: produces a singleton type (i.e. a type with only one constructor, and only one argument to this constructor), the inductive structure is removed and this type is seen as an alias to the inner type. - The typical example is ``sig``. This option allows disabling this + The typical example is ``sig``. This flag allows disabling this optimization when one wishes to preserve the inductive structure of types. .. flag:: Extraction AutoInline @@ -159,7 +160,7 @@ The type-preserving optimizations are controlled by the following |Coq| options: some defined constants, according to some heuristics like size of bodies, uselessness of some arguments, etc. Those heuristics are not always perfect; if you want to disable - this feature, turn this option off. + this feature, turn this flag off. .. cmd:: Extraction Inline {+ @qualid } @@ -223,11 +224,11 @@ principles of extraction (logical parts and types). When an actual extraction takes place, an error is normally raised if the :cmd:`Extraction Implicit` declarations cannot be honored, that is if any of the implicit arguments still occurs in the final code. -This behavior can be relaxed via the following option: +This behavior can be relaxed via the following flag: .. flag:: Extraction SafeImplicits - Default is on. When this option is off, a warning is emitted + Default is on. When this flag is off, a warning is emitted instead of an error if some implicit arguments still occur in the final code of an extraction. This way, the extracted code may be obtained nonetheless and reviewed manually to locate the source of the issue diff --git a/doc/sphinx/addendum/generalized-rewriting.rst b/doc/sphinx/addendum/generalized-rewriting.rst index 2ea0861e47..93a1be027c 100644 --- a/doc/sphinx/addendum/generalized-rewriting.rst +++ b/doc/sphinx/addendum/generalized-rewriting.rst @@ -714,8 +714,10 @@ Definitions The generalized rewriting tactic is based on a set of strategies that can be combined to obtain custom rewriting procedures. Its set of strategies is based -on Elan’s rewriting strategies :cite:`Luttik97specificationof`. Rewriting -strategies are applied using the tactic :n:`rewrite_strat @strategy` where :token:`strategy` is a +on the programmable rewriting strategies with generic traversals by Visser et al. +:cite:`Luttik97specificationof` :cite:`Visser98`, which formed the core of +the Stratego transformation language :cite:`Visser01`. Rewriting strategies +are applied using the tactic :n:`rewrite_strat @strategy` where :token:`strategy` is a strategy expression. Strategies are defined inductively as described by the following grammar: diff --git a/doc/sphinx/addendum/implicit-coercions.rst b/doc/sphinx/addendum/implicit-coercions.rst index 7fee62179b..c3b197288f 100644 --- a/doc/sphinx/addendum/implicit-coercions.rst +++ b/doc/sphinx/addendum/implicit-coercions.rst @@ -274,7 +274,7 @@ Activating the Printing of Coercions .. flag:: Printing Coercions - When on, this option forces all the coercions to be printed. + When on, this flag forces all the coercions to be printed. By default, coercions are not printed. .. table:: Printing Coercion @qualid diff --git a/doc/sphinx/addendum/micromega.rst b/doc/sphinx/addendum/micromega.rst index 4a691bde3a..cc19c8b6a9 100644 --- a/doc/sphinx/addendum/micromega.rst +++ b/doc/sphinx/addendum/micromega.rst @@ -31,21 +31,21 @@ tactics for solving arithmetic goals over :math:`\mathbb{Q}`, .. flag:: Simplex - This option (set by default) instructs the decision procedures to + This flag (set by default) instructs the decision procedures to use the Simplex method for solving linear goals. If it is not set, the decision procedures are using Fourier elimination. .. flag:: Lia Cache - This option (set by default) instructs :tacn:`lia` to cache its results in the file `.lia.cache` + This flag (set by default) instructs :tacn:`lia` to cache its results in the file `.lia.cache` .. flag:: Nia Cache - This option (set by default) instructs :tacn:`nia` to cache its results in the file `.nia.cache` + This flag (set by default) instructs :tacn:`nia` to cache its results in the file `.nia.cache` .. flag:: Nra Cache - This option (set by default) instructs :tacn:`nra` to cache its results in the file `.nra.cache` + This flag (set by default) instructs :tacn:`nra` to cache its results in the file `.nra.cache` The tactics solve propositional formulas parameterized by atomic diff --git a/doc/sphinx/addendum/omega.rst b/doc/sphinx/addendum/omega.rst index b008508bbc..650a444a16 100644 --- a/doc/sphinx/addendum/omega.rst +++ b/doc/sphinx/addendum/omega.rst @@ -119,21 +119,21 @@ Options .. deprecated:: 8.5 - This deprecated option (on by default) is for compatibility with Coq pre 8.5. It + This deprecated flag (on by default) is for compatibility with Coq pre 8.5. It resets internal name counters to make executions of :tacn:`omega` independent. .. flag:: Omega UseLocalDefs - This option (on by default) allows :tacn:`omega` to use the bodies of local + This flag (on by default) allows :tacn:`omega` to use the bodies of local variables. .. flag:: Omega System - This option (off by default) activate the printing of debug information + This flag (off by default) activate the printing of debug information .. flag:: Omega Action - This option (off by default) activate the printing of debug information + This flag (off by default) activate the printing of debug information Technical data -------------- diff --git a/doc/sphinx/addendum/parallel-proof-processing.rst b/doc/sphinx/addendum/parallel-proof-processing.rst index cdb7ea834f..35729d852d 100644 --- a/doc/sphinx/addendum/parallel-proof-processing.rst +++ b/doc/sphinx/addendum/parallel-proof-processing.rst @@ -58,7 +58,7 @@ variables used. Automatic suggestion of proof annotations ````````````````````````````````````````` -The flag :flag:`Suggest Proof Using` makes |Coq| suggest, when a ``Qed`` +The :flag:`Suggest Proof Using` flag makes |Coq| suggest, when a ``Qed`` command is processed, a correct proof annotation. It is up to the user to modify the proof script accordingly. diff --git a/doc/sphinx/addendum/program.rst b/doc/sphinx/addendum/program.rst index 45c74ab02a..a17dca1693 100644 --- a/doc/sphinx/addendum/program.rst +++ b/doc/sphinx/addendum/program.rst @@ -78,7 +78,7 @@ operation (see :ref:`extendedpatternmatching`). also works with the previous mechanism. -There are options to control the generation of equalities and +There are flags to control the generation of equalities and coercions. .. flag:: Program Cases @@ -86,13 +86,13 @@ coercions. This controls the special treatment of pattern matching generating equalities and disequalities when using |Program| (it is on by default). All pattern-matches and let-patterns are handled using the standard algorithm - of |Coq| (see :ref:`extendedpatternmatching`) when this option is + of |Coq| (see :ref:`extendedpatternmatching`) when this flag is deactivated. .. flag:: Program Generalized Coercion This controls the coercion of general inductive types when using |Program| - (the option is on by default). Coercion of subset types and pairs is still + (the flag is on by default). Coercion of subset types and pairs is still active in this case. .. flag:: Program Mode @@ -341,9 +341,9 @@ optional tactic is replaced by the default one if not specified. .. flag:: Shrink Obligations - *Deprecated since 8.7* + .. deprecated:: 8.7 - This option (on by default) controls whether obligations should have + This flag (on by default) controls whether obligations should have their context minimized to the set of variables used in the proof of the obligation, to avoid unnecessary dependencies. diff --git a/doc/sphinx/addendum/sprop.rst b/doc/sphinx/addendum/sprop.rst index 9a9ec78edc..9acdd18b89 100644 --- a/doc/sphinx/addendum/sprop.rst +++ b/doc/sphinx/addendum/sprop.rst @@ -9,9 +9,11 @@ SProp (proof irrelevant propositions) This section describes the extension of |Coq| with definitionally proof irrelevant propositions (types in the sort :math:`\SProp`, also -known as strict propositions). Using :math:`\SProp` may be prevented -by passing ``-disallow-sprop`` to the |Coq| program or using -:flag:`Allow StrictProp`. +known as strict propositions) as described in +:cite:`Gilbert:POPL2019`. + +Using :math:`\SProp` may be prevented by passing ``-disallow-sprop`` +to the |Coq| program or using :flag:`Allow StrictProp`. .. flag:: Allow StrictProp :name: Allow StrictProp diff --git a/doc/sphinx/addendum/type-classes.rst b/doc/sphinx/addendum/type-classes.rst index db3e20a9c6..1bbf988505 100644 --- a/doc/sphinx/addendum/type-classes.rst +++ b/doc/sphinx/addendum/type-classes.rst @@ -560,8 +560,8 @@ Settings Determines how much information is shown for typeclass resolution steps during search. 1 is the default level. 2 shows additional information such as tried tactics and shelving - of goals. Setting this option to 1 or 2 turns on :flag:`Typeclasses Debug`; setting this - option to 0 turns that option off. + of goals. Setting this option to 1 or 2 turns on the :flag:`Typeclasses Debug` flag; setting this + option to 0 turns that flag off. Typeclasses eauto `:=` ~~~~~~~~~~~~~~~~~~~~~~ diff --git a/doc/sphinx/addendum/universe-polymorphism.rst b/doc/sphinx/addendum/universe-polymorphism.rst index 905068e316..7adb25cbd6 100644 --- a/doc/sphinx/addendum/universe-polymorphism.rst +++ b/doc/sphinx/addendum/universe-polymorphism.rst @@ -129,12 +129,12 @@ Polymorphic, Monomorphic .. flag:: Universe Polymorphism - Once enabled, this option will implicitly prepend ``Polymorphic`` to any + Once enabled, this flag will implicitly prepend ``Polymorphic`` to any definition of the user. .. cmd:: Monomorphic @definition - When the :flag:`Universe Polymorphism` option is set, to make a definition + When the :flag:`Universe Polymorphism` flag is set, to make a definition producing global universe constraints, one can use the ``Monomorphic`` prefix. Many other commands support the ``Polymorphic`` flag, including: @@ -162,8 +162,8 @@ declared cumulative using the :g:`Cumulative` prefix. Declares the inductive as cumulative -Alternatively, there is a flag :flag:`Polymorphic Inductive -Cumulativity` which when set, makes all subsequent *polymorphic* +Alternatively, there is a :flag:`Polymorphic Inductive +Cumulativity` flag which when set, makes all subsequent *polymorphic* inductive definitions cumulative. When set, inductive types and the like can be enforced to be non-cumulative using the :g:`NonCumulative` prefix. @@ -174,7 +174,7 @@ prefix. .. flag:: Polymorphic Inductive Cumulativity - When this option is on, it sets all following polymorphic inductive + When this flag is on, it sets all following polymorphic inductive types as cumulative (it is off by default). Consider the examples below. @@ -222,8 +222,8 @@ Cumulative inductive types, coinductive types, variants and records only make sense when they are universe polymorphic. Therefore, an error is issued whenever the user uses the :g:`Cumulative` or :g:`NonCumulative` prefix in a monomorphic context. -Notice that this is not the case for the option :flag:`Polymorphic Inductive Cumulativity`. -That is, this option, when set, makes all subsequent *polymorphic* +Notice that this is not the case for the :flag:`Polymorphic Inductive Cumulativity` flag. +That is, this flag, when set, makes all subsequent *polymorphic* inductive declarations cumulative (unless, of course the :g:`NonCumulative` prefix is used) but has no effect on *monomorphic* inductive declarations. @@ -439,7 +439,7 @@ underscore or by omitting the annotation to a polymorphic definition. .. flag:: Strict Universe Declaration - Turning this option off allows one to freely use + Turning this flag off allows one to freely use identifiers for universes without declaring them first, with the semantics that the first use declares it. In this mode, the universe names are not associated with the definition or proof once it has been @@ -447,7 +447,7 @@ underscore or by omitting the annotation to a polymorphic definition. .. flag:: Private Polymorphic Universes - This option, on by default, removes universes which appear only in + This flag, on by default, removes universes which appear only in the body of an opaque polymorphic definition from the definition's universe arguments. As such, no value needs to be provided for these universes when instantiating the definition. Universe @@ -480,7 +480,7 @@ underscore or by omitting the annotation to a polymorphic definition. About foo. To recover the same behaviour with regard to universes as - :g:`Defined`, the option :flag:`Private Polymorphic Universes` may + :g:`Defined`, the :flag:`Private Polymorphic Universes` flag may be unset: .. coqtop:: all diff --git a/doc/sphinx/biblio.bib b/doc/sphinx/biblio.bib index 85b02013d8..db089df395 100644 --- a/doc/sphinx/biblio.bib +++ b/doc/sphinx/biblio.bib @@ -222,6 +222,25 @@ s}, year = {1890} } +@article{Gilbert:POPL2019, + author = {Gilbert, Ga\"{e}tan and Cockx, Jesper and Sozeau, Matthieu and Tabareau, Nicolas}, + title = {{Definitional Proof Irrelevance Without K}}, + journal = {Proc. ACM Program. Lang.}, + issue_date = {January 2019}, + volume = {3}, + number = {POPL}, + year = {2019}, + issn = {2475-1421}, + pages = {3:1--3:28}, + articleno = {3}, + numpages = {28}, + url = {http://doi.acm.org/10.1145/3290316}, + acmid = {3290316}, + publisher = {ACM}, + address = {New York, NY, USA}, + keywords = {proof assistants, proof irrelevance, type theory}, +} + @InProceedings{Gim94, author = {E. Gim\'enez}, booktitle = {Types'94 : Types for Proofs and Programs}, @@ -340,6 +359,27 @@ s}, year = {1997} } +@inproceedings{Visser98, + author = {Eelco Visser and + Zine{-}El{-}Abidine Benaissa and + Andrew P. Tolmach}, + title = {Building Program Optimizers with Rewriting Strategies}, + booktitle = {ICFP}, + pages = {13--26}, + year = {1998}, +} + +@inproceedings{Visser01, + author = {Eelco Visser}, + title = {Stratego: {A} Language for Program Transformation Based on Rewriting + Strategies}, + booktitle = {RTA}, + pages = {357--362}, + year = {2001}, + series = {LNCS}, + volume = {2051}, +} + @InProceedings{DBLP:conf/types/McBride00, author = {Conor McBride}, title = {Elimination with a Motive}, diff --git a/doc/sphinx/language/cic.rst b/doc/sphinx/language/cic.rst index 6410620b40..54aeed428f 100644 --- a/doc/sphinx/language/cic.rst +++ b/doc/sphinx/language/cic.rst @@ -49,7 +49,8 @@ The sort :math:`\SProp` is like :math:`\Prop` but the propositions in equal). Objects of type :math:`\SProp` are called strict propositions. :math:`\SProp` is rejected except when using the compiler option ``-allow-sprop``. See :ref:`sprop` for information about using -:math:`\SProp`. +:math:`\SProp`, and :cite:`Gilbert:POPL2019` for meta theoretical +considerations. The sort :math:`\Set` intends to be the type of small sets. This includes data types such as booleans and naturals, but also products, subsets, and @@ -1195,7 +1196,7 @@ Conversion is preserved as any (partial) instance :math:`I_j~q_1 … q_r` or .. flag:: Auto Template Polymorphism - This option, enabled by default, makes every inductive type declared + This flag, enabled by default, makes every inductive type declared at level :math:`\Type` (without annotations or hiding it behind a definition) template polymorphic if possible. @@ -1224,7 +1225,7 @@ Conversion is preserved as any (partial) instance :math:`I_j~q_1 … q_r` or .. flag:: Template Check - Unsetting option :flag:`Template Check` disables the check of + This flag is on by default. Turning it off disables the check of locality of the sorts when abstracting the inductive over its parameters. This is a deprecated and *unsafe* flag that can introduce inconsistencies, it is only meant to help users incrementally update diff --git a/doc/sphinx/language/coq-library.rst b/doc/sphinx/language/coq-library.rst index ac75240cfb..cad5e4e67e 100644 --- a/doc/sphinx/language/coq-library.rst +++ b/doc/sphinx/language/coq-library.rst @@ -756,6 +756,7 @@ subdirectories: * **Sets** : Sets (classical, constructive, finite, infinite, power set, etc.) * **FSets** : Specification and implementations of finite sets and finite maps (by lists and by AVL trees) * **Reals** : Axiomatization of real numbers (classical, basic functions, integer part, fractional part, limit, derivative, Cauchy series, power series and results,...) + * **Floats** : Machine implementation of floating-point arithmetic (for the binary64 format) * **Relations** : Relations (definitions and basic results) * **Sorting** : Sorted list (basic definitions and heapsort correctness) * **Strings** : 8-bits characters and strings @@ -768,7 +769,7 @@ are directly accessible with the command ``Require`` (see Section :ref:`compiled-files`). The different modules of the |Coq| standard library are documented -online at http://coq.inria.fr/stdlib. +online at https://coq.inria.fr/stdlib. Peano’s arithmetic (nat) ~~~~~~~~~~~~~~~~~~~~~~~~ @@ -988,6 +989,106 @@ Notation Interpretation Precedence Associativity ``_ :: _`` ``cons`` 60 right ========== ============== ========== ============= +.. _floats_library: + +Floats library +~~~~~~~~~~~~~~ + +The library of primitive floating-point arithmetic can be loaded by +requiring module ``Floats``: + +.. coqtop:: in + + Require Import Floats. + +It exports the module ``PrimFloat`` that provides a primitive type +named ``float``, defined in the kernel (see section :ref:`primitive-floats`), +as well as two variant types ``float_comparison`` and ``float_class``: + + +.. coqtop:: all + + Print float. + Print float_comparison. + Print float_class. + +It then defines the primitive operators below, using the processor +floating-point operators for binary64 in rounding-to-nearest even: + +* ``abs`` +* ``opp`` +* ``sub`` +* ``add`` +* ``mul`` +* ``div`` +* ``sqrt`` +* ``compare`` : compare two floats and return a ``float_comparison`` +* ``classify`` : analyze a float and return a ``float_class`` +* ``of_int63`` : round a primitive integer and convert it into a float +* ``normfr_mantissa`` : take a float in ``[0.5; 1.0)`` and return its mantissa +* ``frshiftexp`` : convert a float to fractional part in ``[0.5; 1.0)`` and integer part +* ``ldshiftexp`` : multiply a float by an integral power of ``2`` +* ``next_up`` : return the next float towards positive infinity +* ``next_down`` : return the next float towards negative infinity + +For special floating-point values, the following constants are also +defined: + +* ``zero`` +* ``neg_zero`` +* ``one`` +* ``two`` +* ``infinity`` +* ``neg_infinity`` +* ``nan`` : Not a Number (assumed to be unique: the "payload" of NaNs is ignored) + +The following table shows the notations available when opening scope +``float_scope``. + +=========== ============== +Notation Interpretation +=========== ============== +``- _`` ``opp`` +``_ - _`` ``sub`` +``_ + _`` ``add`` +``_ * _`` ``mul`` +``_ / _`` ``div`` +``_ == _`` ``eqb`` +``_ < _`` ``ltb`` +``_ <= _`` ``leb`` +``_ ?= _`` ``compare`` +=========== ============== + +Floating-point constants are parsed and pretty-printed as (17-digit) +decimal constants. This ensures that the composition +:math:`\text{parse} \circ \text{print}` amounts to the identity. + +.. example:: + + .. coqtop:: all + + Open Scope float_scope. + Eval compute in 1 + 0.5. + Eval compute in 1 / 0. + Eval compute in 1 / -0. + Eval compute in 0 / 0. + Eval compute in 0 ?= -0. + Eval compute in nan ?= nan. + Eval compute in next_down (-1). + +The primitive operators are specified with respect to their Gallina +counterpart, using the variant type ``spec_float``, and the injection +``Prim2SF``: + +.. coqtop:: all + + Print spec_float. + Check Prim2SF. + Check mul_spec. + +For more details on the available definitions and lemmas, see the +online documentation of the ``Floats`` library. + .. _userscontributions: Users’ contributions diff --git a/doc/sphinx/language/gallina-extensions.rst b/doc/sphinx/language/gallina-extensions.rst index f477bf239d..a047bab421 100644 --- a/doc/sphinx/language/gallina-extensions.rst +++ b/doc/sphinx/language/gallina-extensions.rst @@ -188,7 +188,7 @@ other arguments are the parameters of the inductive type. .. note:: Induction schemes are automatically generated for inductive records. Automatic generation of induction schemes for non-recursive records defined with the ``Record`` keyword can be activated with the - ``Nonrecursive Elimination Schemes`` option (see :ref:`proofschemes-induction-principles`). + :flag:`Nonrecursive Elimination Schemes` flag (see :ref:`proofschemes-induction-principles`). .. note:: ``Structure`` is a synonym of the keyword ``Record``. @@ -243,14 +243,14 @@ Primitive Projections .. flag:: Printing Primitive Projection Parameters - This compatibility option reconstructs internally omitted parameters at + This compatibility flag reconstructs internally omitted parameters at printing time (even though they are absent in the actual AST manipulated by the kernel). Primitive Record Types ++++++++++++++++++++++ -When the :flag:`Primitive Projections` option is on, definitions of +When the :flag:`Primitive Projections` flag is on, definitions of record types change meaning. When a type is declared with primitive projections, its :g:`match` construct is disabled (see :ref:`primitive_projections` though). To eliminate the (co-)inductive type, one must use its defined primitive projections. @@ -302,7 +302,7 @@ an object of the record type as arguments, and whose body is an application of the unfolded primitive projection of the same name. These constants are used when elaborating partial applications of the projection. One can distinguish them from applications of the primitive -projection if the :flag:`Printing Primitive Projection Parameters` option +projection if the :flag:`Printing Primitive Projection Parameters` flag is off: For a primitive projection application, parameters are printed as underscores while for the compatibility projections they are printed as usual. @@ -481,7 +481,7 @@ Printing nested patterns pattern matching into a single pattern matching over a nested pattern. - When this option is on (default), |Coq|’s printer tries to do such + When this flag is on (default), |Coq|’s printer tries to do such limited re-factorization. Turning it off tells |Coq| to print only simple pattern matching problems in the same way as the |Coq| kernel handles them. @@ -494,7 +494,7 @@ Factorization of clauses with same right-hand side When several patterns share the same right-hand side, it is additionally possible to share the clauses using disjunctive patterns. Assuming that the - printing matching mode is on, this option (on by default) tells |Coq|'s + printing matching mode is on, this flag (on by default) tells |Coq|'s printer to try to do this kind of factorization. Use of a default clause @@ -505,7 +505,7 @@ Use of a default clause When several patterns share the same right-hand side which do not depend on the arguments of the patterns, yet an extra factorization is possible: the disjunction of patterns can be replaced with a `_` default clause. Assuming that - the printing matching mode and the factorization mode are on, this option (on by + the printing matching mode and the factorization mode are on, this flag (on by default) tells |Coq|'s printer to use a default clause when relevant. Printing of wildcard patterns @@ -514,7 +514,7 @@ Printing of wildcard patterns .. flag:: Printing Wildcard Some variables in a pattern may not occur in the right-hand side of - the pattern matching clause. When this option is on (default), the + the pattern matching clause. When this flag is on (default), the variables having no occurrences in the right-hand side of the pattern matching clause are just printed using the wildcard symbol “_”. @@ -527,7 +527,7 @@ Printing of the elimination predicate In most of the cases, the type of the result of a matched term is mechanically synthesizable. Especially, if the result type does not - depend of the matched term. When this option is on (default), + depend of the matched term. When this flag is on (default), the result type is not printed when |Coq| knows that it can re- synthesize it. @@ -562,7 +562,7 @@ which types are written this way: ``if`` … ``then`` … ``else`` …. Use the :cmd:`Add @table` and :cmd:`Remove @table` commands to update this set. -This example emphasizes what the printing options offer. +This example emphasizes what the printing settings offer. .. example:: @@ -1311,7 +1311,7 @@ component is equal ``nat`` and hence ``M1.T`` as specified. .. flag:: Short Module Printing - This option (off by default) disables the printing of the types of fields, + This flag (off by default) disables the printing of the types of fields, leaving only their names, for the commands :cmd:`Print Module` and :cmd:`Print Module Type`. @@ -1584,7 +1584,7 @@ says that the implicit argument is maximally inserted. Each implicit argument can be declared to have to be inserted maximally or non maximally. This can be governed argument per argument by the command -:cmd:`Arguments (implicits)` or globally by the :flag:`Maximal Implicit Insertion` option. +:cmd:`Arguments (implicits)` or globally by the :flag:`Maximal Implicit Insertion` flag. .. seealso:: :ref:`displaying-implicit-args`. @@ -1757,7 +1757,7 @@ Automatic declaration of implicit arguments This command tells |Coq| to automatically detect what are the implicit arguments of a defined object. - The auto-detection is governed by options telling if strict, + The auto-detection is governed by flags telling if strict, contextual, or reversible-pattern implicit arguments must be considered or not (see :ref:`controlling-strict-implicit-args`, :ref:`controlling-strict-implicit-args`, :ref:`controlling-rev-pattern-implicit-args`, and also :ref:`controlling-insertion-implicit-args`). @@ -1827,9 +1827,9 @@ Mode for automatic declaration of implicit arguments .. flag:: Implicit Arguments - This option (off by default) allows to systematically declare implicit + This flag (off by default) allows to systematically declare implicit the arguments detectable as such. Auto-detection of implicit arguments is - governed by options controlling whether strict and contextual implicit + governed by flags controlling whether strict and contextual implicit arguments have to be considered or not. .. _controlling-strict-implicit-args: @@ -1844,11 +1844,11 @@ Controlling strict implicit arguments arguments plus, for historical reasons, a small subset of the non-strict implicit arguments. To relax this constraint and to set implicit all non strict implicit arguments by default, you can turn this - option off. + flag off. .. flag:: Strongly Strict Implicit - Use this option (off by default) to capture exactly the strict implicit + Use this flag (off by default) to capture exactly the strict implicit arguments and no more than the strict implicit arguments. .. _controlling-contextual-implicit-args: @@ -1859,7 +1859,7 @@ Controlling contextual implicit arguments .. flag:: Contextual Implicit By default, |Coq| does not automatically set implicit the contextual - implicit arguments. You can turn this option on to tell |Coq| to also + implicit arguments. You can turn this flag on to tell |Coq| to also infer contextual implicit argument. .. _controlling-rev-pattern-implicit-args: @@ -1870,7 +1870,7 @@ Controlling reversible-pattern implicit arguments .. flag:: Reversible Pattern Implicit By default, |Coq| does not automatically set implicit the reversible-pattern - implicit arguments. You can turn this option on to tell |Coq| to also infer + implicit arguments. You can turn this flag on to tell |Coq| to also infer reversible-pattern implicit argument. .. _controlling-insertion-implicit-args: @@ -1880,7 +1880,7 @@ Controlling the insertion of implicit arguments not followed by explicit argumen .. flag:: Maximal Implicit Insertion - Assuming the implicit argument mode is on, this option (off by default) + Assuming the implicit argument mode is on, this flag (off by default) declares implicit arguments to be automatically inserted when a function is partially applied and the next argument of the function is an implicit one. @@ -1927,9 +1927,11 @@ Renaming implicit arguments This command is used to redefine the names of implicit arguments. -With the assert flag, ``Arguments`` can be used to assert that a given -object has the expected number of arguments and that these arguments -are named as expected. +.. cmd:: Arguments @qualid {* @name} : assert + :name: Arguments (assert) + + This command is used to assert that a given object has the expected + number of arguments and that these arguments are named as expected. .. example:: (continued) @@ -1960,7 +1962,7 @@ Explicit displaying of implicit arguments for pretty-printing .. flag:: Printing Implicit By default, the basic pretty-printing rules hide the inferable implicit - arguments of an application. Turn this option on to force printing all + arguments of an application. Turn this flag on to force printing all implicit arguments. .. flag:: Printing Implicit Defensive @@ -1968,7 +1970,7 @@ Explicit displaying of implicit arguments for pretty-printing By default, the basic pretty-printing rules display the implicit arguments that are not detected as strict implicit arguments. This “defensive” mode can quickly make the display cumbersome so this can - be deactivated by turning this option off. + be deactivated by turning this flag off. .. seealso:: :flag:`Printing All`. @@ -1997,7 +1999,7 @@ Deactivation of implicit arguments for parsing .. flag:: Parsing Explicit - Turning this option on (it is off by default) deactivates the use of implicit arguments. + Turning this flag on (it is off by default) deactivates the use of implicit arguments. In this case, all arguments of constants, inductive types, constructors, etc, including the arguments declared as implicit, have @@ -2269,11 +2271,11 @@ Printing constructions in full Coercions, implicit arguments, the type of pattern matching, but also notations (see :ref:`syntaxextensionsandinterpretationscopes`) can obfuscate the behavior of some tactics (typically the tactics applying to occurrences of subterms are - sensitive to the implicit arguments). Turning this option on + sensitive to the implicit arguments). Turning this flag on deactivates all high-level printing features such as coercions, implicit arguments, returned type of pattern matching, notations and various syntactic sugar for pattern matching or record projections. - Otherwise said, :flag:`Printing All` includes the effects of the options + Otherwise said, :flag:`Printing All` includes the effects of the flags :flag:`Printing Implicit`, :flag:`Printing Coercions`, :flag:`Printing Synth`, :flag:`Printing Projections`, and :flag:`Printing Notations`. To reactivate the high-level printing features, use the command ``Unset Printing All``. @@ -2285,8 +2287,8 @@ Printing universes .. flag:: Printing Universes - Turn this option on to activate the display of the actual level of each - occurrence of :g:`Type`. See :ref:`Sorts` for details. This wizard option, in + Turn this flag on to activate the display of the actual level of each + occurrence of :g:`Type`. See :ref:`Sorts` for details. This wizard flag, in combination with :flag:`Printing All` can help to diagnose failures to unify terms apparently identical but internally different in the Calculus of Inductive Constructions. @@ -2297,7 +2299,7 @@ Printing universes This command can be used to print the constraints on the internal level of the occurrences of :math:`\Type` (see :ref:`Sorts`). - If the optional ``Sorted`` option is given, each universe will be made + If the ``Sorted`` keyword is present, each universe will be made equivalent to a numbered label reflecting its level (with a linear ordering) in the universe hierarchy. @@ -2355,7 +2357,7 @@ outside of its context of definition, its instance, written under the form :n:`{ {*; @ident := @term} }` is appending to its name, indicating how the variables of its defining context are instantiated. The variables of the context of the existential variables which are -instantiated by themselves are not written, unless the flag :flag:`Printing Existential Instances` +instantiated by themselves are not written, unless the :flag:`Printing Existential Instances` flag is on (see Section :ref:`explicit-display-existentials`), and this is why an existential variable used in the same context as its context of definition is written with no instance. @@ -2379,7 +2381,7 @@ Explicit displaying of existential instances for pretty-printing .. flag:: Printing Existential Instances - This option (off by default) activates the full display of how the + This flag (off by default) activates the full display of how the context of an existential variable is instantiated at each of the occurrences of the existential variable. @@ -2409,7 +2411,7 @@ by means of the interactive proof engine. .. _primitive-integers: Primitive Integers --------------------------------- +------------------ The language of terms features 63-bit machine integers as values. The type of such a value is *axiomatized*; it is declared through the following sentence @@ -2462,6 +2464,55 @@ wrapped into the :g:`Uint63.of_int` (resp. :g:`Uint63.of_int64`) constructor on 64-bit (resp. 32-bit) platforms. Currently, this cannot be customized (see the function :g:`Uint63.compile` from the kernel). +.. _primitive-floats: + +Primitive Floats +---------------- + +The language of terms features Binary64 floating-point numbers as values. +The type of such a value is *axiomatized*; it is declared through the +following sentence (excerpt from the :g:`PrimFloat` module): + +.. coqdoc:: + + Primitive float := #float64_type. + +This type is equipped with a few operators, that must be similarly declared. +For instance, the product of two primitive floats can be computed using the +:g:`PrimFloat.mul` function, declared and specified as follows: + +.. coqdoc:: + + Primitive mul := #float64_mul. + Notation "x * y" := (mul x y) : float_scope. + + Axiom mul_spec : forall x y, Prim2SF (x * y)%float = SF64mul (Prim2SF x) (Prim2SF y). + +where :g:`Prim2SF` is defined in the :g:`FloatOps` module. + +The set of such operators is described in section :ref:`floats_library`. + +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, using the floating-point processor operators that are assumed +to comply with the IEEE 754 standard for floating-point arithmetic. + +The extraction of these primitives can be customized similarly to the extraction +of regular axioms (see :ref:`extraction`). Nonetheless, the :g:`ExtrOCamlFloats` +module can be used when extracting to OCaml: it maps the Coq primitives to types +and functions of a :g:`Float64` 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. + +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)`. + Bidirectionality hints ---------------------- diff --git a/doc/sphinx/language/gallina-specification-language.rst b/doc/sphinx/language/gallina-specification-language.rst index ae9d284661..f667dd94b0 100644 --- a/doc/sphinx/language/gallina-specification-language.rst +++ b/doc/sphinx/language/gallina-specification-language.rst @@ -779,7 +779,7 @@ Simple inductive types The types of the constructors have to satisfy a *positivity condition* (see Section :ref:`positivity`). This condition ensures the soundness of the inductive definition. The positivity checking can be disabled using - the option :flag:`Positivity Checking` (see :ref:`controlling-typing-flags`). + the :flag:`Positivity Checking` flag (see :ref:`controlling-typing-flags`). .. exn:: The conclusion of @type is not valid; it must be built from @ident. @@ -956,7 +956,7 @@ Parameterized inductive types .. flag:: Uniform Inductive Parameters - When this option is set (it is off by default), + When this flag is set (it is off by default), inductive definitions are abstracted over their parameters before type checking constructors, allowing to write: @@ -991,7 +991,7 @@ Variants The :cmd:`Variant` command is identical to the :cmd:`Inductive` command, except that it disallows recursive definition of types (for instance, lists cannot be defined using :cmd:`Variant`). No induction scheme is generated for - this variant, unless option :flag:`Nonrecursive Elimination Schemes` is on. + this variant, unless the :flag:`Nonrecursive Elimination Schemes` flag is on. .. exn:: The @num th argument of @ident must be @ident in @type. :undocumented: @@ -1393,11 +1393,11 @@ Chapter :ref:`Tactics`. The basic assertion command is: The name you provided is already defined. You have then to choose another name. - .. exn:: Nested proofs are not allowed unless you turn option Nested Proofs Allowed on. + .. exn:: Nested proofs are not allowed unless you turn the :flag:`Nested Proofs Allowed` flag on. You are asserting a new statement while already being in proof editing mode. This feature, called nested proofs, is disabled by default. - To activate it, turn option :flag:`Nested Proofs Allowed` on. + To activate it, turn the :flag:`Nested Proofs Allowed` flag on. .. cmdv:: Lemma @ident {? @binders } : @type Remark @ident {? @binders } : @type @@ -1470,8 +1470,8 @@ using the keyword :cmd:`Qed`. .. note:: - #. Several statements can be simultaneously asserted provided option - :flag:`Nested Proofs Allowed` was turned on. + #. Several statements can be simultaneously asserted provided the + :flag:`Nested Proofs Allowed` flag was turned on. #. Not only other assertions but any vernacular command can be given while in the process of proving a given assertion. In this case, the @@ -1556,6 +1556,11 @@ the following attributes names are recognized: now foo. Abort. +.. warn:: Unsupported attribute + + This warning is an error by default. It is caused by using a + command with some attribute it does not understand. + .. [1] This is similar to the expression “*entry* :math:`\{` sep *entry* :math:`\}`” in standard BNF, or “*entry* :math:`(` sep *entry* diff --git a/doc/sphinx/practical-tools/coq-commands.rst b/doc/sphinx/practical-tools/coq-commands.rst index 48d5f4075e..97e7af8cb4 100644 --- a/doc/sphinx/practical-tools/coq-commands.rst +++ b/doc/sphinx/practical-tools/coq-commands.rst @@ -36,7 +36,7 @@ toplevel with the command ``Coqloop.loop();;``. .. flag:: Coqtop Exit On Error - This option, off by default, causes coqtop to exit with status code + This flag, off by default, causes coqtop to exit with status code ``1`` if a command produces an error instead of recovering from it. Batch compilation (coqc) @@ -184,6 +184,13 @@ and ``coqtop``, unless stated otherwise: :-verbose: Output the content of the input file as it is compiled. This option is available for ``coqc`` only; it is the counterpart of -compile-verbose. +:-vos: Indicate |Coq| to skip the processing of opaque proofs + (i.e., proofs ending with ``Qed`` or ``Admitted``), output a ``.vos`` files + instead of a ``.vo`` file, and to load ``.vos`` files instead of ``.vo`` files + when interpreting ``Require`` commands. +:-vok: Indicate |Coq| to check a file completely, to load ``.vos`` files instead + of ``.vo`` files when interpreting ``Require`` commands, and to output an empty + ``.vok`` files upon success instead of writing a ``.vo`` file. :-w (all|none|w₁,…,wₙ): Configure the display of warnings. This option expects all, none or a comma-separated list of warning names or categories (see Section :ref:`controlling-display`). @@ -212,7 +219,7 @@ and ``coqtop``, unless stated otherwise: .. warning:: This makes the logic inconsistent. :-mangle-names *ident*: *Experimental.* Do not depend on this option. Replace Coq's auto-generated name scheme with names of the form *ident0*, *ident1*, - etc. Within Coq, the flag :flag:`Mangle Names` turns this behavior on, + etc. Within Coq, the :flag:`Mangle Names` flag turns this behavior on, and the :opt:`Mangle Names Prefix` option sets the prefix to use. This feature is intended to be used as a linter for developments that want to be robust to changes in the auto-generated name scheme. The options are provided to @@ -245,6 +252,119 @@ and ``coqtop``, unless stated otherwise: currently associated color and exit. :-h, --help: Print a short usage and exit. + + +Compiled interfaces (produced using ``-vos``) +---------------------------------------------- + +Compiled interfaces help saving time while developing Coq formalizations, +by compiling the formal statements exported by a library independently of +the proofs that it contains. + + .. warning:: + + Compiled interfaces should only be used for development purposes. + At the end of the day, one still needs to proof check all files + by producing standard ``.vo`` files. (Technically, when using ``-vos``, + fewer universe constraints are collected.) + Moreover, this feature is still experimental, it may be subject to + change without prior notice. + +**Principle.** + +The compilation using ``coqc -vos foo.v`` produces a file called ``foo.vos``, +which is similar to ``foo.vo`` except that all opaque proofs are skipped in +the compilation process. + +The compilation using ``coqc -vok foo.v`` checks that the file ``foo.v`` +correctly compiles, including all its opaque proofs. If the compilation +succeeds, then the output is a file called ``foo.vok``, with empty contents. +This file is only a placeholder indicating that ``foo.v`` has been successfully +compiled. (This placeholder is useful for build systems such as ``make``.) + +When compiling a file ``bar.v`` that depends on ``foo.v`` (for example via +a ``Require Foo.`` command), if the compilation command is ``coqc -vos bar.v`` +or ``coqc -vok bar.v``, then the file ``foo.vos`` gets loaded (instead of +``foo.vo``). A special case is if file ``foo.vos`` exists and has empty +contents, and ``foo.vo`` exists, then ``foo.vo`` is loaded. + +Appart from the aforementioned case where ``foo.vo`` can be loaded in place +of ``foo.vos``, in general the ``.vos`` and ``.vok`` files live totally +independently from the ``.vo`` files. + +**Dependencies generated by ``coq_makefile``.** + +The files ``foo.vos`` and ``foo.vok`` both depend on ``foo.v``. + +Furthermore, if a file ``foo.v`` requires ``bar.v``, then ``foo.vos`` +and ``foo.vok`` also depend on ``bar.vos``. + +Note, however, that ``foo.vok`` does not depend on ``bar.vok``. +Hence, as detailed further, parallel compilation of proofs is possible. + +In addition, ``coq_makefile`` generates for a file ``foo.v`` a target +``foo.required_vos`` which depends on the list of ``.vos`` files that +``foo.vos`` depends upon (excluding ``foo.vos`` itself). As explained +next, the purpose of this target is to be able to request the minimal +working state for editing interactively the file ``foo.v``. + +**Typical compilation of a set of file using a build system.** + +Assume a file ``foo.v`` that depends on two files ``f1.v`` and ``f2.v``. The +command ``make foo.required_vos`` will compile ``f1.v`` and ``f2.v`` using +the option ``-vos`` to skip the proofs, producing ``f1.vos`` and ``f2.vos``. +At this point, one is ready to work interactively on the file ``foo.v``, even +though it was never needed to compile the proofs involved in the files ``f1.v`` +and ``f2.v``. + +Assume a set of files ``f1.v ... fn.v`` with linear dependencies. The command +``make vos`` enables compiling the statements (i.e. excluding the proofs) in all +the files. Next, ``make -j vok`` enables compiling all the proofs in parallel. +Thus, calling ``make -j vok`` directly enables taking advantage of a maximal +amount of parallelism during the compilation of the set of files. + +Note that this comes at the cost of parsing and typechecking all definitions +twice, once for the ``.vos`` file and once for the ``.vok`` file. However, if +files contain nontrivial proofs, or if the files have many linear chains of +dependencies, or if one has many cores available, compilation should be faster +overall. + +**Need for ``Proof using``** + +When a theorem is part of a section, typechecking the statement of this theorem +might be insufficient for deducing the type of this statement as of at the end +of the section. Indeed, the proof of the theorem could make use of section +variables or section hypotheses that are not mentioned in the statement of the +theorem. + +For this reason, proofs inside section should begin with :cmd:`Proof using` +instead of :cmd:`Proof`, where after the ``using`` clause one should provide +the list of the names of the section variables that are required for the proof +but are not involved in the typechecking of the statement. Note that it is safe +to write ``Proof using.`` instead of ``Proof.`` also for proofs that are not +within a section. + +.. warn:: You should use the “Proof using [...].” syntax instead of “Proof.” to enable skipping this proof which is located inside a section. Give as argument to “Proof using” the list of section variables that are not needed to typecheck the statement but that are required by the proof. + + If |Coq| is invoked using the ``-vos`` option, whenever it finds the + command ``Proof.`` inside a section, it will compile the proof, that is, + refuse to skip it, and it will raise a warning. To disable the warning, one + may pass the flag ``-w -proof-without-using-in-section``. + +**Interaction with standard compilation** + +When compiling a file ``foo.v`` using ``coqc`` in the standard way (i.e., without +``-vos`` nor ``-vok``), an empty file ``foo.vos`` is created in addition to the +regular output file ``foo.vo``. If ``coqc`` is subsequently invoked on some other +file ``bar.v`` using option ``-vos`` or ``-vok``, and that ``bar.v`` requires +``foo.v``, if |Coq| finds an empty file ``foo.vos``, then it will load +``foo.vo`` instead of ``foo.vos``. + +The purpose of this feature is to allow users to benefit from the ``-vos`` +option even if they depend on libraries that were compiled in the traditional +manner (i.e., never compiled using the ``-vos`` option). + + Compiled libraries checker (coqchk) ---------------------------------------- diff --git a/doc/sphinx/proof-engine/ltac.rst b/doc/sphinx/proof-engine/ltac.rst index 6efc634087..e37f300915 100644 --- a/doc/sphinx/proof-engine/ltac.rst +++ b/doc/sphinx/proof-engine/ltac.rst @@ -860,8 +860,8 @@ We can carry out pattern matching on terms with: If the evaluation of the right-hand-side of a valid match fails, the next matching subterm is tried. If no further subterm matches, the next clause is tried. Matching subterms are considered top-bottom and from left to - right (with respect to the raw printing obtained by setting option - :flag:`Printing All`). + right (with respect to the raw printing obtained by setting the + :flag:`Printing All` flag). .. example:: @@ -1642,7 +1642,7 @@ Interactive debugger .. flag:: Ltac Debug - This option governs the step-by-step debugger that comes with the |Ltac| interpreter. + This flag governs the step-by-step debugger that comes with the |Ltac| interpreter. When the debugger is activated, it stops at every step of the evaluation of the current |Ltac| expression and prints information on what it is doing. @@ -1666,13 +1666,13 @@ following: .. exn:: Debug mode not available in the IDE :undocumented: -A non-interactive mode for the debugger is available via the option: +A non-interactive mode for the debugger is available via the flag: .. flag:: Ltac Batch Debug - This option has the effect of presenting a newline at every prompt, when + This flag has the effect of presenting a newline at every prompt, when the debugger is on. The debug log thus created, which does not require - user input to generate when this option is set, can then be run through + user input to generate when this flag is set, can then be run through external tools such as diff. Profiling |Ltac| tactics @@ -1691,7 +1691,7 @@ performance issue. .. flag:: Ltac Profiling - This option enables and disables the profiler. + This flag enables and disables the profiler. .. cmd:: Show Ltac Profile @@ -1775,7 +1775,7 @@ performance issue. benchmarking purposes. You can also pass the ``-profile-ltac`` command line option to ``coqc``, which -turns the :flag:`Ltac Profiling` option on at the beginning of each document, +turns the :flag:`Ltac Profiling` flag on at the beginning of each document, and performs a :cmd:`Show Ltac Profile` at the end. .. warning:: diff --git a/doc/sphinx/proof-engine/ltac2.rst b/doc/sphinx/proof-engine/ltac2.rst index 18d2c79461..cfdc70d50e 100644 --- a/doc/sphinx/proof-engine/ltac2.rst +++ b/doc/sphinx/proof-engine/ltac2.rst @@ -563,6 +563,20 @@ for it. - `&x` as a Coq constr expression expands to `ltac2:(Control.refine (fun () => hyp @x))`. +In the special case where Ltac2 antiquotations appear inside a Coq term +notation, the notation variables are systematically bound in the body +of the tactic expression with type `Ltac2.Init.preterm`. Such a type represents +untyped syntactic Coq expressions, which can by typed in the +current context using the `Ltac2.Constr.pretype` function. + +.. example:: + + The following notation is essentially the identity. + + .. coqtop:: in + + Notation "[ x ]" := ltac2:(let x := Ltac2.Constr.pretype x in exact $x) (only parsing). + Dynamic semantics ***************** diff --git a/doc/sphinx/proof-engine/proof-handling.rst b/doc/sphinx/proof-engine/proof-handling.rst index 00f8269dc3..6884b6e998 100644 --- a/doc/sphinx/proof-engine/proof-handling.rst +++ b/doc/sphinx/proof-engine/proof-handling.rst @@ -804,7 +804,7 @@ Controlling the effect of proof editing commands .. flag:: Nested Proofs Allowed - When turned on (it is off by default), this option enables support for nested + When turned on (it is off by default), this flag enables support for nested proofs: a new assertion command can be inserted before the current proof is finished, in which case Coq will temporarily switch to the proof of this *nested lemma*. When the proof of the nested lemma is finished (with :cmd:`Qed` diff --git a/doc/sphinx/proof-engine/ssreflect-proof-language.rst b/doc/sphinx/proof-engine/ssreflect-proof-language.rst index 75897fec45..4c697be963 100644 --- a/doc/sphinx/proof-engine/ssreflect-proof-language.rst +++ b/doc/sphinx/proof-engine/ssreflect-proof-language.rst @@ -2764,7 +2764,7 @@ typeclass inference. .. flag:: SsrHave NoTCResolution - This option restores the behavior of |SSR| 1.4 and below (never resolve typeclasses). + This flag restores the behavior of |SSR| 1.4 and below (never resolve typeclasses). Variants: the suff and wlog tactics ``````````````````````````````````` @@ -3756,8 +3756,11 @@ involves the following steps: the corresponding intro pattern :n:`@i_pattern__i` in each goal. 4. Then :tacn:`under` checks that the first n subgoals - are (quantified) equalities or double implications between a - term and an evar (e.g. ``m - m = ?F2 m`` in the running example). + are (quantified) Leibniz equalities, double implications or + registered relations (w.r.t. Class ``RewriteRelation``) between a + term and an evar, e.g. ``m - m = ?F2 m`` in the running example. + (This support for setoid-like relations is enabled as soon as we do + both ``Require Import ssreflect.`` and ``Require Setoid.``) 5. If so :tacn:`under` protects these n goals against an accidental instantiation of the evar. @@ -3769,7 +3772,10 @@ involves the following steps: by using a regular :tacn:`rewrite` tactic. 7. Interactive editing of the first n goals has to be signalled by - using the :tacn:`over` tactic or rewrite rule (see below). + using the :tacn:`over` tactic or rewrite rule (see below), which + requires that the underlying relation is reflexive. (The running + example deals with Leibniz equality, but ``PreOrder`` relations are + also supported, for example.) 8. Finally, a post-processing step is performed in the main goal to keep the name(s) for the bound variables chosen by the user in @@ -3795,6 +3801,10 @@ displayed as ``'Under[ … ]``): This is a variant of :tacn:`over` in order to close ``'Under[ … ]`` goals, relying on the ``over`` rewrite rule. +Note that a rewrite rule ``UnderE`` is available as well, if one wants +to "unprotect" the evar, without closing the goal automatically (e.g., +to instantiate it manually with another rule than reflexivity). + .. _under_one_liner: One-liner mode diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index 78753fc053..ad7f9af0f9 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -261,7 +261,7 @@ These patterns can be used when the hypothesis is an equality: conjunctive pattern that doesn't give enough simple patterns to match all the arguments in the constructor. If set (the default), |Coq| generates additional names to match the number of arguments. - Unsetting the option will put the additional hypotheses in the goal instead, behavior that is more + Unsetting the flag will put the additional hypotheses in the goal instead, behavior that is more similar to |SSR|'s intro patterns. .. deprecated:: 8.10 @@ -477,7 +477,7 @@ that occurrences have to be selected in the hypotheses named :token:`ident`. If no numbers are given for hypothesis :token:`ident`, then all the occurrences of :token:`term` in the hypothesis are selected. If numbers are given, they refer to occurrences of :token:`term` when the term is printed -using option :flag:`Printing All`, counting from left to right. In particular, +using the :flag:`Printing All` flag, counting from left to right. In particular, occurrences of :token:`term` in implicit arguments (see :ref:`ImplicitArguments`) or coercions (see :ref:`Coercions`) are counted. @@ -804,11 +804,11 @@ Applying theorems component of the tuple matches the goal, it excludes components whose statement would result in applying an universal lemma of the form ``forall A, ... -> A``. Excluding this kind of lemma can be avoided by - setting the following option: + setting the following flag: .. flag:: Universal Lemma Under Conjunction - This option, which preserves compatibility with versions of Coq prior to + This flag, which preserves compatibility with versions of Coq prior to 8.4 is also available for :n:`apply @term in @ident` (see :tacn:`apply ... in`). .. tacn:: apply @term in @ident @@ -1527,7 +1527,7 @@ name of the variable (here :g:`n`) is chosen based on :g:`T`. This is equivalent to :n:`generalize @term` but it generalizes only over the specified occurrences of :n:`@term` (counting from left to right on the - expression printed using option :flag:`Printing All`). + expression printed using the :flag:`Printing All` flag). .. tacv:: generalize @term as @ident @@ -2300,16 +2300,16 @@ and an explanation of the underlying technique. .. flag:: Structural Injection - This option ensure that :n:`injection @term` erases the original hypothesis + This flag ensures that :n:`injection @term` erases the original hypothesis and leaves the generated equalities in the context rather than putting them as antecedents of the current goal, as if giving :n:`injection @term as` - (with an empty list of names). This option is off by default. + (with an empty list of names). This flag is off by default. .. flag:: Keep Proof Equalities By default, :tacn:`injection` only creates new equalities between :n:`@term`\s whose type is in sort :g:`Type` or :g:`Set`, thus implementing a special - behavior for objects that are proofs of a statement in :g:`Prop`. This option + behavior for objects that are proofs of a statement in :g:`Prop`. This flag controls this behavior. .. tacn:: inversion @ident @@ -2862,26 +2862,26 @@ simply :g:`t=u` dropping the implicit type of :g:`t` and :g:`u`. .. flag:: Regular Subst Tactic - This option controls the behavior of :tacn:`subst`. When it is + This flag controls the behavior of :tacn:`subst`. When it is activated (it is by default), :tacn:`subst` also deals with the following corner cases: + A context with ordered hypotheses :n:`@ident`:sub:`1` :n:`= @ident`:sub:`2` and :n:`@ident`:sub:`1` :n:`= t`, or :n:`t′ = @ident`:sub:`1`` with `t′` not a variable, and no other hypotheses of the form :n:`@ident`:sub:`2` :n:`= u` - or :n:`u = @ident`:sub:`2`; without the option, a second call to + or :n:`u = @ident`:sub:`2`; without the flag, a second call to subst would be necessary to replace :n:`@ident`:sub:`2` by `t` or `t′` respectively. - + The presence of a recursive equation which without the option would + + The presence of a recursive equation which without the flag would be a cause of failure of :tacn:`subst`. + A context with cyclic dependencies as with hypotheses :n:`@ident`:sub:`1` :n:`= f @ident`:sub:`2` and :n:`@ident`:sub:`2` :n:`= g @ident`:sub:`1` which without the - option would be a cause of failure of :tacn:`subst`. + flag would be a cause of failure of :tacn:`subst`. Additionally, it prevents a local definition such as :n:`@ident := t` to be unfolded which otherwise it would exceptionally unfold in configurations containing hypotheses of the form :n:`@ident = u`, or :n:`u′ = @ident` with `u′` not a variable. Finally, it preserves the initial order of - hypotheses, which without the option it may break. + hypotheses, which without the flag it may break. default. @@ -3086,7 +3086,7 @@ the conversion in hypotheses :n:`{+ @ident}`. .. flag:: NativeCompute Profiling - On Linux, if you have the ``perf`` profiler installed, this option makes + On Linux, if you have the ``perf`` profiler installed, this flag makes it possible to profile :tacn:`native_compute` evaluations. .. opt:: NativeCompute Profile Filename @string @@ -3103,7 +3103,7 @@ the conversion in hypotheses :n:`{+ @ident}`. .. flag:: Debug Cbv - This option makes :tacn:`cbv` (and its derivative :tacn:`compute`) print + This flag makes :tacn:`cbv` (and its derivative :tacn:`compute`) print information about the constants it encounters and the unfolding decisions it makes. @@ -3271,7 +3271,7 @@ the conversion in hypotheses :n:`{+ @ident}`. .. flag:: Debug RAKAM - This option makes :tacn:`cbn` print various debugging information. + This flag makes :tacn:`cbn` print various debugging information. ``RAKAM`` is the Refolding Algebraic Krivine Abstract Machine. .. tacn:: unfold @qualid @@ -3548,7 +3548,7 @@ Automation Info Trivial Debug Trivial - These options enable printing of informative or debug information for + These flags enable printing of informative or debug information for the :tacn:`auto` and :tacn:`trivial` tactics. .. tacn:: eauto @@ -3576,7 +3576,7 @@ Automation The various options for :tacn:`eauto` are the same as for :tacn:`auto`. - :tacn:`eauto` also obeys the following options: + :tacn:`eauto` also obeys the following flags: .. flag:: Info Eauto Debug Eauto @@ -3720,7 +3720,7 @@ automatically created. .. cmdv:: Local Hint @hint_definition : {+ @ident} This is used to declare hints that must not be exported to the other modules - that require and import the current module. Inside a section, the option + that require and import the current module. Inside a section, the flag Local is useless since hints do not survive anyway to the closure of sections. @@ -4196,7 +4196,7 @@ some incompatibilities. .. flag:: Intuition Negation Unfolding Controls whether :tacn:`intuition` unfolds inner negations which do not need - to be unfolded. This option is on by default. + to be unfolded. This flag is on by default. .. tacn:: rtauto :name: rtauto @@ -4316,7 +4316,7 @@ some incompatibilities. .. flag:: Congruence Verbose - This option makes :tacn:`congruence` print debug information. + This flag makes :tacn:`congruence` print debug information. Checking properties of terms diff --git a/doc/sphinx/proof-engine/vernacular-commands.rst b/doc/sphinx/proof-engine/vernacular-commands.rst index 843459b723..e87b76b4ab 100644 --- a/doc/sphinx/proof-engine/vernacular-commands.rst +++ b/doc/sphinx/proof-engine/vernacular-commands.rst @@ -962,7 +962,7 @@ Controlling display .. flag:: Silent - This option controls the normal displaying. + This flag controls the normal displaying. .. opt:: Warnings "{+, {? {| - | + } } @ident }" :name: Warnings @@ -977,7 +977,7 @@ Controlling display .. flag:: Search Output Name Only - This option restricts the output of search commands to identifier names; + This flag restricts the output of search commands to identifier names; turning it on causes invocations of :cmd:`Search`, :cmd:`SearchHead`, :cmd:`SearchPattern`, :cmd:`SearchRewrite` etc. to omit types from their output, printing only identifiers. @@ -998,7 +998,7 @@ Controlling display .. flag:: Printing Compact Contexts - This option controls the compact display mode for goals contexts. When on, + This flag controls the compact display mode for goals contexts. When on, the printer tries to reduce the vertical size of goals contexts by putting several variables (even if of different types) on the same line provided it does not exceed the printing width (see :opt:`Printing Width`). At the time @@ -1006,13 +1006,13 @@ Controlling display .. flag:: Printing Unfocused - This option controls whether unfocused goals are displayed. Such goals are + This flag controls whether unfocused goals are displayed. Such goals are created by focusing other goals with bullets (see :ref:`bullets` or :ref:`curly braces <curly-braces>`). It is off by default. .. flag:: Printing Dependent Evars Line - This option controls the printing of the “(dependent evars: …)” information + This flag controls the printing of the “(dependent evars: …)” information after each tactic. The information is used by the Prooftree tool in Proof General. (https://askra.de/software/prooftree) @@ -1213,7 +1213,7 @@ Controlling Typing Flags .. flag:: Guard Checking - This option can be used to enable/disable the guard checking of + This flag can be used to enable/disable the guard checking of fixpoints. Warning: this can break the consistency of the system, use at your own risk. Decreasing argument can still be specified: the decrease is not checked anymore but it still affects the reduction of the term. Unchecked fixpoints are @@ -1221,14 +1221,14 @@ Controlling Typing Flags .. flag:: Positivity Checking - This option can be used to enable/disable the positivity checking of inductive + This flag can be used to enable/disable the positivity checking of inductive types and the productivity checking of coinductive types. Warning: this can break the consistency of the system, use at your own risk. Unchecked (co)inductive types are printed by :cmd:`Print Assumptions`. .. flag:: Universe Checking - This option can be used to enable/disable the checking of universes, providing a + This flag can be used to enable/disable the checking of universes, providing a form of "type in type". Warning: this breaks the consistency of the system, use at your own risk. Constants relying on "type in type" are printed by :cmd:`Print Assumptions`. It has the same effect as `-type-in-type` command line diff --git a/doc/sphinx/user-extensions/proof-schemes.rst b/doc/sphinx/user-extensions/proof-schemes.rst index 3a12ee288a..5b0b3c51b0 100644 --- a/doc/sphinx/user-extensions/proof-schemes.rst +++ b/doc/sphinx/user-extensions/proof-schemes.rst @@ -128,7 +128,7 @@ Automatic declaration of schemes .. warning:: - You have to be careful with this option since Coq may now reject well-defined + You have to be careful with these flags since Coq may now reject well-defined inductive types because it cannot compute a Boolean equality for them. .. flag:: Rewriting Schemes diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index a28ce600ca..02910e603a 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -1442,8 +1442,8 @@ Numeral notations of the resulting term will be refreshed. Note that only fully-reduced ground terms (terms containing only - function application, constructors, inductive type families, and - primitive integers) will be considered for printing. + function application, constructors, inductive type families, + sorts, and primitive integers) will be considered for printing. .. cmdv:: Numeral Notation @ident__1 @ident__2 @ident__3 : @scope (warning after @num). @@ -1592,8 +1592,8 @@ String notations of the resulting term will be refreshed. Note that only fully-reduced ground terms (terms containing only - function application, constructors, inductive type families, and - primitive integers) will be considered for printing. + function application, constructors, inductive type families, + sorts, and primitive integers) will be considered for printing. .. exn:: Cannot interpret this string as a value of type @type diff --git a/doc/stdlib/hidden-files b/doc/stdlib/hidden-files index bb6df87970..a2bc90ffc0 100644 --- a/doc/stdlib/hidden-files +++ b/doc/stdlib/hidden-files @@ -13,6 +13,7 @@ plugins/extraction/ExtrHaskellZNum.v plugins/extraction/ExtrOcamlBasic.v plugins/extraction/ExtrOcamlBigIntConv.v plugins/extraction/ExtrOCamlInt63.v +plugins/extraction/ExtrOCamlFloats.v plugins/extraction/ExtrOcamlIntConv.v plugins/extraction/ExtrOcamlNatBigInt.v plugins/extraction/ExtrOcamlNatInt.v @@ -82,3 +83,5 @@ plugins/setoid_ring/Rings_Q.v plugins/setoid_ring/Rings_R.v plugins/setoid_ring/Rings_Z.v plugins/setoid_ring/ZArithRing.v +plugins/ssr/ssrunder.v +plugins/ssr/ssrsetoid.v diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index f0ada745e7..851510b465 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -328,6 +328,19 @@ through the <tt>Require Import</tt> command.</p> theories/Numbers/Integer/Binary/ZBinary.v theories/Numbers/Integer/NatPairs/ZNatPairs.v </dd> + + <dt> <b> Floats</b>: + Floating-point arithmetic + </dt> + <dd> + theories/Floats/FloatClass.v + theories/Floats/PrimFloat.v + theories/Floats/SpecFloat.v + theories/Floats/FloatOps.v + theories/Floats/FloatAxioms.v + theories/Floats/FloatLemmas.v + (theories/Floats/Floats.v) + </dd> </dl> </dd> @@ -607,6 +620,7 @@ through the <tt>Require Import</tt> command.</p> </dt> <dd> plugins/ssrmatching/ssrmatching.v + plugins/ssr/ssrclasses.v plugins/ssr/ssreflect.v plugins/ssr/ssrbool.v plugins/ssr/ssrfun.v diff --git a/engine/eConstr.ml b/engine/eConstr.ml index 23d066df58..46a80239cf 100644 --- a/engine/eConstr.ml +++ b/engine/eConstr.ml @@ -76,6 +76,7 @@ let mkProj (p, c) = of_kind (Proj (p, c)) 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 mkRef (gr,u) = let open GlobRef in match gr with | ConstRef c -> mkConstU (c,u) @@ -334,7 +335,7 @@ let iter_with_full_binders sigma g f n c = let open Context.Rel.Declaration in match kind sigma c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ - | Construct _ | Int _) -> () + | Construct _ | Int _ | Float _) -> () | Cast (c,_,t) -> f n c; f n t | Prod (na,t,c) -> f n t; f (g (LocalAssum (na, t)) n) c | Lambda (na,t,c) -> f n t; f (g (LocalAssum (na, t)) n) c diff --git a/engine/eConstr.mli b/engine/eConstr.mli index 2afce38db7..90f50b764c 100644 --- a/engine/eConstr.mli +++ b/engine/eConstr.mli @@ -127,6 +127,7 @@ 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 mkRef : GlobRef.t * EInstance.t -> t diff --git a/engine/namegen.ml b/engine/namegen.ml index 89c2fade62..b850f38b4d 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 _ -> None + | Sort _ | Rel _ | Meta _|Evar _|Case (_, _, _, _) | Int _ | Float _ -> None in hdrec c @@ -165,6 +165,7 @@ let hdchar env sigma c = | Evar _ (* We could do better... *) | Meta _ | Case (_, _, _, _) -> "y" | Int _ -> "i" + | Float _ -> "f" in hdrec 0 c diff --git a/engine/termops.ml b/engine/termops.ml index 2ab2f60421..90fa8546ce 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -600,7 +600,7 @@ let map_constr_with_binders_left_to_right sigma g f l c = let open EConstr in match EConstr.kind sigma c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ - | Construct _ | Int _) -> c + | Construct _ | Int _ | Float _) -> c | Cast (b,k,t) -> let b' = f l b in let t' = f l t in @@ -681,7 +681,7 @@ let map_constr_with_full_binders_gen userview sigma g f l cstr = let open EConstr in match EConstr.kind sigma cstr with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ - | Construct _ | Int _) -> cstr + | Construct _ | Int _ | Float _) -> cstr | Cast (c,k, t) -> let c' = f l c in let t' = f l t in diff --git a/ide/gtk_parsing.ml b/ide/gtk_parsing.ml index a84c161a84..8e6d9f75c7 100644 --- a/ide/gtk_parsing.ml +++ b/ide/gtk_parsing.ml @@ -12,50 +12,45 @@ let underscore = Glib.Utf8.to_unichar "_" ~pos:(ref 0) let prime = Glib.Utf8.to_unichar "'" ~pos:(ref 0) let dot = Glib.Utf8.to_unichar "." ~pos:(ref 0) -(* TODO: avoid num and prime at the head of a word *) -let is_word_char c = - Glib.Unichar.isalnum c || c = underscore || c = prime || c = dot +let find_word_start (it:GText.iter) = + let rec aux it good = + if it#is_start then good + else + let it = it#backward_char in + let c = it#char in + if Glib.Unichar.isalpha c || c = underscore then aux it it + else if Glib.Unichar.isalnum c || c = prime || c = dot then aux it good + else good in + aux it it +let find_word_end (it:GText.iter) = + let rec aux it good = + if it#is_end then good + else + let c = it#char in + let it = it#forward_char in + if Glib.Unichar.isalnum c || c = prime || c = underscore then aux it it + else if c = dot then aux it good + else good in + aux it it let starts_word (it:GText.iter) = - (it#is_start || - (let c = it#backward_char#char in - not (is_word_char c))) + if it#is_start then true + else + let it = it#backward_char in + let c = it#char in + if Glib.Unichar.isalpha c || c = underscore then + it#equal (find_word_start it) + else false let ends_word (it:GText.iter) = - (it#is_end || - let c = it#forward_char#char in - not (is_word_char c) - ) - -let find_word_start (it:GText.iter) = - let rec step_to_start it = - Minilib.log "Find word start"; - if not it#nocopy#backward_char then - (Minilib.log "find_word_start: cannot backward"; it) - else if is_word_char it#char - then step_to_start it - else begin - ignore(it#nocopy#forward_char); - Minilib.log ("Word start at: "^(string_of_int it#offset)); - it - end - in - step_to_start it#copy - -let find_word_end (it:GText.iter) = - let rec step_to_end (it:GText.iter) = - Minilib.log "Find word end"; + if it#is_end then true + else let c = it#char in - if c<>0 && is_word_char c then ( - ignore (it#nocopy#forward_char); - step_to_end it - ) else ( - Minilib.log ("Word end at: "^(string_of_int it#offset)); - it) - in - step_to_end it#copy - + let it = it#forward_char in + if Glib.Unichar.isalnum c || c = prime || c = underscore then + it#equal (find_word_end it) + else false let get_word_around (it:GText.iter) = let start = find_word_start it in diff --git a/ide/wg_Completion.ml b/ide/wg_Completion.ml index 98390e810f..ac6712909e 100644 --- a/ide/wg_Completion.ml +++ b/ide/wg_Completion.ml @@ -175,7 +175,7 @@ object (self) let log = Printf.sprintf "Completion at offset: %i" insert_offset in let () = Minilib.log log in let prefix = - if Gtk_parsing.ends_word iter#backward_char then + if Gtk_parsing.ends_word iter then let start = Gtk_parsing.find_word_start iter in let w = buffer#get_text ~start ~stop:iter () in if String.length w >= auto_complete_length then Some (w, start) diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 217381d854..0a1371413a 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -752,6 +752,30 @@ let extended_glob_local_binder_of_decl loc = function let extended_glob_local_binder_of_decl ?loc u = DAst.make ?loc (extended_glob_local_binder_of_decl loc u) (**********************************************************************) +(* mapping special floats *) + +(* this helper function is copied from notation.ml as it's not exported *) +let qualid_of_ref n = + n |> Coqlib.lib_ref |> Nametab.shortest_qualid_of_global Id.Set.empty + +let q_infinity () = qualid_of_ref "num.float.infinity" +let q_neg_infinity () = qualid_of_ref "num.float.neg_infinity" +let q_nan () = qualid_of_ref "num.float.nan" + +let extern_float f scopes = + if Float64.is_nan f then CRef(q_nan (), None) + else if Float64.is_infinity f then CRef(q_infinity (), None) + else if Float64.is_neg_infinity f then CRef(q_neg_infinity (), None) + else + let sign = if Float64.sign f then SMinus else SPlus in + let s = Float64.(to_string (abs f)) in + match NumTok.of_string s with + | None -> assert false + | Some n -> + extern_prim_token_delimiter_if_required (Numeral (sign, n)) + "float" "float_scope" scopes + +(**********************************************************************) (* mapping glob_constr to constr_expr *) let extern_glob_sort = function @@ -972,6 +996,8 @@ let rec extern inctx scopes vars r = (Numeral (SPlus, NumTok.int (Uint63.to_string i))) "int63" "int63_scope" (snd scopes) + | GFloat f -> extern_float f (snd scopes) + in insert_coercion coercion (CAst.make ?loc c) and extern_typ (subentry,(_,scopes)) = @@ -1314,6 +1340,7 @@ let rec glob_of_pat avoid env sigma pat = DAst.make @@ match pat with | PSort Sorts.InSet -> GSort (UNamed [GSet,0]) | PSort Sorts.InType -> GSort (UAnonymous {rigid=true}) | PInt i -> GInt i + | PFloat f -> GFloat f 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/impargs.ml b/interp/impargs.ml index 5f41c2a366..0de4eb5fa1 100644 --- a/interp/impargs.ml +++ b/interp/impargs.ml @@ -216,7 +216,7 @@ let rec is_rigid_head sigma t = match kind sigma t 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 _ -> assert false + | Prod _ | Meta _ | Cast _ | Int _ | Float _ -> assert false let is_rigid env sigma t = let open Context.Rel.Declaration in diff --git a/interp/notation.ml b/interp/notation.ml index 70d3e4175e..c157cf43fb 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -503,6 +503,9 @@ let rec constr_of_glob env sigma g = match DAst.get g with let sigma,cl = List.fold_left_map (constr_of_glob env) sigma gcl in sigma,mkApp (c, Array.of_list cl) | Glob_term.GInt i -> sigma, mkInt i + | Glob_term.GSort gs -> + let sigma,c = Evd.fresh_sort_in_family sigma (Glob_ops.glob_sort_family gs) in + sigma,mkSort c | _ -> raise NotAValidPrimToken @@ -516,6 +519,10 @@ let rec glob_of_constr token_kind ?loc env sigma c = match Constr.kind c with | Ind (ind, _) -> DAst.make ?loc (Glob_term.GRef (GlobRef.IndRef ind, None)) | Var id -> DAst.make ?loc (Glob_term.GRef (GlobRef.VarRef id, None)) | Int i -> DAst.make ?loc (Glob_term.GInt i) + | Sort Sorts.SProp -> DAst.make ?loc (Glob_term.GSort (Glob_term.UNamed [Glob_term.GSProp, 0])) + | Sort Sorts.Prop -> DAst.make ?loc (Glob_term.GSort (Glob_term.UNamed [Glob_term.GProp, 0])) + | Sort Sorts.Set -> DAst.make ?loc (Glob_term.GSort (Glob_term.UNamed [Glob_term.GSet, 0])) + | Sort (Sorts.Type _) -> DAst.make ?loc (Glob_term.GSort (Glob_term.UAnonymous {rigid=true})) | _ -> Loc.raise ?loc (PrimTokenNotationError(token_kind,env,sigma,UnexpectedTerm c)) let no_such_prim_token uninterpreted_token_kind ?loc ty = diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index f30a874426..7e146754b2 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -90,9 +90,11 @@ let rec eq_notation_constr (vars1,vars2 as vars) t1 t2 = match t1, t2 with (eq_notation_constr vars) t1 t2 && cast_type_eq (eq_notation_constr vars) c1 c2 | NInt i1, NInt i2 -> Uint63.equal i1 i2 +| NFloat f1, NFloat f2 -> + Float64.equal f1 f2 | (NRef _ | NVar _ | NApp _ | NHole _ | NList _ | NLambda _ | NProd _ | NBinderList _ | NLetIn _ | NCases _ | NLetTuple _ | NIf _ - | NRec _ | NSort _ | NCast _ | NInt _), _ -> false + | NRec _ | NSort _ | NCast _ | NInt _ | NFloat _), _ -> false (**********************************************************************) (* Re-interpret a notation as a glob_constr, taking care of binders *) @@ -222,6 +224,7 @@ let glob_constr_of_notation_constr_with_binders ?loc g f e nc = | NHole (x, naming, arg) -> GHole (x, naming, arg) | NRef x -> GRef (x,None) | NInt i -> GInt i + | NFloat f -> GFloat f let glob_constr_of_notation_constr ?loc x = let rec aux () x = @@ -438,6 +441,7 @@ let notation_constr_and_vars_of_glob_constr recvars a = | GCast (c,k) -> NCast (aux c,map_cast_type aux k) | GSort s -> NSort s | GInt i -> NInt i + | GFloat f -> NFloat f | GHole (w,naming,arg) -> if arg != None then has_ltac := true; NHole (w, naming, arg) @@ -627,6 +631,7 @@ let rec subst_notation_constr subst bound raw = | NSort _ -> raw | NInt _ -> raw + | NFloat _ -> raw | NHole (knd, naming, solve) -> let nknd = match knd with @@ -1196,6 +1201,7 @@ let rec match_ inner u alp metas sigma a1 a2 = | GSort s1, NSort s2 when glob_sort_eq s1 s2 -> sigma | GInt i1, NInt i2 when Uint63.equal i1 i2 -> sigma + | GFloat f1, NFloat f2 when Float64.equal f1 f2 -> sigma | GPatVar _, NHole _ -> (*Don't hide Metas, they bind in ltac*) raise No_match | a, NHole _ -> sigma @@ -1223,7 +1229,7 @@ let rec match_ inner u alp metas sigma a1 a2 = | (GRef _ | GVar _ | GEvar _ | GPatVar _ | GApp _ | GLambda _ | GProd _ | GLetIn _ | GCases _ | GLetTuple _ | GIf _ | GRec _ | GSort _ | GHole _ - | GCast _ | GInt _ ), _ -> raise No_match + | GCast _ | GInt _ | GFloat _), _ -> raise No_match and match_in u = match_ true u diff --git a/interp/notation_term.ml b/interp/notation_term.ml index 908455bd05..c6ddd9ac95 100644 --- a/interp/notation_term.ml +++ b/interp/notation_term.ml @@ -44,6 +44,7 @@ type notation_constr = | NSort of glob_sort | NCast of notation_constr * notation_constr cast_type | NInt of Uint63.t + | NFloat of Float64.t (** 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 0865487c98..931b509f48 100644 --- a/kernel/byterun/coq_fix_code.c +++ b/kernel/byterun/coq_fix_code.c @@ -44,6 +44,7 @@ void init_arity () { arity[PUSHCONST0]=arity[PUSHCONST1]=arity[PUSHCONST2]=arity[PUSHCONST3]= arity[ACCUMULATE]=arity[STOP]=arity[MAKEPROD]= arity[ADDINT63]=arity[SUBINT63]=arity[LTINT63]=arity[LEINT63]= + arity[LTFLOAT]=arity[LEFLOAT]= arity[ISINT]=arity[AREINT2]=0; /* instruction with one operand */ arity[ACC]=arity[PUSHACC]=arity[POP]=arity[ENVACC]=arity[PUSHENVACC]= @@ -63,7 +64,15 @@ void init_arity () { arity[CHECKLSLINT63]=arity[CHECKLSRINT63]=arity[CHECKADDMULDIVINT63]= arity[CHECKLSLINT63CONST1]=arity[CHECKLSRINT63CONST1]= arity[CHECKEQINT63]=arity[CHECKLTINT63]=arity[CHECKLEINT63]= - arity[CHECKCOMPAREINT63]=arity[CHECKHEAD0INT63]=arity[CHECKTAIL0INT63]=1; + arity[CHECKCOMPAREINT63]=arity[CHECKHEAD0INT63]=arity[CHECKTAIL0INT63]= + arity[CHECKEQFLOAT]=arity[CHECKLTFLOAT]=arity[CHECKLEFLOAT]= + arity[CHECKOPPFLOAT]=arity[CHECKABSFLOAT]=arity[CHECKCOMPAREFLOAT]= + arity[CHECKCLASSIFYFLOAT]= + arity[CHECKADDFLOAT]=arity[CHECKSUBFLOAT]=arity[CHECKMULFLOAT]= + arity[CHECKDIVFLOAT]=arity[CHECKSQRTFLOAT]= + arity[CHECKFLOATOFINT63]=arity[CHECKFLOATNORMFRMANTISSA]= + arity[CHECKFRSHIFTEXP]=arity[CHECKLDSHIFTEXP]= + arity[CHECKNEXTUPFLOAT]=arity[CHECKNEXTDOWNFLOAT]=1; /* instruction with two operands */ arity[APPTERM]=arity[MAKEBLOCK]=arity[CLOSURE]= arity[PROJ]=2; diff --git a/kernel/byterun/coq_float64.h b/kernel/byterun/coq_float64.h new file mode 100644 index 0000000000..c41079c8ff --- /dev/null +++ b/kernel/byterun/coq_float64.h @@ -0,0 +1,48 @@ +#ifndef _COQ_FLOAT64_ +#define _COQ_FLOAT64_ + +#include <math.h> + +#define DECLARE_FREL(name, e) \ + int coq_##name(double x, double y) { \ + return e; \ + } \ + \ + value coq_##name##_byte(value x, value y) { \ + return coq_##name(Double_val(x), Double_val(y)); \ + } + +#define DECLARE_FBINOP(name, e) \ + double coq_##name(double x, double y) { \ + return e; \ + } \ + \ + value coq_##name##_byte(value x, value y) { \ + return caml_copy_double(coq_##name(Double_val(x), Double_val(y))); \ + } + +#define DECLARE_FUNOP(name, e) \ + double coq_##name(double x) { \ + return e; \ + } \ + \ + value coq_##name##_byte(value x) { \ + return caml_copy_double(coq_##name(Double_val(x))); \ + } + +DECLARE_FREL(feq, x == y) +DECLARE_FREL(flt, x < y) +DECLARE_FREL(fle, x <= y) +DECLARE_FBINOP(fmul, x * y) +DECLARE_FBINOP(fadd, x + y) +DECLARE_FBINOP(fsub, x - y) +DECLARE_FBINOP(fdiv, x / y) +DECLARE_FUNOP(fsqrt, sqrt(x)) +DECLARE_FUNOP(next_up, nextafter(x, INFINITY)) +DECLARE_FUNOP(next_down, nextafter(x, -INFINITY)) + +value coq_is_double(value x) { + return Val_long(Is_double(x)); +} + +#endif /* _COQ_FLOAT64_ */ diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c index 4b45608ae5..ca1308696c 100644 --- a/kernel/byterun/coq_interp.c +++ b/kernel/byterun/coq_interp.c @@ -17,11 +17,13 @@ #include <signal.h> #include <stdint.h> #include <caml/memory.h> +#include <math.h> #include "coq_gc.h" #include "coq_instruct.h" #include "coq_fix_code.h" #include "coq_memory.h" #include "coq_values.h" +#include "coq_float64.h" #ifdef ARCH_SIXTYFOUR #include "coq_uint63_native.h" @@ -167,38 +169,34 @@ if (sp - num_args < coq_stack_threshold) { \ #endif #endif -#define CheckInt1() do{ \ - if (Is_uint63(accu)) pc++; \ +#define CheckPrimArgs(cond, apply_lbl) do{ \ + if (cond) pc++; \ else{ \ *--sp=accu; \ accu = Field(coq_global_data, *pc++); \ - goto apply1; \ - } \ - }while(0) - -#define CheckInt2() do{ \ - if (Is_uint63(accu) && Is_uint63(sp[0])) pc++; \ - else{ \ - *--sp=accu; \ - accu = Field(coq_global_data, *pc++); \ - goto apply2; \ + goto apply_lbl; \ } \ }while(0) - - -#define CheckInt3() do{ \ - if (Is_uint63(accu) && Is_uint63(sp[0]) && Is_uint63(sp[1]) ) pc++; \ - else{ \ - *--sp=accu; \ - accu = Field(coq_global_data, *pc++); \ - goto apply3; \ - } \ - }while(0) +#define CheckInt1() CheckPrimArgs(Is_uint63(accu), apply1) +#define CheckInt2() CheckPrimArgs(Is_uint63(accu) && Is_uint63(sp[0]), apply2) +#define CheckInt3() CheckPrimArgs(Is_uint63(accu) && Is_uint63(sp[0]) \ + && Is_uint63(sp[1]), apply3) +#define CheckFloat1() CheckPrimArgs(Is_double(accu), apply1) +#define CheckFloat2() CheckPrimArgs(Is_double(accu) && Is_double(sp[0]), apply2) #define AllocCarry(cond) Alloc_small(accu, 1, (cond)? coq_tag_C1 : coq_tag_C0) #define AllocPair() Alloc_small(accu, 2, coq_tag_pair) +/* Beware: we cannot use caml_copy_double here as it doesn't use + Alloc_small, hence doesn't protect the stack via + Setup_for_gc/Restore_after_gc. */ +#define Coq_copy_double(val) do{ \ + double Coq_copy_double_f__ = (val); \ + Alloc_small(accu, Double_wosize, Double_tag); \ + Store_double_val(accu, Coq_copy_double_f__); \ + }while(0); + #define Swap_accu_sp do{ \ value swap_accu_sp_tmp__ = accu; \ accu = *sp; \ @@ -1533,6 +1531,206 @@ value coq_interprete } + Instruct (CHECKOPPFLOAT) { + print_instr("CHECKOPPFLOAT"); + CheckFloat1(); + Coq_copy_double(-Double_val(accu)); + Next; + } + + Instruct (CHECKABSFLOAT) { + print_instr("CHECKABSFLOAT"); + CheckFloat1(); + Coq_copy_double(fabs(Double_val(accu))); + Next; + } + + Instruct (CHECKEQFLOAT) { + print_instr("CHECKEQFLOAT"); + CheckFloat2(); + accu = coq_feq(Double_val(accu), Double_val(*sp++)) ? coq_true : coq_false; + Next; + } + + Instruct (CHECKLTFLOAT) { + print_instr("CHECKLTFLOAT"); + CheckFloat2(); + } + Instruct (LTFLOAT) { + print_instr("LTFLOAT"); + accu = coq_flt(Double_val(accu), Double_val(*sp++)) ? coq_true : coq_false; + Next; + } + + Instruct (CHECKLEFLOAT) { + print_instr("CHECKLEFLOAT"); + CheckFloat2(); + } + Instruct (LEFLOAT) { + print_instr("LEFLOAT"); + accu = coq_fle(Double_val(accu), Double_val(*sp++)) ? coq_true : coq_false; + Next; + } + + Instruct (CHECKCOMPAREFLOAT) { + double x, y; + print_instr("CHECKCOMPAREFLOAT"); + CheckFloat2(); + x = Double_val(accu); + y = Double_val(*sp++); + if(x < y) { + accu = coq_FLt; + } + else if(x > y) { + accu = coq_FGt; + } + else if(x == y) { + accu = coq_FEq; + } + else { // nan value + accu = coq_FNotComparable; + } + Next; + } + + Instruct (CHECKCLASSIFYFLOAT) { + double x; + print_instr("CHECKCLASSIFYFLOAT"); + CheckFloat1(); + x = Double_val(accu); + switch (fpclassify(x)) { + case FP_NORMAL: + accu = signbit(x) ? coq_NNormal : coq_PNormal; + break; + case FP_SUBNORMAL: + accu = signbit(x) ? coq_NSubn : coq_PSubn; + break; + case FP_ZERO: + accu = signbit(x) ? coq_NZero : coq_PZero; + break; + case FP_INFINITE: + accu = signbit(x) ? coq_NInf : coq_PInf; + break; + default: /* FP_NAN */ + accu = coq_NaN; + break; + } + Next; + } + + Instruct (CHECKADDFLOAT) { + print_instr("CHECKADDFLOAT"); + CheckFloat2(); + Coq_copy_double(coq_fadd(Double_val(accu), Double_val(*sp++))); + Next; + } + + Instruct (CHECKSUBFLOAT) { + print_instr("CHECKSUBFLOAT"); + CheckFloat2(); + Coq_copy_double(coq_fsub(Double_val(accu), Double_val(*sp++))); + Next; + } + + Instruct (CHECKMULFLOAT) { + print_instr("CHECKMULFLOAT"); + CheckFloat2(); + Coq_copy_double(coq_fmul(Double_val(accu), Double_val(*sp++))); + Next; + } + + Instruct (CHECKDIVFLOAT) { + print_instr("CHECKDIVFLOAT"); + CheckFloat2(); + Coq_copy_double(coq_fdiv(Double_val(accu), Double_val(*sp++))); + Next; + } + + Instruct (CHECKSQRTFLOAT) { + print_instr("CHECKSQRTFLOAT"); + CheckFloat1(); + Coq_copy_double(coq_fsqrt(Double_val(accu))); + Next; + } + + Instruct (CHECKFLOATOFINT63) { + print_instr("CHECKFLOATOFINT63"); + CheckInt1(); + Uint63_to_double(accu); + Next; + } + + Instruct (CHECKFLOATNORMFRMANTISSA) { + double f; + print_instr("CHECKFLOATNORMFRMANTISSA"); + CheckFloat1(); + f = fabs(Double_val(accu)); + if (f >= 0.5 && f < 1) { + Uint63_of_double(ldexp(f, DBL_MANT_DIG)); + } + else { + Uint63_of_int(Val_int(0)); + } + Next; + } + + Instruct (CHECKFRSHIFTEXP) { + int exp; + double f; + print_instr("CHECKFRSHIFTEXP"); + CheckFloat1(); + /* frexp(infinity) incorrectly returns nan on mingw */ +#if defined(__MINGW32__) || defined(__MINGW64__) + if (fpclassify(Double_val(accu)) == FP_INFINITE) { + f = Double_val(accu); + } else +#endif + f = frexp(Double_val(accu), &exp); + if (fpclassify(f) == FP_NORMAL) { + exp += FLOAT_EXP_SHIFT; + } + else { + exp = 0; + } + Coq_copy_double(f); + *--sp = accu; +#ifdef ARCH_SIXTYFOUR + Alloc_small(accu, 2, coq_tag_pair); + Field(accu, 1) = Val_int(exp); +#else + Uint63_of_int(Val_int(exp)); + *--sp = accu; + Alloc_small(accu, 2, coq_tag_pair); + Field(accu, 1) = *sp++; +#endif + Field(accu, 0) = *sp++; + Next; + } + + Instruct (CHECKLDSHIFTEXP) { + print_instr("CHECKLDSHIFTEXP"); + CheckPrimArgs(Is_double(accu) && Is_uint63(sp[0]), apply2); + Swap_accu_sp; + Uint63_to_int_min(accu, Val_int(2 * FLOAT_EXP_SHIFT)); + accu = Int_val(accu); + Coq_copy_double(ldexp(Double_val(*sp++), accu - FLOAT_EXP_SHIFT)); + Next; + } + + Instruct (CHECKNEXTUPFLOAT) { + print_instr("CHECKNEXTUPFLOAT"); + CheckFloat1(); + Coq_copy_double(coq_next_up(Double_val(accu))); + Next; + } + + Instruct (CHECKNEXTDOWNFLOAT) { + print_instr("CHECKNEXTDOWNFLOAT"); + CheckFloat1(); + Coq_copy_double(coq_next_down(Double_val(accu))); + Next; + } + /* Debugging and machine control */ Instruct(STOP){ diff --git a/kernel/byterun/coq_uint63_emul.h b/kernel/byterun/coq_uint63_emul.h index 528cc6fc1f..143a6d098c 100644 --- a/kernel/byterun/coq_uint63_emul.h +++ b/kernel/byterun/coq_uint63_emul.h @@ -156,3 +156,18 @@ DECLARE_BINOP(mulc_ml) *(h) = Field(uint63_return_value__, 0); \ accu = Field(uint63_return_value__, 1); \ }while(0) + +DECLARE_UNOP(to_float) +#define Uint63_to_double(x) CALL_UNOP(to_float, x) + +DECLARE_UNOP(of_float) +#define Uint63_of_double(f) do{ \ + Coq_copy_double(f); \ + CALL_UNOP(of_float, accu); \ + }while(0) + +DECLARE_UNOP(of_int) +#define Uint63_of_int(x) CALL_UNOP(of_int, x) + +DECLARE_BINOP(to_int_min) +#define Uint63_to_int_min(n, m) CALL_BINOP(to_int_min, n, m) diff --git a/kernel/byterun/coq_uint63_native.h b/kernel/byterun/coq_uint63_native.h index 9fbd3f83d8..5be7587091 100644 --- a/kernel/byterun/coq_uint63_native.h +++ b/kernel/byterun/coq_uint63_native.h @@ -138,3 +138,26 @@ value uint63_div21(value xh, value xl, value y, value* ql) { } } #define Uint63_div21(xh, xl, y, q) (accu = uint63_div21(xh, xl, y, q)) + +#define Uint63_to_double(x) Coq_copy_double((double) uint63_of_value(x)) + +double coq_uint63_to_float(value x) { + return (double) uint63_of_value(x); +} + +value coq_uint63_to_float_byte(value x) { + return caml_copy_double(coq_uint63_to_float(x)); +} + +#define Uint63_of_double(f) do{ \ + accu = Val_long((uint64_t)(f)); \ + }while(0) + +#define Uint63_of_int(x) (accu = (x)) + +#define Uint63_to_int_min(n, m) do { \ + if (uint63_lt((n),(m))) \ + accu = (n); \ + else \ + accu = (m); \ + }while(0) diff --git a/kernel/byterun/coq_values.h b/kernel/byterun/coq_values.h index 0cf6ccf532..b027673ac7 100644 --- a/kernel/byterun/coq_values.h +++ b/kernel/byterun/coq_values.h @@ -14,6 +14,8 @@ #include <caml/alloc.h> #include <caml/mlvalues.h> +#include <float.h> + #define Default_tag 0 #define Accu_tag 0 @@ -29,8 +31,9 @@ /* Les blocs accumulate */ #define Is_accu(v) (Is_block(v) && (Tag_val(v) == Accu_tag)) #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 values for primitive operations */ #define coq_tag_C1 2 #define coq_tag_C0 1 #define coq_tag_pair 1 @@ -39,5 +42,20 @@ #define coq_Eq Val_int(0) #define coq_Lt Val_int(1) #define coq_Gt Val_int(2) +#define coq_FEq Val_int(0) +#define coq_FLt Val_int(1) +#define coq_FGt Val_int(2) +#define coq_FNotComparable Val_int(3) +#define coq_PNormal Val_int(0) +#define coq_NNormal Val_int(1) +#define coq_PSubn Val_int(2) +#define coq_NSubn Val_int(3) +#define coq_PZero Val_int(4) +#define coq_NZero Val_int(5) +#define coq_PInf Val_int(6) +#define coq_NInf Val_int(7) +#define coq_NaN Val_int(8) + +#define FLOAT_EXP_SHIFT (2101) /* 2*emax + prec */ #endif /* _COQ_VALUES_ */ diff --git a/kernel/byterun/dune b/kernel/byterun/dune index 20bdf28e54..d0145176ea 100644 --- a/kernel/byterun/dune +++ b/kernel/byterun/dune @@ -1,3 +1,16 @@ +; Dune doesn't use configure's output, but it is still necessary for +; some Coq files to work; will be fixed in the future. +(rule + (targets dune.c_flags) + (mode fallback) + (deps %{project_root}/configure.ml %{project_root}/dev/ocamldebug-coq.run (env_var COQ_CONFIGURE_PREFIX)) + (action (chdir %{project_root} (run %{ocaml} configure.ml -no-ask -native-compiler no)))) + +(env + (dev (c_flags (:include dune.c_flags))) + (release (c_flags (:include dune.c_flags))) + (ireport (c_flags (:include dune.c_flags)))) + (library (name byterun) (synopsis "Coq's Kernel Abstract Reduction Machine [C implementation]") diff --git a/kernel/cClosure.ml b/kernel/cClosure.ml index 3fd613e905..72585e5014 100644 --- a/kernel/cClosure.ml +++ b/kernel/cClosure.ml @@ -348,6 +348,7 @@ and fterm = | 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 | FLIFT of int * fconstr | FCLOS of constr * fconstr subs | FLOCKED @@ -428,7 +429,7 @@ let rec stack_args_size = function let rec lft_fconstr n ft = let r = Mark.relevance ft.mark in match ft.term with - | (FInd _|FConstruct _|FFlex(ConstKey _|VarKey _)|FInt _) -> ft + | (FInd _|FConstruct _|FFlex(ConstKey _|VarKey _)|FInt _|FFloat _) -> ft | FRel i -> {mark=mark Norm r;term=FRel(i+n)} | FLambda(k,tys,f,e) -> {mark=mark Cstr r; term=FLambda(k,tys,f,subs_shft(n,e))} | FFix(fx,e) -> @@ -499,6 +500,7 @@ let mk_clos e t = | Ind kn -> {mark = mark Norm KnownR; term = FInd kn } | 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 _) -> {mark = mark Red Unknown; term = FCLOS(t,e)} @@ -616,6 +618,8 @@ let rec to_constr lfts v = | FInt i -> Constr.mkInt i + | FFloat f -> + Constr.mkFloat f | FCLOS (t,env) -> if is_subs_id env && is_lift_id lfts then t @@ -926,7 +930,7 @@ let rec knh info m stk = (* cases where knh stops *) | (FFlex _|FLetIn _|FConstruct _|FEvar _| - FCoFix _|FLambda _|FRel _|FAtom _|FInd _|FProd _|FInt _) -> + FCoFix _|FLambda _|FRel _|FAtom _|FInd _|FProd _|FInt _|FFloat _) -> (m, stk) (* The same for pure terms *) @@ -940,7 +944,7 @@ and knht info e t 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 _) -> (mk_clos e t, 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) -> @@ -969,6 +973,11 @@ module FNativeEntries = | FInt i -> i | _ -> raise Primred.NativeDestKO + let get_float () e = + match [@ocaml.warning "-4"] e.term with + | FFloat f -> f + | _ -> raise Primred.NativeDestKO + let dummy = {mark = mark Norm KnownR; term = FRel 0} let current_retro = ref Retroknowledge.empty @@ -982,6 +991,16 @@ module FNativeEntries = fint := { mark = mark Norm KnownR; term = FFlex (ConstKey (Univ.in_punivs c)) } | None -> defined_int := false + let defined_float = ref false + let ffloat = ref dummy + + let init_float retro = + match retro.Retroknowledge.retro_float64 with + | Some c -> + defined_float := true; + ffloat := { mark = mark Norm KnownR; term = FFlex (ConstKey (Univ.in_punivs c)) } + | None -> defined_float := false + let defined_bool = ref false let ftrue = ref dummy let ffalse = ref dummy @@ -1020,6 +1039,7 @@ module FNativeEntries = let fEq = ref dummy let fLt = ref dummy let fGt = ref dummy + let fcmp = ref dummy let init_cmp retro = match retro.Retroknowledge.retro_cmp with @@ -1027,9 +1047,54 @@ module FNativeEntries = defined_cmp := true; fEq := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs cEq) }; fLt := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs cLt) }; - fGt := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs cGt) } + fGt := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs cGt) }; + let (icmp, _) = cEq in + fcmp := { mark = mark Norm KnownR; term = FInd (Univ.in_punivs icmp) } | None -> defined_cmp := false + let defined_f_cmp = ref false + let fFEq = ref dummy + let fFLt = ref dummy + let fFGt = ref dummy + let fFNotComparable = ref dummy + + let init_f_cmp retro = + match retro.Retroknowledge.retro_f_cmp with + | Some (cFEq, cFLt, cFGt, cFNotComparable) -> + defined_f_cmp := true; + fFEq := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs cFEq) }; + fFLt := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs cFLt) }; + fFGt := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs cFGt) }; + fFNotComparable := + { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs cFNotComparable) }; + | None -> defined_f_cmp := false + + let defined_f_class = ref false + let fPNormal = ref dummy + let fNNormal = ref dummy + let fPSubn = ref dummy + let fNSubn = ref dummy + let fPZero = ref dummy + let fNZero = ref dummy + let fPInf = ref dummy + let fNInf = ref dummy + let fNaN = ref dummy + + let init_f_class retro = + match retro.Retroknowledge.retro_f_class with + | Some (cPNormal, cNNormal, cPSubn, cNSubn, cPZero, cNZero, + cPInf, cNInf, cNaN) -> + defined_f_class := true; + fPNormal := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs cPNormal) }; + fNNormal := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs cNNormal) }; + fPSubn := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs cPSubn) }; + fNSubn := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs cNSubn) }; + fPZero := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs cPZero) }; + fNZero := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs cNZero) }; + fPInf := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs cPInf) }; + fNInf := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs cNInf) }; + fNaN := { mark = mark Cstr KnownR; term = FConstruct (Univ.in_punivs cNaN) }; + | None -> defined_f_class := false let defined_refl = ref false let frefl = ref dummy @@ -1044,10 +1109,13 @@ module FNativeEntries = let init env = current_retro := env.retroknowledge; init_int !current_retro; + init_float !current_retro; init_bool !current_retro; init_carry !current_retro; init_pair !current_retro; init_cmp !current_retro; + init_f_cmp !current_retro; + init_f_class !current_retro; init_refl !current_retro let check_env env = @@ -1057,6 +1125,10 @@ module FNativeEntries = check_env env; assert (!defined_int) + let check_float env = + check_env env; + assert (!defined_float) + let check_bool env = check_env env; assert (!defined_bool) @@ -1073,10 +1145,22 @@ module FNativeEntries = check_env env; assert (!defined_cmp) + let check_f_cmp env = + check_env env; + assert (!defined_f_cmp) + + let check_f_class env = + check_env env; + assert (!defined_f_class) + let mkInt env i = check_int env; { mark = mark Cstr KnownR; term = FInt i } + let mkFloat env f = + check_float env; + { mark = mark Norm KnownR; term = FFloat f } + let mkBool env b = check_bool env; if b then !ftrue else !ffalse @@ -1090,6 +1174,11 @@ module FNativeEntries = check_pair env; { mark = mark Cstr KnownR; term = FApp(!fPair, [|!fint;!fint;e1;e2|]) } + let mkFloatIntPair env f i = + check_pair env; + check_float env; + { mark = mark Cstr KnownR; term = FApp(!fPair, [|!ffloat;!fint;f;i|]) } + let mkLt env = check_cmp env; !fLt @@ -1102,6 +1191,57 @@ module FNativeEntries = check_cmp env; !fGt + let mkFLt env = + check_f_cmp env; + !fFLt + + let mkFEq env = + check_f_cmp env; + !fFEq + + let mkFGt env = + check_f_cmp env; + !fFGt + + let mkFNotComparable env = + check_f_cmp env; + !fFNotComparable + + let mkPNormal env = + check_f_class env; + !fPNormal + + let mkNNormal env = + check_f_class env; + !fNNormal + + let mkPSubn env = + check_f_class env; + !fPSubn + + let mkNSubn env = + check_f_class env; + !fNSubn + + let mkPZero env = + check_f_class env; + !fPZero + + let mkNZero env = + check_f_class env; + !fNZero + + let mkPInf env = + check_f_class env; + !fPInf + + let mkNInf env = + check_f_class env; + !fNInf + + let mkNaN env = + check_f_class env; + !fNaN end module FredNative = RedNative(FNativeEntries) @@ -1164,7 +1304,7 @@ 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 _ -> + | FInt _ | FFloat _ -> (match [@ocaml.warning "-4"] strip_update_shift_app m stk with | (_, _, Zprimitive(op,c,rargs,nargs)::s) -> let (rargs, nargs) = skip_native_args (m::rargs) nargs in @@ -1270,7 +1410,7 @@ and norm_head info tab m = | FProj (p,c) -> mkProj (p, kl info tab c) | FLOCKED | FRel _ | FAtom _ | FFlex _ | FInd _ | FConstruct _ - | FApp _ | FCaseT _ | FLIFT _ | FCLOS _ | FInt _ -> term_of_fconstr m + | FApp _ | FCaseT _ | FLIFT _ | FCLOS _ | FInt _ | FFloat _ -> term_of_fconstr m (* Initialization and then normalization *) diff --git a/kernel/cClosure.mli b/kernel/cClosure.mli index cd1de4c834..720f11b8f2 100644 --- a/kernel/cClosure.mli +++ b/kernel/cClosure.mli @@ -115,6 +115,7 @@ type fterm = | 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 | FLIFT of int * fconstr | FCLOS of constr * fconstr subs | FLOCKED diff --git a/kernel/cPrimitives.ml b/kernel/cPrimitives.ml index d854cadd15..9ff7f69203 100644 --- a/kernel/cPrimitives.ml +++ b/kernel/cPrimitives.ml @@ -33,6 +33,24 @@ type t = | Int63lt | Int63le | Int63compare + | Float64opp + | Float64abs + | Float64eq + | Float64lt + | Float64le + | Float64compare + | Float64classify + | Float64add + | Float64sub + | Float64mul + | Float64div + | Float64sqrt + | Float64ofInt63 + | Float64normfr_mantissa + | Float64frshiftexp + | Float64ldshiftexp + | Float64next_up + | Float64next_down let equal (p1 : t) (p2 : t) = p1 == p2 @@ -62,6 +80,24 @@ let hash = function | Int63lt -> 22 | Int63le -> 23 | Int63compare -> 24 + | Float64opp -> 25 + | Float64abs -> 26 + | Float64compare -> 27 + | Float64classify -> 28 + | Float64add -> 29 + | Float64sub -> 30 + | Float64mul -> 31 + | Float64div -> 32 + | Float64sqrt -> 33 + | Float64ofInt63 -> 34 + | Float64normfr_mantissa -> 35 + | Float64frshiftexp -> 36 + | Float64ldshiftexp -> 37 + | Float64next_up -> 38 + | Float64next_down -> 39 + | Float64eq -> 40 + | Float64lt -> 41 + | Float64le -> 42 (* Should match names in nativevalues.ml *) let to_string = function @@ -89,6 +125,72 @@ let to_string = function | Int63lt -> "lt" | Int63le -> "le" | Int63compare -> "compare" + | Float64opp -> "fopp" + | Float64abs -> "fabs" + | Float64eq -> "feq" + | Float64lt -> "flt" + | Float64le -> "fle" + | Float64compare -> "fcompare" + | Float64classify -> "fclassify" + | Float64add -> "fadd" + | Float64sub -> "fsub" + | Float64mul -> "fmul" + | Float64div -> "fdiv" + | Float64sqrt -> "fsqrt" + | Float64ofInt63 -> "float_of_int" + | Float64normfr_mantissa -> "normfr_mantissa" + | Float64frshiftexp -> "frshiftexp" + | Float64ldshiftexp -> "ldshiftexp" + | Float64next_up -> "next_up" + | Float64next_down -> "next_down" + +type prim_type = + | PT_int63 + | PT_float64 + +type 'a prim_ind = + | PIT_bool : unit prim_ind + | PIT_carry : prim_type prim_ind + | PIT_pair : (prim_type * prim_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 = + | PITT_ind : 'a prim_ind * 'a -> ind_or_type + | PITT_type : prim_type -> ind_or_type + +let types = + let int_ty = PITT_type PT_int63 in + let float_ty = PITT_type PT_float64 in + function + | Int63head0 | Int63tail0 -> [int_ty; int_ty] + | Int63add | Int63sub | Int63mul + | Int63div | Int63mod + | 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)] + | Int63mulc | Int63diveucl -> + [int_ty; int_ty; PITT_ind (PIT_pair, (PT_int63, PT_int63))] + | 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))] + | 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))] + | 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] type arg_kind = | Kparam (* not needed for the evaluation of the primitive when it reduces *) @@ -97,58 +199,32 @@ type arg_kind = type args_red = arg_kind list -(* Invariant only argument of type int63 or an inductive can +(* Invariant only argument of type int63, float or an inductive can have kind Kwhnf *) -let kind = function - | Int63head0 | Int63tail0 -> [Kwhnf] - - | Int63add | Int63sub | Int63mul - | Int63div | Int63mod - | Int63lsr | Int63lsl - | Int63land | Int63lor | Int63lxor - | Int63addc | Int63subc - | Int63addCarryC | Int63subCarryC | Int63mulc | Int63diveucl - | Int63eq | Int63lt | Int63le | Int63compare -> [Kwhnf; Kwhnf] +let arity t = List.length (types t) - 1 - | Int63div21 | Int63addMulDiv -> [Kwhnf; Kwhnf; Kwhnf] - -let arity = function - | Int63head0 | Int63tail0 -> 1 - | Int63add | Int63sub | Int63mul - | Int63div | Int63mod - | Int63lsr | Int63lsl - | Int63land | Int63lor | Int63lxor - | Int63addc | Int63subc - | Int63addCarryC | Int63subCarryC | Int63mulc | Int63diveucl - | Int63eq | Int63lt | Int63le - | Int63compare -> 2 - - | Int63div21 | Int63addMulDiv -> 3 +let kind t = + let rec aux n = if n <= 0 then [] else Kwhnf :: aux (n - 1) in + aux (arity t) (** Special Entries for Register **) -type prim_ind = - | PIT_bool - | PIT_carry - | PIT_pair - | PIT_cmp - -type prim_type = - | PT_int63 - type op_or_type = | OT_op of t | OT_type of prim_type -let prim_ind_to_string = function +let prim_ind_to_string (type a) (p : a prim_ind) = match p with | PIT_bool -> "bool" | PIT_carry -> "carry" | PIT_pair -> "pair" | PIT_cmp -> "cmp" + | PIT_f_cmp -> "f_cmp" + | PIT_f_class -> "f_class" let prim_type_to_string = function | PT_int63 -> "int63_type" + | PT_float64 -> "float64_type" let op_or_type_to_string = function | OT_op op -> to_string op diff --git a/kernel/cPrimitives.mli b/kernel/cPrimitives.mli index 6913371caf..be65ba5305 100644 --- a/kernel/cPrimitives.mli +++ b/kernel/cPrimitives.mli @@ -33,6 +33,24 @@ type t = | Int63lt | Int63le | Int63compare + | Float64opp + | Float64abs + | Float64eq + | Float64lt + | Float64le + | Float64compare + | Float64classify + | Float64add + | Float64sub + | Float64mul + | Float64div + | Float64sqrt + | Float64ofInt63 + | Float64normfr_mantissa + | Float64frshiftexp + | Float64ldshiftexp + | Float64next_up + | Float64next_down val equal : t -> t -> bool @@ -53,18 +71,29 @@ val kind : t -> args_red (** Special Entries for Register **) -type prim_ind = - | PIT_bool - | PIT_carry - | PIT_pair - | PIT_cmp - type prim_type = | PT_int63 + | PT_float64 + +type 'a prim_ind = + | PIT_bool : unit prim_ind + | PIT_carry : prim_type prim_ind + | PIT_pair : (prim_type * prim_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 op_or_type = | OT_op of t | OT_type of prim_type -val prim_ind_to_string : prim_ind -> string +val prim_ind_to_string : 'a prim_ind -> string val op_or_type_to_string : op_or_type -> string + +type ind_or_type = + | PITT_ind : 'a prim_ind * 'a -> ind_or_type + | PITT_type : prim_type -> ind_or_type + +val types : t -> ind_or_type list diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml index 83d2a58d83..13cc6f7ea4 100644 --- a/kernel/cbytegen.ml +++ b/kernel/cbytegen.ml @@ -528,6 +528,8 @@ let rec compile_lam env cenv lam sz cont = | Luint i -> compile_structured_constant cenv (Const_uint i) sz cont + | Lfloat f -> compile_structured_constant cenv (Const_float f) sz cont + | Lproj (p,arg) -> compile_lam env cenv arg sz (Kproj p :: cont) diff --git a/kernel/cemitcodes.ml b/kernel/cemitcodes.ml index 76e2515ea7..5e82cef810 100644 --- a/kernel/cemitcodes.ml +++ b/kernel/cemitcodes.ml @@ -234,6 +234,24 @@ let check_prim_op = function | Int63lt -> opCHECKLTINT63 | Int63le -> opCHECKLEINT63 | Int63compare -> opCHECKCOMPAREINT63 + | Float64opp -> opCHECKOPPFLOAT + | Float64abs -> opCHECKABSFLOAT + | Float64eq -> opCHECKEQFLOAT + | Float64lt -> opCHECKLTFLOAT + | Float64le -> opCHECKLEFLOAT + | Float64compare -> opCHECKCOMPAREFLOAT + | Float64classify -> opCHECKCLASSIFYFLOAT + | Float64add -> opCHECKADDFLOAT + | Float64sub -> opCHECKSUBFLOAT + | Float64mul -> opCHECKMULFLOAT + | Float64div -> opCHECKDIVFLOAT + | Float64sqrt -> opCHECKSQRTFLOAT + | Float64ofInt63 -> opCHECKFLOATOFINT63 + | Float64normfr_mantissa -> opCHECKFLOATNORMFRMANTISSA + | Float64frshiftexp -> opCHECKFRSHIFTEXP + | Float64ldshiftexp -> opCHECKLDSHIFTEXP + | Float64next_up -> opCHECKNEXTUPFLOAT + | Float64next_down -> opCHECKNEXTDOWNFLOAT let emit_instr env = function | Klabel lbl -> define_label env lbl @@ -384,7 +402,8 @@ type to_patch = emitcodes * patches * fv (* Substitution *) let subst_strcst s sc = match sc with - | Const_sort _ | Const_b0 _ | Const_univ_level _ | Const_val _ | Const_uint _ -> sc + | Const_sort _ | Const_b0 _ | Const_univ_level _ | Const_val _ | Const_uint _ + | Const_float _ -> sc | Const_ind ind -> let kn,i = ind in Const_ind (subst_mind s kn, i) let subst_reloc s ri = diff --git a/kernel/clambda.ml b/kernel/clambda.ml index a764cca354..8c7aa6b17a 100644 --- a/kernel/clambda.ml +++ b/kernel/clambda.ml @@ -28,6 +28,7 @@ type lambda = | Lint of int | Lmakeblock of int * lambda array | Luint of Uint63.t + | Lfloat of Float64.t | Lval of structured_values | Lsort of Sorts.t | Lind of pinductive @@ -143,6 +144,7 @@ let rec pp_lam lam = prlist_with_sep spc pp_lam (Array.to_list args) ++ str")") | Luint i -> str (Uint63.to_string i) + | Lfloat f -> str (Float64.to_string f) | Lval _ -> str "values" | Lsort s -> pp_sort s | Lind ((mind,i), _) -> MutInd.print mind ++ str"#" ++ int i @@ -195,7 +197,8 @@ let shift subst = subs_shft (1, subst) let map_lam_with_binders g f n lam = match lam with - | Lrel _ | Lvar _ | Lconst _ | Lval _ | Lsort _ | Lind _ | Lint _ | Luint _ -> lam + | Lrel _ | Lvar _ | Lconst _ | Lval _ | Lsort _ | Lind _ | Lint _ | Luint _ + | Lfloat _ -> lam | Levar (evk, args) -> let args' = Array.Smart.map (f n) args in if args == args' then lam else Levar (evk, args') @@ -416,7 +419,8 @@ let rec occurrence k kind lam = if n = k then if kind then false else raise Not_found else kind - | Lvar _ | Lconst _ | Lval _ | Lsort _ | Lind _ | Lint _ | Luint _ -> kind + | Lvar _ | Lconst _ | Lval _ | Lsort _ | Lind _ | Lint _ | Luint _ + | Lfloat _ -> kind | Levar (_, args) -> occurrence_args k kind args | Lprod(dom, codom) -> @@ -763,6 +767,7 @@ let rec lambda_of_constr env c = Lproj (Projection.repr p,lc) | Int i -> Luint i + | Float f -> Lfloat f and lambda_of_app env f args = match Constr.kind f with diff --git a/kernel/clambda.mli b/kernel/clambda.mli index 1476bb6e45..bd11c2667f 100644 --- a/kernel/clambda.mli +++ b/kernel/clambda.mli @@ -21,6 +21,7 @@ type lambda = | Lint of int | Lmakeblock of int * lambda array | Luint of Uint63.t + | Lfloat of Float64.t | Lval of structured_values | Lsort of Sorts.t | Lind of pinductive diff --git a/kernel/constr.ml b/kernel/constr.ml index 8375316003..b60b2d6d04 100644 --- a/kernel/constr.ml +++ b/kernel/constr.ml @@ -104,6 +104,7 @@ type ('constr, 'types, 'sort, 'univs) kind_of_term = | CoFix of ('constr, 'types) pcofixpoint | Proj of Projection.t * 'constr | Int of Uint63.t + | Float of Float64.t (* 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 @@ -241,6 +242,9 @@ let mkRef (gr,u) = let open GlobRef in match gr with (* Constructs a primitive integer *) let mkInt i = Int i +(* Constructs a primitive float number *) +let mkFloat f = Float f + (************************************************************************) (* kind_of_term = constructions as seen by the user *) (************************************************************************) @@ -446,7 +450,7 @@ let decompose_appvect c = let fold f acc c = match kind c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ - | Construct _ | Int _) -> acc + | Construct _ | Int _ | Float _) -> acc | Cast (c,_,t) -> f (f acc c) t | Prod (_,t,c) -> f (f acc t) c | Lambda (_,t,c) -> f (f acc t) c @@ -466,7 +470,7 @@ let fold f acc c = match kind c with let iter f c = match kind c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ - | Construct _ | Int _) -> () + | Construct _ | Int _ | Float _) -> () | Cast (c,_,t) -> f c; f t | Prod (_,t,c) -> f t; f c | Lambda (_,t,c) -> f t; f c @@ -486,7 +490,7 @@ let iter f c = match kind c with let iter_with_binders g f n c = match kind c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ - | Construct _ | Int _) -> () + | Construct _ | Int _ | Float _) -> () | Cast (c,_,t) -> f n c; f n t | Prod (_,t,c) -> f n t; f (g n) c | Lambda (_,t,c) -> f n t; f (g n) c @@ -512,7 +516,7 @@ let iter_with_binders g f n c = match kind c with let fold_constr_with_binders g f n acc c = match kind c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ - | Construct _ | Int _) -> acc + | Construct _ | Int _ | Float _) -> acc | Cast (c,_, t) -> f n (f n acc c) t | Prod (_na,t,c) -> f (g n) (f n acc t) c | Lambda (_na,t,c) -> f (g n) (f n acc t) c @@ -608,7 +612,7 @@ let map_return_predicate_with_full_binders g f l ci p = let map_gen userview f c = match kind c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ - | Construct _ | Int _) -> c + | Construct _ | Int _ | Float _) -> c | Cast (b,k,t) -> let b' = f b in let t' = f t in @@ -673,7 +677,7 @@ let map = map_gen false let fold_map f accu c = match kind c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ - | Construct _ | Int _) -> accu, c + | Construct _ | Int _ | Float _) -> accu, c | Cast (b,k,t) -> let accu, b' = f accu b in let accu, t' = f accu t in @@ -733,7 +737,7 @@ let fold_map f accu c = match kind c with let map_with_binders g f l c0 = match kind c0 with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ - | Construct _ | Int _) -> c0 + | Construct _ | Int _ | Float _) -> c0 | Cast (c, k, t) -> let c' = f l c in let t' = f l t in @@ -810,7 +814,7 @@ let lift n = liftn n 1 let fold_with_full_binders g f n acc c = let open Context.Rel.Declaration in match kind c with - | Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _ | Int _ -> acc + | Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _ | Int _ | Float _ -> acc | Cast (c,_, t) -> f n (f n acc c) t | Prod (na,t,c) -> f (g (LocalAssum (na,t)) n) (f n acc t) c | Lambda (na,t,c) -> f (g (LocalAssum (na,t)) n) (f n acc t) c @@ -852,6 +856,7 @@ let compare_head_gen_leq_with kind1 kind2 leq_universes leq_sorts eq leq nargs t | Meta m1, Meta m2 -> Int.equal m1 m2 | Var id1, Var id2 -> Id.equal id1 id2 | Int i1, Int i2 -> Uint63.equal i1 i2 + | Float f1, Float f2 -> Float64.equal f1 f2 | Sort s1, Sort s2 -> leq_sorts s1 s2 | Prod (_,t1,c1), Prod (_,t2,c2) -> eq 0 t1 t2 && leq 0 c1 c2 | Lambda (_,t1,c1), Lambda (_,t2,c2) -> eq 0 t1 t2 && eq 0 c1 c2 @@ -878,7 +883,7 @@ let compare_head_gen_leq_with kind1 kind2 leq_universes leq_sorts eq leq nargs t Int.equal ln1 ln2 && Array.equal_norefl (eq 0) tl1 tl2 && Array.equal_norefl (eq 0) bl1 bl2 | (Rel _ | Meta _ | Var _ | Sort _ | Prod _ | Lambda _ | LetIn _ | App _ | Proj _ | Evar _ | Const _ | Ind _ | Construct _ | Case _ | Fix _ - | CoFix _ | Int _), _ -> false + | CoFix _ | Int _ | Float _), _ -> 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, @@ -1055,6 +1060,8 @@ let constr_ord_int f t1 t2 = | Proj (p1,c1), Proj (p2,c2) -> (Projection.compare =? f) p1 p2 c1 c2 | Proj _, _ -> -1 | _, Proj _ -> 1 | Int i1, Int i2 -> Uint63.compare i1 i2 + | Int _, _ -> -1 | _, Int _ -> 1 + | Float f1, Float f2 -> Float64.total_compare f1 f2 let rec compare m n= constr_ord_int compare m n @@ -1139,9 +1146,10 @@ let hasheq t1 t2 = && array_eqeq tl1 tl2 && array_eqeq bl1 bl2 | Int i1, Int i2 -> i1 == i2 + | Float f1, Float f2 -> Float64.equal f1 f2 | (Rel _ | Meta _ | Var _ | Sort _ | Cast _ | Prod _ | Lambda _ | LetIn _ | App _ | Proj _ | Evar _ | Const _ | Ind _ | Construct _ | Case _ - | Fix _ | CoFix _ | Int _), _ -> false + | Fix _ | CoFix _ | Int _ | Float _), _ -> 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 *) @@ -1247,6 +1255,7 @@ let hashcons (sh_sort,sh_ci,sh_construct,sh_ind,sh_con,sh_na,sh_id) = | Int i -> let (h,l) = Uint63.to_int2 i in (t, combinesmall 18 (combine h l)) + | Float f -> (t, combinesmall 19 (Float64.hash f)) and sh_rec t = let (y, h) = hash_term t in @@ -1311,6 +1320,7 @@ let rec hash t = | Proj (p,c) -> combinesmall 17 (combine (Projection.hash p) (hash c)) | Int i -> combinesmall 18 (Uint63.hash i) + | Float f -> combinesmall 19 (Float64.hash f) and hash_term_array t = Array.fold_left (fun acc t -> combine (hash t) acc) 0 t @@ -1455,3 +1465,4 @@ let rec debug_print c = cut() ++ str":=" ++ debug_print bd) (Array.to_list fixl)) ++ str"}") | Int i -> str"Int("++str (Uint63.to_string i) ++ str")" + | Float i -> str"Float("++str (Float64.to_string i) ++ str")" diff --git a/kernel/constr.mli b/kernel/constr.mli index 45ec8a7e64..4f8d682e42 100644 --- a/kernel/constr.mli +++ b/kernel/constr.mli @@ -76,6 +76,9 @@ val mkVar : Id.t -> constr (** Constructs a machine integer *) val mkInt : Uint63.t -> constr +(** Constructs a machine float number *) +val mkFloat : Float64.t -> constr + (** Constructs an patvar named "?n" *) val mkMeta : metavariable -> constr @@ -234,6 +237,7 @@ type ('constr, 'types, 'sort, 'univs) kind_of_term = | CoFix of ('constr, 'types) pcofixpoint | Proj of Projection.t * 'constr | Int of Uint63.t + | Float of Float64.t (** User view of [constr]. For [App], it is ensured there is at least one argument and the function is not itself an applicative diff --git a/kernel/csymtable.ml b/kernel/csymtable.ml index 6c9e73b50d..cbffdc731e 100644 --- a/kernel/csymtable.ml +++ b/kernel/csymtable.ml @@ -184,7 +184,16 @@ and eval_to_patch env (buff,pl,fv) = | Reloc_proj_name p -> slot_for_proj_name p in let tc = patch buff pl slots in - let vm_env = Array.map (slot_for_fv env) fv in + let vm_env = + (* Beware, this may look like a call to [Array.map], but it's not. + Calling [Array.map f] when the first argument returned by [f] + is a float would lead to [vm_env] being an unboxed Double_array + (Tag_val = Double_array_tag) whereas eval_tcode expects a + regular array (Tag_val = 0). + See test-suite/primitive/float/coq_env_double_array.v + for an actual instance. *) + let a = Array.make (Array.length fv) crazy_val in + Array.iteri (fun i v -> a.(i) <- slot_for_fv env v) fv; a in eval_tcode tc (get_atom_rel ()) (vm_global global_data.glob_val) vm_env and val_of_constr env c = diff --git a/kernel/float64.ml b/kernel/float64.ml new file mode 100644 index 0000000000..3e36373b77 --- /dev/null +++ b/kernel/float64.ml @@ -0,0 +1,159 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(* OCaml's float type follows the IEEE 754 Binary64 (double precision) + format *) +type t = float + +let is_nan f = f <> f +let is_infinity f = f = infinity +let is_neg_infinity f = f = neg_infinity + +(* Printing a binary64 float in 17 decimal places and parsing it again + will yield the same float. We assume [to_string_raw] is not given a + [nan] as input. *) +let to_string_raw f = Printf.sprintf "%.17g" f + +(* OCaml gives a sign to nan values which should not be displayed as + all NaNs are considered equal here *) +let to_string f = if is_nan f then "nan" else to_string_raw f +let of_string = float_of_string + +(* Compiles a float to OCaml code *) +let compile f = + let s = + if is_nan f then "nan" else if is_neg_infinity f then "neg_infinity" + else Printf.sprintf "%h" f in + Printf.sprintf "Float64.of_float (%s)" s + +let of_float f = f + +let sign f = copysign 1. f < 0. + +let opp = ( ~-. ) +let abs = abs_float + +type float_comparison = FEq | FLt | FGt | FNotComparable + +let eq x y = x = y +[@@ocaml.inline always] + +let lt x y = x < y +[@@ocaml.inline always] + +let le x y = x <= y +[@@ocaml.inline always] + +(* inspired by lib/util.ml; see also #10471 *) +let pervasives_compare = compare + +let compare x y = + if x < y then FLt + else + ( + if x > y then FGt + else + ( + if x = y then FEq + else FNotComparable (* NaN case *) + ) + ) +[@@ocaml.inline always] + +type float_class = + | PNormal | NNormal | PSubn | NSubn | PZero | NZero | PInf | NInf | NaN + +let classify x = + match classify_float x with + | FP_normal -> if 0. < x then PNormal else NNormal + | FP_subnormal -> if 0. < x then PSubn else NSubn + | FP_zero -> if 0. < 1. /. x then PZero else NZero + | FP_infinite -> if 0. < x then PInf else NInf + | FP_nan -> NaN +[@@ocaml.inline always] + +external mul : float -> float -> float = "coq_fmul_byte" "coq_fmul" +[@@unboxed] [@@noalloc] + +external add : float -> float -> float = "coq_fadd_byte" "coq_fadd" +[@@unboxed] [@@noalloc] + +external sub : float -> float -> float = "coq_fsub_byte" "coq_fsub" +[@@unboxed] [@@noalloc] + +external div : float -> float -> float = "coq_fdiv_byte" "coq_fdiv" +[@@unboxed] [@@noalloc] + +external sqrt : float -> float = "coq_fsqrt_byte" "coq_fsqrt" +[@@unboxed] [@@noalloc] + +let of_int63 x = Uint63.to_float x +[@@ocaml.inline always] + +let prec = 53 +let normfr_mantissa f = + let f = abs f in + if f >= 0.5 && f < 1. then Uint63.of_float (ldexp f prec) + else Uint63.zero +[@@ocaml.inline always] + +let eshift = 2101 (* 2*emax + prec *) + +(* When calling frexp on a nan or an infinity, the returned value inside + the exponent is undefined. + Therefore we must always set it to a fixed value (here 0). *) +let frshiftexp f = + match classify_float f with + | FP_zero | FP_infinite | FP_nan -> (f, Uint63.zero) + | FP_normal | FP_subnormal -> + let (m, e) = frexp f in + m, Uint63.of_int (e + eshift) +[@@ocaml.inline always] + +let ldshiftexp f e = ldexp f (Uint63.to_int_min e (2 * eshift) - eshift) +[@@ocaml.inline always] + +external next_up : float -> float = "coq_next_up_byte" "coq_next_up" +[@@unboxed] [@@noalloc] + +external next_down : float -> float = "coq_next_down_byte" "coq_next_down" +[@@unboxed] [@@noalloc] + +let equal f1 f2 = + match classify_float f1 with + | FP_normal | FP_subnormal | FP_infinite -> (f1 = f2) + | FP_nan -> is_nan f2 + | FP_zero -> f1 = f2 && 1. /. f1 = 1. /. f2 (* OCaml consider 0. = -0. *) +[@@ocaml.inline always] + +let hash = + (* Hashtbl.hash already considers all NaNs as equal, + cf. https://github.com/ocaml/ocaml/commit/aea227fdebe0b5361fd3e1d0aaa42cf929052269 + and http://caml.inria.fr/pub/docs/manual-ocaml/libref/Hashtbl.html *) + Hashtbl.hash + +let total_compare f1 f2 = + (* pervasives_compare considers all NaNs as equal, which is fine here, + but also considers -0. and +0. as equal *) + if f1 = 0. && f2 = 0. then pervasives_compare (1. /. f1) (1. /. f2) + else pervasives_compare f1 f2 + +let is_float64 t = + Obj.tag t = Obj.double_tag +[@@ocaml.inline always] + +(*** Test at runtime that no harmful double rounding seems to + be performed with an intermediate 80 bits representation (x87). *) +let () = + let b = ldexp 1. 53 in + let s = add 1. (ldexp 1. (-52)) in + if add b s <= b || add b 1. <> b || ldexp 1. (-1074) <= 0. then + failwith "Detected non IEEE-754 compliant architecture (or wrong \ + rounding mode). Use of Float is thus unsafe." diff --git a/kernel/float64.mli b/kernel/float64.mli new file mode 100644 index 0000000000..2aa9796526 --- /dev/null +++ b/kernel/float64.mli @@ -0,0 +1,95 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** [t] is currently implemented by OCaml's [float] type. + +Beware: NaNs have a sign and a payload, while they should be +indistinguishable from Coq's perspective. *) +type t + +(** Test functions for special values to avoid calling [classify] *) +val is_nan : t -> bool +val is_infinity : t -> bool +val is_neg_infinity : t -> bool + +val to_string : t -> string +val of_string : string -> t + +val compile : t -> string + +val of_float : float -> t + +(** Return [true] for "-", [false] for "+". *) +val sign : t -> bool + +val opp : t -> t +val abs : t -> t + +type float_comparison = FEq | FLt | FGt | FNotComparable + +val eq : t -> t -> bool + +val lt : t -> t -> bool + +val le : t -> t -> bool + +(** The IEEE 754 float comparison. + * NotComparable is returned if there is a NaN in the arguments *) +val compare : t -> t -> float_comparison +[@@ocaml.inline always] + +type float_class = + | PNormal | NNormal | PSubn | NSubn | PZero | NZero | PInf | NInf | NaN + +val classify : t -> float_class +[@@ocaml.inline always] + +val mul : t -> t -> t + +val add : t -> t -> t + +val sub : t -> t -> t + +val div : t -> t -> t + +val sqrt : t -> t + +(** Link with integers *) +val of_int63 : Uint63.t -> t +[@@ocaml.inline always] + +val normfr_mantissa : t -> Uint63.t +[@@ocaml.inline always] + +(** Shifted exponent extraction *) +val eshift : int + +val frshiftexp : t -> t * Uint63.t (* float remainder, shifted exponent *) +[@@ocaml.inline always] + +val ldshiftexp : t -> Uint63.t -> t +[@@ocaml.inline always] + +val next_up : t -> t + +val next_down : t -> t + +(** Return true if two floats are equal. + * All NaN values are considered equal. *) +val equal : t -> t -> bool +[@@ocaml.inline always] + +val hash : t -> int + +(** Total order relation over float values. Behaves like [Pervasives.compare].*) +val total_compare : t -> t -> int + +val is_float64 : Obj.t -> bool +[@@ocaml.inline always] diff --git a/kernel/genOpcodeFiles.ml b/kernel/genOpcodeFiles.ml index a8a4ffce9c..82bb2b584d 100644 --- a/kernel/genOpcodeFiles.ml +++ b/kernel/genOpcodeFiles.ml @@ -137,6 +137,26 @@ let opcodes = "CHECKTAIL0INT63"; "ISINT"; "AREINT2"; + "CHECKOPPFLOAT"; + "CHECKABSFLOAT"; + "CHECKEQFLOAT"; + "CHECKLTFLOAT"; + "LTFLOAT"; + "CHECKLEFLOAT"; + "LEFLOAT"; + "CHECKCOMPAREFLOAT"; + "CHECKCLASSIFYFLOAT"; + "CHECKADDFLOAT"; + "CHECKSUBFLOAT"; + "CHECKMULFLOAT"; + "CHECKDIVFLOAT"; + "CHECKSQRTFLOAT"; + "CHECKFLOATOFINT63"; + "CHECKFLOATNORMFRMANTISSA"; + "CHECKFRSHIFTEXP"; + "CHECKLDSHIFTEXP"; + "CHECKNEXTUPFLOAT"; + "CHECKNEXTDOWNFLOAT"; "STOP" |] diff --git a/kernel/inductive.ml b/kernel/inductive.ml index 9c2af7aebb..fdd09436d4 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -812,7 +812,7 @@ let rec subterm_specif renv stack t = | Not_subterm -> Not_subterm) | Var _ | Sort _ | Cast _ | Prod _ | LetIn _ | App _ | Const _ | Ind _ - | Construct _ | CoFix _ | Int _ -> Not_subterm + | Construct _ | CoFix _ | Int _ | Float _ -> Not_subterm (* Other terms are not subterms *) @@ -1065,7 +1065,7 @@ let check_one_fix renv recpos trees def = check_rec_call renv stack (Term.applist(c,l)) end - | Sort _ | Int _ -> + | Sort _ | Int _ | Float _ -> assert (List.is_empty l) (* l is not checked because it is considered as the meta's context *) @@ -1259,7 +1259,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 _ -> + | Ind _ | Fix _ | Proj _ | Int _ | Float _ -> raise (CoFixGuardError (env,NotGuardedForm t)) in let ((mind, _),_) = codomain_is_coind env deftype in diff --git a/kernel/inferCumulativity.ml b/kernel/inferCumulativity.ml index 3b8c2cd788..550c81ed82 100644 --- a/kernel/inferCumulativity.ml +++ b/kernel/inferCumulativity.ml @@ -102,6 +102,7 @@ let rec infer_fterm cv_pb infos variances hd stk = infer_vect infos variances (Array.map (mk_clos e) args) | FRel _ -> infer_stack infos variances stk | FInt _ -> infer_stack infos variances stk + | FFloat _ -> infer_stack infos variances stk | FFlex fl -> let variances = infer_table_key variances fl in infer_stack infos variances stk diff --git a/kernel/kernel.mllib b/kernel/kernel.mllib index 20e742d7f8..2b83c2d868 100644 --- a/kernel/kernel.mllib +++ b/kernel/kernel.mllib @@ -1,6 +1,7 @@ Names TransparentState Uint63 +Float64 CPrimitives Univ UGraph diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index 1a5455cf3a..63dc49ba57 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -258,16 +258,19 @@ type primitive = | Mk_var of Id.t | Mk_proj | Is_int + | Is_float | Cast_accu | Upd_cofix | Force_cofix | Mk_uint + | Mk_float | Mk_int | Mk_bool | Val_to_int | Mk_meta | Mk_evar | MLand + | MLnot | MLle | MLlt | MLinteq @@ -349,6 +352,9 @@ let primitive_hash = function | Mk_proj -> 36 | MLarrayget -> 37 | Mk_empty_instance -> 38 + | Mk_float -> 39 + | Is_float -> 40 + | MLnot -> 41 type mllambda = | MLlocal of lname @@ -365,6 +371,7 @@ type mllambda = (* prefix, inductive name, tag, arguments *) | MLint of int | MLuint of Uint63.t + | MLfloat of Float64.t | MLsetref of string * mllambda | MLsequence of mllambda * mllambda | MLarray of mllambda array @@ -436,6 +443,8 @@ let rec eq_mllambda gn1 gn2 n env1 env2 t1 t2 = Int.equal i1 i2 | MLuint i1, MLuint i2 -> Uint63.equal i1 i2 + | MLfloat f1, MLfloat f2 -> + Float64.equal f1 f2 | MLsetref (id1, ml1), MLsetref (id2, ml2) -> String.equal id1 id2 && eq_mllambda gn1 gn2 n env1 env2 ml1 ml2 @@ -450,7 +459,7 @@ let rec eq_mllambda gn1 gn2 n env1 env2 t1 t2 = eq_mllambda gn1 gn2 n env1 env2 ml1 ml2 | (MLlocal _ | MLglobal _ | MLprimitive _ | MLlam _ | MLletrec _ | MLlet _ | MLapp _ | MLif _ | MLmatch _ | MLconstruct _ | MLint _ | MLuint _ | - MLsetref _ | MLsequence _ | MLarray _ | MLisaccu _), _ -> false + MLfloat _ | MLsetref _ | MLsequence _ | MLarray _ | MLisaccu _), _ -> false and eq_letrec gn1 gn2 n env1 env2 defs1 defs2 = let eq_def (_,args1,ml1) (_,args2,ml2) = @@ -535,6 +544,8 @@ let rec hash_mllambda gn n env t = combinesmall 15 (hash_mllambda_array gn n env 1 arr) | MLisaccu (s, ind, c) -> combinesmall 16 (combine (String.hash s) (combine (ind_hash ind) (hash_mllambda gn n env c))) + | MLfloat f -> + combinesmall 17 (Float64.hash f) and hash_mllambda_letrec gn n env init defs = let hash_def (_,args,ml) = @@ -568,7 +579,7 @@ let fv_lam l = match l with | MLlocal l -> if LNset.mem l bind then fv else LNset.add l fv - | MLglobal _ | MLprimitive _ | MLint _ | MLuint _ -> fv + | MLglobal _ | MLprimitive _ | MLint _ | MLuint _ | MLfloat _ -> fv | MLlam (ln,body) -> let bind = Array.fold_right LNset.add ln bind in aux body bind fv @@ -757,7 +768,7 @@ type env = env_named : (Id.t * mllambda) list ref; env_univ : lname option} -let empty_env univ () = +let empty_env univ = { env_rel = []; env_bound = 0; env_urel = ref []; @@ -958,25 +969,29 @@ type prim_aux = | PAprim of string * pconstant * CPrimitives.t * prim_aux array | PAml of mllambda -let add_check cond args = - let aux cond a = +let add_check cond targs args = + let aux cond t a = match a with | PAml(MLint _) -> cond | PAml ml -> (* FIXME: use explicit equality function *) - if List.mem ml cond then cond else ml::cond + if List.mem (t, ml) cond then cond else (t, ml)::cond | _ -> cond in - Array.fold_left aux cond args + Array.fold_left2 aux cond targs args let extract_prim ml_of l = let decl = ref [] in 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 rec aux l = match l with | Lprim(prefix,kn,p,args) -> + let targs = type_args p in let args = Array.map aux args in - cond := add_check !cond args; + cond := add_check !cond targs args; PAprim(prefix,kn,p,args) | Lrel _ | Lvar _ | Luint _ | Lval _ | Lconst _ -> PAml (ml_of l) | _ -> @@ -1010,15 +1025,35 @@ let compile_prim decl cond paux = let compile_cond cond paux = match cond with | [] -> opt_prim_aux paux - | [c1] -> + | [CPrimitives.(PITT_type PT_int63), c1] -> MLif(app_prim Is_int [|c1|], opt_prim_aux paux, naive_prim_aux paux) - | c1::cond -> - let cond = - List.fold_left - (fun ml c -> app_prim MLland [| ml; cast_to_int c|]) - (app_prim MLland [| cast_to_int c1; MLint 0 |]) cond in - let cond = app_prim MLmagic [|cond|] in - MLif(cond, naive_prim_aux paux, opt_prim_aux paux) in + | _ -> + let ci, cf = + let is_int = + function CPrimitives.(PITT_type PT_int63), _ -> true | _ -> false in + List.partition is_int cond in + let condi = + let cond = + List.fold_left + (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 + | [] -> MLint 0 + | [_, c1] -> app_prim Is_float [|c1|] + | (_, c1) :: condf -> + 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 + | [], [] -> opt_prim_aux paux + | _ :: _, [] -> + MLif(condi, naive_prim_aux paux, opt_prim_aux paux) + | [], _ :: _ -> + MLif(condf, opt_prim_aux paux, naive_prim_aux paux) + | _ :: _, _ :: _ -> + let cond = app_prim MLand [|condf; app_prim MLnot [|condi|]|] in + MLif(cond, opt_prim_aux paux, naive_prim_aux paux) in let add_decl decl body = List.fold_left (fun body (x,d) -> MLlet(x,d,body)) body decl in @@ -1095,14 +1130,14 @@ let ml_of_instance instance u = (* Remark: if we do not want to compile the predicate we should a least compute the fv, then store the lambda representation of the predicate (not the mllambda) *) - let env_p = empty_env env.env_univ () in + let env_p = empty_env env.env_univ in let pn = fresh_gpred l in let mlp = ml_of_lam env_p l p in let mlp = generalize_fv env_p mlp in let (pfvn,pfvr) = !(env_p.env_named), !(env_p.env_urel) in let pn = push_global_let pn mlp in (* Compilation of the case *) - let env_c = empty_env env.env_univ () in + let env_c = empty_env env.env_univ in let a_uid = fresh_lname Anonymous in let la_uid = MLlocal a_uid in (* compilation of branches *) @@ -1158,7 +1193,7 @@ let ml_of_instance instance u = start *) (* Compilation of type *) - let env_t = empty_env env.env_univ () in + let env_t = empty_env env.env_univ in let ml_t = Array.map (ml_of_lam env_t l) tt in let params_t = fv_params env_t in let args_t = fv_args env !(env_t.env_named) !(env_t.env_urel) in @@ -1167,7 +1202,7 @@ let ml_of_instance instance u = let mk_type = MLapp(MLglobal gft, args_t) in (* Compilation of norm_i *) let ndef = Array.length ids in - let lf,env_n = push_rels (empty_env env.env_univ ()) ids in + let lf,env_n = push_rels (empty_env env.env_univ) ids in let t_params = Array.make ndef [||] in let t_norm_f = Array.make ndef (Gnorm (l,-1)) in let mk_let _envi (id,def) t = MLlet (id,def,t) in @@ -1224,7 +1259,7 @@ let ml_of_instance instance u = MLletrec(Array.mapi mkrec lf, lf_args.(start)) | Lcofix (start, (ids, tt, tb)) -> (* Compilation of type *) - let env_t = empty_env env.env_univ () in + let env_t = empty_env env.env_univ in let ml_t = Array.map (ml_of_lam env_t l) tt in let params_t = fv_params env_t in let args_t = fv_args env !(env_t.env_named) !(env_t.env_urel) in @@ -1233,7 +1268,7 @@ let ml_of_instance instance u = let mk_type = MLapp(MLglobal gft, args_t) in (* Compilation of norm_i *) let ndef = Array.length ids in - let lf,env_n = push_rels (empty_env env.env_univ ()) ids in + let lf,env_n = push_rels (empty_env env.env_univ) ids in let t_params = Array.make ndef [||] in let t_norm_f = Array.make ndef (Gnorm (l,-1)) in let ml_of_fix i body = @@ -1297,6 +1332,7 @@ let ml_of_instance instance u = let args = Array.map (ml_of_lam env l) args in MLconstruct(prefix,cn,tag,args) | Luint i -> MLapp(MLprimitive Mk_uint, [|MLuint i|]) + | Lfloat f -> MLapp(MLprimitive Mk_float, [|MLfloat f|]) | Lval v -> let i = push_symbol (SymbValue v) in get_value_code i | Lsort s -> @@ -1314,7 +1350,7 @@ let ml_of_instance instance u = | Lforce -> MLglobal (Ginternal "Lazy.force") let mllambda_of_lambda univ auxdefs l t = - let env = empty_env univ () in + let env = empty_env univ in global_stack := auxdefs; let ml = ml_of_lam env l t in let fv_rel = !(env.env_urel) in @@ -1347,7 +1383,7 @@ let subst s l = let rec aux l = match l with | MLlocal id -> (try LNmap.find id s with Not_found -> l) - | MLglobal _ | MLprimitive _ | MLint _ | MLuint _ -> l + | MLglobal _ | MLprimitive _ | MLint _ | MLuint _ | MLfloat _ -> l | MLlam(params,body) -> MLlam(params, aux body) | MLletrec(defs,body) -> let arec (f,params,body) = (f,params,aux body) in @@ -1417,7 +1453,7 @@ let optimize gdef l = let rec optimize s l = match l with | MLlocal id -> (try LNmap.find id s with Not_found -> l) - | MLglobal _ | MLprimitive _ | MLint _ | MLuint _ -> l + | MLglobal _ | MLprimitive _ | MLint _ | MLuint _ | MLfloat _ -> l | MLlam(params,body) -> MLlam(params, optimize s body) | MLletrec(decls,body) -> @@ -1623,6 +1659,7 @@ let pp_mllam fmt l = (string_of_construct prefix ~constant:false ind tag) pp_cargs args | MLint i -> pp_int fmt i | MLuint i -> Format.fprintf fmt "(%s)" (Uint63.compile i) + | MLfloat f -> Format.fprintf fmt "(%s)" (Float64.compile f) | MLsetref (s, body) -> Format.fprintf fmt "@[%s@ :=@\n %a@]" s pp_mllam body | MLsequence(l1,l2) -> @@ -1739,16 +1776,19 @@ let pp_mllam fmt l = Format.fprintf fmt "mk_var_accu (Names.Id.of_string \"%s\")" (string_of_id id) | Mk_proj -> Format.fprintf fmt "mk_proj_accu" | Is_int -> Format.fprintf fmt "is_int" + | Is_float -> Format.fprintf fmt "is_float" | Cast_accu -> Format.fprintf fmt "cast_accu" | Upd_cofix -> Format.fprintf fmt "upd_cofix" | Force_cofix -> Format.fprintf fmt "force_cofix" | Mk_uint -> Format.fprintf fmt "mk_uint" + | Mk_float -> Format.fprintf fmt "mk_float" | Mk_int -> Format.fprintf fmt "mk_int" | Mk_bool -> Format.fprintf fmt "mk_bool" | Val_to_int -> Format.fprintf fmt "val_to_int" | Mk_meta -> Format.fprintf fmt "mk_meta_accu" | Mk_evar -> Format.fprintf fmt "mk_evar_accu" | MLand -> Format.fprintf fmt "(&&)" + | MLnot -> Format.fprintf fmt "not" | MLle -> Format.fprintf fmt "(<=)" | MLlt -> Format.fprintf fmt "(<)" | MLinteq -> Format.fprintf fmt "(==)" diff --git a/kernel/nativeconv.ml b/kernel/nativeconv.ml index dd010e5cad..ef610ce7e9 100644 --- a/kernel/nativeconv.ml +++ b/kernel/nativeconv.ml @@ -35,6 +35,9 @@ let rec conv_val env pb lvl v1 v2 cu = if Int.equal i1 i2 then cu else raise NotConvertible | Vint64 i1, Vint64 i2 -> if Int64.equal i1 i2 then cu else raise NotConvertible + | Vfloat64 f1, Vfloat64 f2 -> + if Float64.(equal (of_float f1) (of_float f2)) then cu + else raise NotConvertible | Vblock b1, Vblock b2 -> let n1 = block_size b1 in let n2 = block_size b2 in @@ -48,7 +51,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 _, _ | Vblock _, _ -> raise NotConvertible + | (Vaccu _ | Vconst _ | Vint64 _ | Vfloat64 _ | 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 70b3beb2dc..7a4e62cdfe 100644 --- a/kernel/nativelambda.ml +++ b/kernel/nativelambda.ml @@ -44,6 +44,7 @@ type lambda = (* prefix, inductive name, constructor tag, arguments *) (* A fully applied non-constant constructor *) | Luint of Uint63.t + | Lfloat of Float64.t | Lval of Nativevalues.t | Lsort of Sorts.t | Lind of prefix * pinductive @@ -123,7 +124,7 @@ let get_const_prefix env c = let map_lam_with_binders g f n lam = match lam with | Lrel _ | Lvar _ | Lconst _ | Lproj _ | Lval _ | Lsort _ | Lind _ | Luint _ - | Llazy | Lforce | Lmeta _ | Lint _ -> lam + | Llazy | Lforce | Lmeta _ | Lint _ | Lfloat _ -> lam | Lprod(dom,codom) -> let dom' = f n dom in let codom' = f n codom in @@ -331,7 +332,7 @@ and reduce_lapp substf lids body substa largs = let is_value lc = match lc with - | Lval _ | Lint _ | Luint _ -> true + | Lval _ | Lint _ | Luint _ | Lfloat _ -> true | _ -> false let get_value lc = @@ -339,6 +340,7 @@ let get_value lc = | Lval v -> v | Lint tag -> Nativevalues.mk_int tag | Luint i -> Nativevalues.mk_uint i + | Lfloat f -> Nativevalues.mk_float f | _ -> raise Not_found let make_args start _end = @@ -364,7 +366,12 @@ let makeblock env ind tag nparams arity args = if Int.equal arity 0 then Lint tag else if Array.for_all is_value args then - let args = Array.map get_value args in + let dummy_val = Obj.magic 0 in + let args = + (* Don't simplify this to Array.map, cf. the related comment in + function eval_to_patch, file kernel/csymtable.ml *) + let a = Array.make (Array.length args) dummy_val in + Array.iteri (fun i v -> a.(i) <- get_value v) args; a in Lval (Nativevalues.mk_block tag args) else let prefix = get_mind_prefix env (fst ind) in @@ -580,6 +587,8 @@ let rec lambda_of_constr cache env sigma c = | Int i -> Luint i + | Float f -> Lfloat f + 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 f17339f84d..1d7bf5343a 100644 --- a/kernel/nativelambda.mli +++ b/kernel/nativelambda.mli @@ -38,6 +38,7 @@ type lambda = (* prefix, inductive name, constructor tag, arguments *) (* A fully applied non-constant constructor *) | Luint of Uint63.t + | Lfloat of Float64.t | Lval of Nativevalues.t | Lsort of Sorts.t | Lind of prefix * pinductive diff --git a/kernel/nativevalues.ml b/kernel/nativevalues.ml index f788832d5b..e4a8344eaf 100644 --- a/kernel/nativevalues.ml +++ b/kernel/nativevalues.ml @@ -225,6 +225,9 @@ let mk_bool (b : bool) = (Obj.magic (not b) : t) let mk_uint (x : Uint63.t) = (Obj.magic x : t) [@@ocaml.inline always] +let mk_float (x : Float64.t) = (Obj.magic x : t) +[@@ocaml.inline always] + type block let block_size (b:block) = @@ -240,16 +243,19 @@ type kind_of_value = | Vfun of (t -> t) | Vconst of int | Vint64 of int64 + | Vfloat64 of float | Vblock of block let kind_of_value (v:t) = let o = Obj.repr v in if Obj.is_int o then Vconst (Obj.magic v) + else if Obj.tag o == Obj.double_tag then Vfloat64 (Obj.magic v) else let tag = Obj.tag o in if Int.equal tag accumulate_tag then 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) else (* assert (tag = Obj.closure_tag || tag = Obj.infix_tag); @@ -261,6 +267,7 @@ let kind_of_value (v:t) = let is_int (x:t) = let o = Obj.repr x in Obj.is_int o || Int.equal (Obj.tag o) Obj.custom_tag +[@@ocaml.inline always] let val_to_int (x:t) = (Obj.magic x : int) [@@ocaml.inline always] @@ -508,6 +515,177 @@ let print x = flush stderr; x +(** Support for machine floating point values *) + +external is_float : t -> bool = "coq_is_double" +[@@noalloc] + +let to_float (x:t) = (Obj.magic x : Float64.t) +[@@ocaml.inline always] + +let no_check_fopp x = + mk_float (Float64.opp (to_float x)) +[@@ocaml.inline always] + +let fopp accu x = + if is_float x then no_check_fopp x + else accu x + +let no_check_fabs x = + mk_float (Float64.abs (to_float x)) +[@@ocaml.inline always] + +let fabs accu x = + if is_float x then no_check_fabs x + else accu x + +let no_check_feq x y = + mk_bool (Float64.eq (to_float x) (to_float y)) + +let feq accu x y = + if is_float x && is_float y then no_check_feq x y + else accu x y + +let no_check_flt x y = + mk_bool (Float64.lt (to_float x) (to_float y)) + +let flt accu x y = + if is_float x && is_float y then no_check_flt x y + else accu x y + +let no_check_fle x y = + mk_bool (Float64.le (to_float x) (to_float y)) + +let fle accu x y = + if is_float x && is_float y then no_check_fle x y + else accu x y + +type coq_fcmp = + | CFcmpAccu of t + | CFcmpEq + | CFcmpLt + | CFcmpGt + | CFcmpNotComparable + +let no_check_fcompare x y = + let c = Float64.compare (to_float x) (to_float y) in + (Obj.magic c:t) +[@@ocaml.inline always] + +let fcompare accu x y = + if is_float x && is_float y then no_check_fcompare x y + else accu x y + +type coq_fclass = + | CFclassAccu of t + | CFclassPNormal + | CFclassNNormal + | CFclassPSubn + | CFclassNSubn + | CFclassPZero + | CFclassNZero + | CFclassPInf + | CFclassNInf + | CFclassNaN + +let no_check_fclassify x = + let c = Float64.classify (to_float x) in + (Obj.magic c:t) +[@@ocaml.inline always] + +let fclassify accu x = + if is_float x then no_check_fclassify x + else accu x + +let no_check_fadd x y = + mk_float (Float64.add (to_float x) (to_float y)) +[@@ocaml.inline always] + +let fadd accu x y = + if is_float x && is_float y then no_check_fadd x y + else accu x y + +let no_check_fsub x y = + mk_float (Float64.sub (to_float x) (to_float y)) +[@@ocaml.inline always] + +let fsub accu x y = + if is_float x && is_float y then no_check_fsub x y + else accu x y + +let no_check_fmul x y = + mk_float (Float64.mul (to_float x) (to_float y)) +[@@ocaml.inline always] + +let fmul accu x y = + if is_float x && is_float y then no_check_fmul x y + else accu x y + +let no_check_fdiv x y = + mk_float (Float64.div (to_float x) (to_float y)) +[@@ocaml.inline always] + +let fdiv accu x y = + if is_float x && is_float y then no_check_fdiv x y + else accu x y + +let no_check_fsqrt x = + mk_float (Float64.sqrt (to_float x)) +[@@ocaml.inline always] + +let fsqrt accu x = + if is_float x then no_check_fsqrt x + else accu x + +let no_check_float_of_int x = + mk_float (Float64.of_int63 (to_uint x)) +[@@ocaml.inline always] + +let float_of_int accu x = + if is_int x then no_check_float_of_int x + else accu x + +let no_check_normfr_mantissa x = + mk_uint (Float64.normfr_mantissa (to_float x)) +[@@ocaml.inline always] + +let normfr_mantissa accu x = + if is_float x then no_check_normfr_mantissa x + else accu x + +let no_check_frshiftexp x = + let f, e = Float64.frshiftexp (to_float x) in + (Obj.magic (PPair(mk_float f, mk_uint e)):t) +[@@ocaml.inline always] + +let frshiftexp accu x = + if is_float x then no_check_frshiftexp x + else accu x + +let no_check_ldshiftexp x e = + mk_float (Float64.ldshiftexp (to_float x) (to_uint e)) +[@@ocaml.inline always] + +let ldshiftexp accu x e = + if is_float x && is_int e then no_check_ldshiftexp x e + else accu x e + +let no_check_next_up x = + mk_float (Float64.next_up (to_float x)) +[@@ocaml.inline always] + +let next_up accu x = + if is_float x then no_check_next_up x + else accu x + +let no_check_next_down x = + mk_float (Float64.next_down (to_float x)) +[@@ocaml.inline always] + +let next_down accu x = + if is_float x then no_check_next_down x + else accu x + 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 b54f437e73..815ef3e98e 100644 --- a/kernel/nativevalues.mli +++ b/kernel/nativevalues.mli @@ -102,6 +102,9 @@ val mk_int : int -> t val mk_uint : Uint63.t -> t [@@ocaml.inline always] +val mk_float : Float64.t -> t +[@@ocaml.inline always] + val napply : t -> t array -> t (* Functions over accumulators *) @@ -130,6 +133,7 @@ type kind_of_value = | Vfun of (t -> t) | Vconst of int | Vint64 of int64 + | Vfloat64 of float | Vblock of block val kind_of_value : t -> kind_of_value @@ -140,7 +144,9 @@ val str_decode : string -> 'a (** Support for machine integers *) val val_to_int : t -> int + val is_int : t -> bool +[@@ocaml.inline always] (* function with check *) val head0 : t -> t -> t @@ -247,3 +253,82 @@ val no_check_le : t -> t -> t [@@ocaml.inline always] val no_check_compare : t -> t -> t + +(** Support for machine floating point values *) + +val is_float : t -> bool +[@@ocaml.inline always] + +val fopp : t -> t -> t +val fabs : t -> t -> t +val feq : t -> t -> t -> t +val flt : t -> t -> t -> t +val fle : t -> t -> t -> t +val fcompare : t -> t -> t -> t +val fclassify : t -> t -> t +val fadd : t -> t -> t -> t +val fsub : t -> t -> t -> t +val fmul : t -> t -> t -> t +val fdiv : t -> t -> t -> t +val fsqrt : t -> t -> t +val float_of_int : t -> t -> t +val normfr_mantissa : t -> t -> t +val frshiftexp : t -> t -> t +val ldshiftexp : t -> t -> t -> t +val next_up : t -> t -> t +val next_down : t -> t -> t + +(* Function without check *) +val no_check_fopp : t -> t +[@@ocaml.inline always] + +val no_check_fabs : t -> t +[@@ocaml.inline always] + +val no_check_feq : t -> t -> t +[@@ocaml.inline always] + +val no_check_flt : t -> t -> t +[@@ocaml.inline always] + +val no_check_fle : t -> t -> t +[@@ocaml.inline always] + +val no_check_fcompare : t -> t -> t +[@@ocaml.inline always] + +val no_check_fclassify : t -> t +[@@ocaml.inline always] + +val no_check_fadd : t -> t -> t +[@@ocaml.inline always] + +val no_check_fsub : t -> t -> t +[@@ocaml.inline always] + +val no_check_fmul : t -> t -> t +[@@ocaml.inline always] + +val no_check_fdiv : t -> t -> t +[@@ocaml.inline always] + +val no_check_fsqrt : t -> t +[@@ocaml.inline always] + +val no_check_float_of_int : t -> t +[@@ocaml.inline always] + +val no_check_normfr_mantissa : t -> t +[@@ocaml.inline always] + +val no_check_frshiftexp : t -> t +[@@ocaml.inline always] + +val no_check_ldshiftexp : t -> t -> t +[@@ocaml.inline always] + +val no_check_next_up : t -> t +[@@ocaml.inline always] + +val no_check_next_down : t -> t +[@@ocaml.inline always] diff --git a/kernel/primred.ml b/kernel/primred.ml index d6d0a6143a..c475828cb3 100644 --- a/kernel/primred.ml +++ b/kernel/primred.ml @@ -14,6 +14,13 @@ let add_retroknowledge env action = | None -> { retro with retro_int63 = Some c } | Some c' -> assert (Constant.equal c c'); retro in set_retroknowledge env retro + | Register_type(PT_float64,c) -> + let retro = env.retroknowledge in + let retro = + match retro.retro_float64 with + | None -> { retro with retro_float64 = 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 = @@ -42,6 +49,21 @@ let add_retroknowledge env action = | None -> ((ind,1), (ind,2), (ind,3)) | Some (((ind',_),_,_) as t) -> assert (eq_ind ind ind'); t in { retro with retro_cmp = Some r } + | PIT_f_cmp -> + let r = + match retro.retro_f_cmp with + | None -> ((ind,1), (ind,2), (ind,3), (ind,4)) + | Some (((ind',_),_,_,_) as t) -> assert (eq_ind ind ind'); t in + { retro with retro_f_cmp = Some r } + | PIT_f_class -> + let r = + match retro.retro_f_class with + | None -> ((ind,1), (ind,2), (ind,3), (ind,4), + (ind,5), (ind,6), (ind,7), (ind,8), + (ind,9)) + | Some (((ind',_),_,_,_,_,_,_,_,_) as t) -> + assert (eq_ind ind ind'); t in + { retro with retro_f_class = Some r } in set_retroknowledge env retro @@ -50,6 +72,17 @@ let get_int_type env = | Some c -> c | None -> anomaly Pp.(str"Reduction of primitive: int63 not registered") +let get_float_type env = + match env.retroknowledge.retro_float64 with + | Some c -> c + | None -> anomaly Pp.(str"Reduction of primitive: float64 not registered") + +let get_cmp_type env = + match env.retroknowledge.retro_cmp with + | Some (((mindcmp,_),_),_,_) -> + Constant.make (MutInd.user mindcmp) (MutInd.canonical mindcmp) + | None -> anomaly Pp.(str"Reduction of primitive: comparison not registered") + let get_bool_constructors env = match env.retroknowledge.retro_bool with | Some r -> r @@ -70,6 +103,16 @@ let get_cmp_constructors env = | Some r -> r | None -> anomaly Pp.(str"Reduction of primitive: cmp not registered") +let get_f_cmp_constructors env = + match env.retroknowledge.retro_f_cmp with + | Some r -> r + | None -> anomaly Pp.(str"Reduction of primitive: fcmp not registered") + +let get_f_class_constructors env = + match env.retroknowledge.retro_f_class with + | Some r -> r + | None -> anomaly Pp.(str"Reduction of primitive: fclass not registered") + exception NativeDestKO module type RedNativeEntries = @@ -80,14 +123,29 @@ module type RedNativeEntries = val get : args -> int -> elem val get_int : evd -> elem -> Uint63.t + val get_float : evd -> elem -> Float64.t val mkInt : env -> Uint63.t -> elem + val mkFloat : env -> Float64.t -> elem val mkBool : env -> bool -> elem val mkCarry : env -> bool -> elem -> elem (* true if carry *) val mkIntPair : env -> elem -> elem -> elem + val mkFloatIntPair : env -> elem -> elem -> elem val mkLt : env -> elem val mkEq : env -> elem val mkGt : env -> elem - + val mkFLt : env -> elem + val mkFEq : env -> elem + val mkFGt : env -> elem + val mkFNotComparable : env -> elem + val mkPNormal : env -> elem + val mkNNormal : env -> elem + val mkPSubn : env -> elem + val mkNSubn : env -> elem + val mkPZero : env -> elem + val mkNZero : env -> elem + val mkPInf : env -> elem + val mkNInf : env -> elem + val mkNaN : env -> elem end module type RedNative = @@ -116,6 +174,12 @@ struct let get_int3 evd args = get_int evd args 0, get_int evd args 1, get_int evd args 2 + let get_float evd args i = E.get_float evd (E.get args i) + + let get_float1 evd args = get_float evd args 0 + + let get_float2 evd args = get_float evd args 0, get_float evd args 1 + let red_prim_aux env evd op args = let open CPrimitives in match op with @@ -193,6 +257,64 @@ struct | 0 -> E.mkEq env | _ -> E.mkGt env end + | Float64opp -> + let f = get_float1 evd args in E.mkFloat env (Float64.opp f) + | Float64abs -> + let f = get_float1 evd args in E.mkFloat env (Float64.abs f) + | Float64eq -> + let i1, i2 = get_float2 evd args in + E.mkBool env (Float64.eq i1 i2) + | Float64lt -> + let i1, i2 = get_float2 evd args in + E.mkBool env (Float64.lt i1 i2) + | Float64le -> + let i1, i2 = get_float2 evd args in + E.mkBool env (Float64.le i1 i2) + | Float64compare -> + let f1, f2 = get_float2 evd args in + (match Float64.compare f1 f2 with + | Float64.FEq -> E.mkFEq env + | Float64.FLt -> E.mkFLt env + | Float64.FGt -> E.mkFGt env + | Float64.FNotComparable -> E.mkFNotComparable env) + | Float64classify -> + let f = get_float1 evd args in + (match Float64.classify f with + | Float64.PNormal -> E.mkPNormal env + | Float64.NNormal -> E.mkNNormal env + | Float64.PSubn -> E.mkPSubn env + | Float64.NSubn -> E.mkNSubn env + | Float64.PZero -> E.mkPZero env + | Float64.NZero -> E.mkNZero env + | Float64.PInf -> E.mkPInf env + | Float64.NInf -> E.mkNInf env + | Float64.NaN -> E.mkNaN env) + | Float64add -> + let f1, f2 = get_float2 evd args in E.mkFloat env (Float64.add f1 f2) + | Float64sub -> + let f1, f2 = get_float2 evd args in E.mkFloat env (Float64.sub f1 f2) + | Float64mul -> + let f1, f2 = get_float2 evd args in E.mkFloat env (Float64.mul f1 f2) + | Float64div -> + let f1, f2 = get_float2 evd args in E.mkFloat env (Float64.div f1 f2) + | Float64sqrt -> + let f = get_float1 evd args in E.mkFloat env (Float64.sqrt f) + | Float64ofInt63 -> + let i = get_int1 evd args in E.mkFloat env (Float64.of_int63 i) + | Float64normfr_mantissa -> + let f = get_float1 evd args in E.mkInt env (Float64.normfr_mantissa f) + | Float64frshiftexp -> + let f = get_float1 evd args in + let (m,e) = Float64.frshiftexp f in + E.mkFloatIntPair env (E.mkFloat env m) (E.mkInt env e) + | Float64ldshiftexp -> + let f = get_float evd args 0 in + let e = get_int evd args 1 in + E.mkFloat env (Float64.ldshiftexp f e) + | Float64next_up -> + 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) let red_prim env evd p args = try diff --git a/kernel/primred.mli b/kernel/primred.mli index f5998982d7..bbe564d8e7 100644 --- a/kernel/primred.mli +++ b/kernel/primred.mli @@ -5,10 +5,17 @@ open Environ val add_retroknowledge : env -> Retroknowledge.action -> env val get_int_type : env -> Constant.t +val get_float_type : env -> Constant.t +val get_cmp_type : env -> Constant.t val get_bool_constructors : env -> constructor * constructor val get_carry_constructors : env -> constructor * constructor val get_pair_constructor : env -> constructor val get_cmp_constructors : env -> constructor * constructor * constructor +val get_f_cmp_constructors : env -> constructor * constructor * constructor * constructor +val get_f_class_constructors : + env -> constructor * constructor * constructor * constructor + * constructor * constructor * constructor * constructor + * constructor exception NativeDestKO (* Should be raised by get_* functions on failure *) @@ -20,13 +27,29 @@ module type RedNativeEntries = val get : args -> int -> elem val get_int : evd -> elem -> Uint63.t + val get_float : evd -> elem -> Float64.t val mkInt : env -> Uint63.t -> elem + val mkFloat : env -> Float64.t -> elem val mkBool : env -> bool -> elem val mkCarry : env -> bool -> elem -> elem (* true if carry *) val mkIntPair : env -> elem -> elem -> elem + val mkFloatIntPair : env -> elem -> elem -> elem val mkLt : env -> elem val mkEq : env -> elem val mkGt : env -> elem + val mkFLt : env -> elem + val mkFEq : env -> elem + val mkFGt : env -> elem + val mkFNotComparable : env -> elem + val mkPNormal : env -> elem + val mkNNormal : env -> elem + val mkPSubn : env -> elem + val mkNSubn : env -> elem + val mkPZero : env -> elem + val mkNZero : env -> elem + val mkPInf : env -> elem + val mkNInf : env -> elem + val mkNaN : env -> elem end module type RedNative = diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 327cb2efeb..0cc7692fcf 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 _) -> x + Prod _|Lambda _|Fix _|CoFix _|Int _|Float _) -> x | App (c, _) -> begin match kind c with - | Ind _ | Construct _ | Evar _ | Meta _ | Const _ | Int _ -> x + | Ind _ | Construct _ | Evar _ | Meta _ | Const _ | Int _ | Float _ -> 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 _) -> t + Prod _|Lambda _|Fix _|CoFix _|Int _|Float _) -> t | App (c, _) -> begin match kind c with - | Ind _ | Construct _ | Evar _ | Meta _ | Int _ -> t + | Ind _ | Construct _ | Evar _ | Meta _ | Int _ | Float _ -> 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 _) -> t + Prod _|Lambda _|Fix _|CoFix _|LetIn _|Int _|Float _) -> t | App (c, _) -> begin match kind c with - | Ind _ | Construct _ | Evar _ | Meta _ | LetIn _ | Int _ -> t + | Ind _ | Construct _ | Evar _ | Meta _ | LetIn _ | Int _ | Float _ -> t | Sort _ | Rel _ | Var _ | Cast _ | Prod _ | Lambda _ | App _ | Const _ | Case _ | Fix _ | CoFix _ | Proj _ -> whd_val (create_clos_infos allnolet env) (create_tab ()) (inject t) @@ -627,13 +627,17 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = if Uint63.equal i1 i2 then convert_stacks l2r infos lft1 lft2 v1 v2 cuniv else raise NotConvertible + | FFloat f1, FFloat f2 -> + if Float64.equal f1 f2 then convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + else raise NotConvertible + (* 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 _), _ -> raise NotConvertible + | FProd _ | FEvar _ | FInt _ | FFloat _), _ -> 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 diff --git a/kernel/retroknowledge.ml b/kernel/retroknowledge.ml index 873c6af93d..479fe02295 100644 --- a/kernel/retroknowledge.ml +++ b/kernel/retroknowledge.ml @@ -18,23 +18,37 @@ open Names type retroknowledge = { retro_int63 : Constant.t option; + retro_float64 : Constant.t option; retro_bool : (constructor * constructor) option; (* true, false *) retro_carry : (constructor * constructor) option; (* C0, C1 *) retro_pair : constructor option; retro_cmp : (constructor * constructor * constructor) option; (* Eq, Lt, Gt *) - retro_refl : constructor option; + retro_f_cmp : (constructor * constructor * constructor * constructor) + option; + (* FEq, FLt, FGt, FNotComparable *) + retro_f_class : (constructor * constructor * constructor * constructor + * constructor * constructor * constructor * constructor + * constructor) + option; + (* PNormal, NNormal, PSubn, NSubn, + PZero, NZero, PInf, NInf, + NaN *) + retro_refl : constructor option } let empty = { retro_int63 = None; + retro_float64 = None; retro_bool = None; retro_carry = None; retro_pair = None; retro_cmp = None; + retro_f_cmp = None; + retro_f_class = None; retro_refl = None; } type action = - | Register_ind of CPrimitives.prim_ind * inductive - | Register_type of CPrimitives.prim_type * Constant.t + | Register_ind : 'a CPrimitives.prim_ind * inductive -> action + | Register_type : CPrimitives.prim_type * Constant.t -> action diff --git a/kernel/retroknowledge.mli b/kernel/retroknowledge.mli index 2a7b390951..2df8a00465 100644 --- a/kernel/retroknowledge.mli +++ b/kernel/retroknowledge.mli @@ -12,16 +12,27 @@ open Names type retroknowledge = { retro_int63 : Constant.t option; + retro_float64 : Constant.t option; retro_bool : (constructor * constructor) option; (* true, false *) retro_carry : (constructor * constructor) option; (* C0, C1 *) retro_pair : constructor option; retro_cmp : (constructor * constructor * constructor) option; (* Eq, Lt, Gt *) - retro_refl : constructor option; + retro_f_cmp : (constructor * constructor * constructor * constructor) + option; + (* FEq, FLt, FGt, FNotComparable *) + retro_f_class : (constructor * constructor * constructor * constructor + * constructor * constructor * constructor * constructor + * constructor) + option; + (* PNormal, NNormal, PSubn, NSubn, + PZero, NZero, PInf, NInf, + NaN *) + retro_refl : constructor option } val empty : retroknowledge type action = - | Register_ind of CPrimitives.prim_ind * inductive - | Register_type of CPrimitives.prim_type * Constant.t + | Register_ind : 'a CPrimitives.prim_ind * inductive -> action + | Register_type : CPrimitives.prim_type * Constant.t -> action diff --git a/kernel/retypeops.ml b/kernel/retypeops.ml index f398e6a5da..5c15257511 100644 --- a/kernel/retypeops.ml +++ b/kernel/retypeops.ml @@ -60,7 +60,7 @@ let rec relevance_of_fterm env extra lft f = | FRel n -> relevance_of_rel_extra env extra (Esubst.reloc_rel n lft) | FAtom c -> relevance_of_term_extra env extra lft (Esubst.subs_id 0) c | FFlex key -> relevance_of_flex env extra lft key - | FInt _ -> Sorts.Relevant + | FInt _ | FFloat _ -> 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 @@ -105,7 +105,7 @@ and relevance_of_term_extra env extra lft subs c = | Fix ((_,i),(lna,_,_)) -> (lna.(i)).binder_relevance | CoFix (i,(lna,_,_)) -> (lna.(i)).binder_relevance | Proj (p, _) -> relevance_of_projection env p - | Int _ -> Sorts.Relevant + | Int _ | Float _ -> Sorts.Relevant | Meta _ | Evar _ -> Sorts.Relevant (* let's assume metas and evars are relevant for now *) diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index e846b17aa0..d3cffd1546 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -1327,7 +1327,7 @@ let register_inline kn senv = let cb = {cb with const_inline_code = true} in let env = add_constant kn cb env in { senv with env} -let check_register_ind ind r env = +let check_register_ind (type t) ind (r : t CPrimitives.prim_ind) env = let (mb,ob as spec) = Inductive.lookup_mind_specif env ind in let check_if b msg = if not b then @@ -1403,6 +1403,36 @@ let check_register_ind ind r env = check_type_cte 1; check_name 2 "Gt"; check_type_cte 2 + | CPrimitives.PIT_f_cmp -> + check_nconstr 4; + check_name 0 "FEq"; + check_type_cte 0; + check_name 1 "FLt"; + check_type_cte 1; + check_name 2 "FGt"; + check_type_cte 2; + check_name 3 "FNotComparable"; + check_type_cte 3 + | CPrimitives.PIT_f_class -> + check_nconstr 9; + check_name 0 "PNormal"; + check_type_cte 0; + check_name 1 "NNormal"; + check_type_cte 1; + check_name 2 "PSubn"; + check_type_cte 2; + check_name 3 "NSubn"; + check_type_cte 3; + check_name 4 "PZero"; + check_type_cte 4; + check_name 5 "NZero"; + check_type_cte 5; + check_name 6 "PInf"; + check_type_cte 6; + check_name 7 "NInf"; + check_type_cte 7; + check_name 8 "NaN"; + check_type_cte 8 let register_inductive ind prim senv = check_register_ind ind prim senv.env; diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index b2f6668577..ae6993b0e2 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -226,7 +226,7 @@ val mind_of_delta_kn_senv : safe_environment -> KerName.t -> MutInd.t (** {6 Retroknowledge / Native compiler } *) val register_inline : Constant.t -> safe_transformer0 -val register_inductive : inductive -> CPrimitives.prim_ind -> safe_transformer0 +val register_inductive : inductive -> 'a CPrimitives.prim_ind -> safe_transformer0 val set_strategy : Names.Constant.t Names.tableKey -> Conv_oracle.level -> safe_transformer0 diff --git a/kernel/term.ml b/kernel/term.ml index 38c0d043cf..7343507838 100644 --- a/kernel/term.ml +++ b/kernel/term.ml @@ -383,4 +383,4 @@ let kind_of_type t = match kind t with | (Rel _ | Meta _ | Var _ | Evar _ | Const _ | Proj _ | Case _ | Fix _ | CoFix _ | Ind _) -> AtomicType (t,[||]) - | (Lambda _ | Construct _ | Int _) -> failwith "Not a type" + | (Lambda _ | Construct _ | Int _ | Float _) -> failwith "Not a type" diff --git a/kernel/typeops.ml b/kernel/typeops.ml index b87384d228..1cc40a6707 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -215,14 +215,22 @@ let type_of_apply env func funt argsv argstv = (* Type of primitive constructs *) let type_of_prim_type _env = function | CPrimitives.PT_int63 -> Constr.mkSet + | CPrimitives.PT_float64 -> Constr.mkSet let type_of_int env = match env.retroknowledge.Retroknowledge.retro_int63 with | Some c -> mkConst c | None -> CErrors.user_err Pp.(str"The type int must be registered before this construction can be typechecked.") +let type_of_float env = + match env.retroknowledge.Retroknowledge.retro_float64 with + | Some c -> mkConst c + | 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 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 @@ -233,6 +241,16 @@ let type_of_prim env t = | 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|]) @@ -243,39 +261,27 @@ let type_of_prim env t = | 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 rec nary_int63_op arity ty = - if Int.equal arity 0 then ty - else Constr.mkProd(Context.nameR (Id.of_string "x"), int_ty, nary_int63_op (arity-1) ty) - in - let return_ty = - let open CPrimitives in - match t with - | Int63head0 - | Int63tail0 - | Int63add - | Int63sub - | Int63mul - | Int63div - | Int63mod - | Int63lsr - | Int63lsl - | Int63land - | Int63lor - | Int63lxor - | Int63addMulDiv -> int_ty - | Int63eq - | Int63lt - | Int63le -> bool_ty () - | Int63mulc - | Int63div21 - | Int63diveucl -> pair_ty int_ty int_ty - | Int63addc - | Int63subc - | Int63addCarryC - | Int63subCarryC -> carry_ty int_ty - | Int63compare -> compare_ty () - in - nary_int63_op (CPrimitives.arity t) return_ty + 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 @@ -285,6 +291,9 @@ let type_of_prim_or_type env = let open CPrimitives in 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) + (* Type of product *) let sort_of_product env domsort rangsort = @@ -583,6 +592,7 @@ let rec execute env cstr = (* Primitive types *) | Int _ -> cstr, type_of_int env + | Float _ -> cstr, type_of_float env (* Partial proofs: unsupported by the kernel *) | Meta _ -> diff --git a/kernel/typeops.mli b/kernel/typeops.mli index c71a0e0ca4..ae816fe26e 100644 --- a/kernel/typeops.mli +++ b/kernel/typeops.mli @@ -120,6 +120,9 @@ val check_primitive_type : env -> CPrimitives.op_or_type -> types -> unit val type_of_int : env -> types 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 diff --git a/kernel/uint63.mli b/kernel/uint63.mli index d22ba3468f..e0bf44da35 100644 --- a/kernel/uint63.mli +++ b/kernel/uint63.mli @@ -19,7 +19,14 @@ val to_int2 : t -> int * int (* msb, lsb *) val of_int64 : Int64.t -> t (* val of_uint : int -> t -*) + *) +(** [int_min n m] returns the minimum of [n] and [m], + [m] must be in [0, 2^30-1]. *) +val to_int_min : t -> int -> int + + (* conversion to float *) +val of_float : float -> t +val to_float : t -> float val hash : t -> int diff --git a/kernel/uint63_31.ml b/kernel/uint63_31.ml index b8eccd19fb..e38389ca13 100644 --- a/kernel/uint63_31.ml +++ b/kernel/uint63_31.ml @@ -26,6 +26,13 @@ let mask63 i = Int64.logand i maxuint63 let of_int i = Int64.of_int i let to_int2 i = (Int64.to_int (Int64.shift_right_logical i 31), Int64.to_int i) let of_int64 i = i + +let to_int_min n m = + if Int64.(compare n (of_int m)) < 0 then Int64.to_int n else m + +let of_float f = mask63 (Int64.of_float f) +let to_float = Int64.to_float + let hash i = let (h,l) = to_int2 i in (*Hashset.combine h l*) @@ -213,4 +220,8 @@ let () = Callback.register "uint63 one" one; Callback.register "uint63 sub" sub; Callback.register "uint63 subcarry" subcarry; - Callback.register "uint63 tail0" tail0 + Callback.register "uint63 tail0" tail0; + Callback.register "uint63 of_float" of_float; + Callback.register "uint63 to_float" to_float; + Callback.register "uint63 of_int" of_int; + Callback.register "uint63 to_int_min" to_int_min diff --git a/kernel/uint63_63.ml b/kernel/uint63_63.ml index 5c4028e1c8..85b44528a7 100644 --- a/kernel/uint63_63.ml +++ b/kernel/uint63_63.ml @@ -27,6 +27,12 @@ let to_int2 i = (0,i) let of_int64 _i = assert false +let of_float = int_of_float + +external to_float : int -> (float [@unboxed]) + = "coq_uint63_to_float_byte" "coq_uint63_to_float" +[@@noalloc] + let hash i = i [@@ocaml.inline always] @@ -96,6 +102,10 @@ let le (x : int) (y : int) = (x lxor 0x4000000000000000) <= (y lxor 0x4000000000000000) [@@ocaml.inline always] +let to_int_min n m = + if lt n m then n else m +[@@ocaml.inline always] + (* division of two numbers by one *) (* precondition: xh < y *) (* outputs: q, r s.t. x = q * y + r, r < y *) diff --git a/kernel/vconv.ml b/kernel/vconv.ml index 414c443c4e..5d36ad54a2 100644 --- a/kernel/vconv.ml +++ b/kernel/vconv.ml @@ -73,6 +73,9 @@ and conv_whd env pb k whd1 whd2 cu = else raise NotConvertible | Vint64 i1, Vint64 i2 -> if Int64.equal i1 i2 then cu else raise NotConvertible + | Vfloat64 f1, Vfloat64 f2 -> + if Float64.(equal (of_float f1) (of_float f2)) then cu + else raise NotConvertible | Vatom_stk(a1,stk1), Vatom_stk(a2,stk2) -> conv_atom env pb k a1 stk1 a2 stk2 cu | Vfun _, _ | _, Vfun _ -> @@ -80,7 +83,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 _, _ - | Vconstr_block _, _ | Vatom_stk _, _ -> raise NotConvertible + | Vfloat64 _, _ | 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 319a26d824..5f08720f77 100644 --- a/kernel/vm.ml +++ b/kernel/vm.ml @@ -169,7 +169,8 @@ 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 _ -> assert false + | Vprod _ | Vconstr_const _ | Vconstr_block _ | Vint64 _ | Vfloat64 _ -> + assert false | Vfun f -> reduce_fun k f | Vfix(f, None) -> push_ra stop; diff --git a/kernel/vmvalues.ml b/kernel/vmvalues.ml index c8f5020d71..5acdd964b1 100644 --- a/kernel/vmvalues.ml +++ b/kernel/vmvalues.ml @@ -57,6 +57,7 @@ type structured_constant = | Const_univ_level of Univ.Level.t | Const_val of structured_values | Const_uint of Uint63.t + | Const_float of Float64.t type reloc_table = (tag * int) array @@ -75,6 +76,8 @@ let rec eq_structured_values v1 v2 = Int.equal (Obj.size o1) (Obj.size o2) then if Int.equal t1 Obj.custom_tag then Int64.equal (Obj.magic v1 : int64) (Obj.magic v2 : int64) + else if Int.equal t1 Obj.double_tag + then Float64.(equal (of_float (Obj.magic v1)) (of_float (Obj.magic v2))) else begin assert (t1 <= Obj.last_non_constant_constructor_tag && t2 <= Obj.last_non_constant_constructor_tag); @@ -105,6 +108,8 @@ let eq_structured_constant c1 c2 = match c1, c2 with | Const_val _, _ -> false | Const_uint i1, Const_uint i2 -> Uint63.equal i1 i2 | Const_uint _, _ -> false +| Const_float f1, Const_float f2 -> Float64.equal f1 f2 +| Const_float _, _ -> false let hash_structured_constant c = let open Hashset.Combine in @@ -115,6 +120,7 @@ let hash_structured_constant c = | Const_univ_level l -> combinesmall 4 (Univ.Level.hash l) | Const_val v -> combinesmall 5 (hash_structured_values v) | Const_uint i -> combinesmall 6 (Uint63.hash i) + | Const_float f -> combinesmall 7 (Float64.hash f) let eq_annot_switch asw1 asw2 = let eq_ci ci1 ci2 = @@ -149,6 +155,7 @@ let pp_struct_const = function | Const_univ_level l -> Univ.Level.pr l | Const_val _ -> Pp.str "(value)" | Const_uint i -> Pp.str (Uint63.to_string i) + | Const_float f -> Pp.str (Float64.to_string f) (* Abstract data *) type vprod @@ -284,6 +291,7 @@ type whd = | Vconstr_const of int | Vconstr_block of vblock | Vint64 of int64 + | Vfloat64 of float | Vatom_stk of atom * stack | Vuniv_level of Univ.Level.t @@ -315,6 +323,7 @@ let uni_lvl_val (v : values) : Univ.Level.t = | Vconstr_const _i -> str "Vconstr_const" | Vconstr_block _b -> str "Vconstr_block" | Vint64 _ -> str "Vint64" + | Vfloat64 _ -> str "Vfloat64" | Vatom_stk (_a,_stk) -> str "Vatom_stk" | Vuniv_level _ -> assert false in @@ -374,6 +383,8 @@ let rec whd_accu a stk = end | i when Int.equal i Obj.custom_tag -> Vint64 (Obj.magic i) + | i when Int.equal i Obj.double_tag -> + Vfloat64 (Obj.magic i) | tg -> CErrors.anomaly Pp.(strbrk "Failed to parse VM value. Tag = " ++ int tg ++ str ".") @@ -403,6 +414,7 @@ let whd_val : values -> whd = | 3 -> Vatom_stk(Aid(RelKey(int_tcode (fun_code o) 1)), []) | _ -> CErrors.anomaly ~label:"Vm.whd " (Pp.str "kind_of_closure does not work.")) 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 Vconstr_block(Obj.obj o) @@ -426,6 +438,7 @@ let obj_of_str_const str = | Const_univ_level l -> Obj.repr (Vuniv_level l) | Const_val v -> Obj.repr v | Const_uint i -> Obj.repr i + | Const_float f -> Obj.repr f let val_of_block tag (args : structured_values array) = let nargs = Array.length args in @@ -675,6 +688,7 @@ and pr_whd w = | Vconstr_const i -> str "Vconstr_const(" ++ int i ++ str ")" | 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 ")" | Vatom_stk (a,stk) -> str "Vatom_stk(" ++ pr_atom a ++ str ", " ++ pr_stack stk ++ str ")" | Vuniv_level _ -> assert false) and pr_stack stk = diff --git a/kernel/vmvalues.mli b/kernel/vmvalues.mli index d289e7db9a..9c24006ff0 100644 --- a/kernel/vmvalues.mli +++ b/kernel/vmvalues.mli @@ -45,6 +45,7 @@ type structured_constant = | Const_univ_level of Univ.Level.t | Const_val of structured_values | Const_uint of Uint63.t + | Const_float of Float64.t val pp_struct_const : structured_constant -> Pp.t @@ -127,6 +128,7 @@ type whd = | Vconstr_const of int | Vconstr_block of vblock | Vint64 of int64 + | Vfloat64 of float | Vatom_stk of atom * stack | Vuniv_level of Univ.Level.t diff --git a/lib/flags.ml b/lib/flags.ml index 7676665fe9..90b5f877d5 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -44,6 +44,8 @@ let with_options ol f x = let async_proofs_worker_id = ref "master" let async_proofs_is_worker () = !async_proofs_worker_id <> "master" +let load_vos_libraries = ref false + let debug = ref false let in_debugger = ref false diff --git a/lib/flags.mli b/lib/flags.mli index 3f72cc4b91..76a78e61fc 100644 --- a/lib/flags.mli +++ b/lib/flags.mli @@ -35,6 +35,10 @@ val async_proofs_worker_id : string ref val async_proofs_is_worker : unit -> bool +(** Flag to indicate that .vos files should be loaded for dependencies + instead of .vo files. Used by -vos and -vok options. *) +val load_vos_libraries : bool ref + (** Debug flags *) val debug : bool ref val in_debugger : bool ref diff --git a/library/global.mli b/library/global.mli index f8b1f35f4d..0570ad0102 100644 --- a/library/global.mli +++ b/library/global.mli @@ -157,7 +157,7 @@ val is_type_in_type : GlobRef.t -> bool (** {6 Retroknowledge } *) val register_inline : Constant.t -> unit -val register_inductive : inductive -> CPrimitives.prim_ind -> unit +val register_inductive : inductive -> 'a CPrimitives.prim_ind -> unit (** {6 Oracle } *) diff --git a/parsing/g_constr.mlg b/parsing/g_constr.mlg index 87b9a8eea3..470782a7dc 100644 --- a/parsing/g_constr.mlg +++ b/parsing/g_constr.mlg @@ -263,7 +263,7 @@ GRAMMAR EXTEND Gram { mkProdCN ~loc bl c } | "fun"; bl = open_binders; "=>"; c = operconstr LEVEL "200" -> { mkLambdaCN ~loc bl c } - | "let"; id=name; bl = binders; ty = type_cstr; ":="; + | "let"; id=name; bl = binders; ty = let_type_cstr; ":="; c1 = operconstr LEVEL "200"; "in"; c2 = operconstr LEVEL "200" -> { let ty,c1 = match ty, c1 with | (_,None), { CAst.v = CCast(c, CastConv t) } -> (Loc.tag ?loc:(constr_loc t) @@ Some t), c (* Tolerance, see G_vernac.def_body *) @@ -353,7 +353,7 @@ GRAMMAR EXTEND Gram | "cofix" -> { false } ] ] ; fix_decl: - [ [ id=identref; bl=binders_fixannot; ty=type_cstr; ":="; + [ [ id=identref; bl=binders_fixannot; ty=let_type_cstr; ":="; c=operconstr LEVEL "200" -> { (id,fst bl,snd bl,c,ty) } ] ] ; @@ -525,7 +525,7 @@ GRAMMAR EXTEND Gram ] ] ; - type_cstr: + let_type_cstr: [ [ c=OPT [":"; c=lconstr -> { c } ] -> { Loc.tag ~loc c } ] ] ; END diff --git a/plugins/extraction/ExtrOCamlFloats.v b/plugins/extraction/ExtrOCamlFloats.v new file mode 100644 index 0000000000..1891772cc2 --- /dev/null +++ b/plugins/extraction/ExtrOCamlFloats.v @@ -0,0 +1,61 @@ +(************************************************************************) +(* * 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 native binary64 floating-point numbers. + +Note: the extraction of primitive floats relies on Coq's internal file +kernel/float64.ml, so make sure the corresponding binary is available +when linking the extracted OCaml code. + +For example, if you build a (_CoqProject + coq_makefile)-based project +and if you created an empty subfolder "extracted" and a file "test.v" +containing [Cd "extracted". Separate Extraction function_to_extract.], +you will just need to add in the _CoqProject: [test.v], [-I extracted] +and the list of [extracted/*.ml] and [extracted/*.mli] files, then add +[CAMLFLAGS += -w -33] in the Makefile.local file. *) + +From Coq Require Floats Extraction. + +(** Basic data types used by some primitive operators. *) + +Extract Inductive bool => bool [ true false ]. +Extract Inductive prod => "( * )" [ "" ]. + +Extract Inductive FloatClass.float_class => + "Float64.float_class" + [ "PNormal" "NNormal" "PSubn" "NSubn" "PZero" "NZero" "PInf" "NInf" "NaN" ]. +Extract Inductive PrimFloat.float_comparison => + "Float64.float_comparison" + [ "FEq" "FLt" "FGt" "FNotComparable" ]. + +(** Primitive types and operators. *) + +Extract Constant PrimFloat.float => "Float64.t". +Extraction Inline PrimFloat.float. +(* Otherwise, the name conflicts with the primitive OCaml type [float] *) + +Extract Constant PrimFloat.classify => "Float64.classify". +Extract Constant PrimFloat.abs => "Float64.abs". +Extract Constant PrimFloat.sqrt => "Float64.sqrt". +Extract Constant PrimFloat.opp => "Float64.opp". +Extract Constant PrimFloat.eqb => "Float64.eq". +Extract Constant PrimFloat.ltb => "Float64.lt". +Extract Constant PrimFloat.leb => "Float64.le". +Extract Constant PrimFloat.compare => "Float64.compare". +Extract Constant PrimFloat.mul => "Float64.mul". +Extract Constant PrimFloat.add => "Float64.add". +Extract Constant PrimFloat.sub => "Float64.sub". +Extract Constant PrimFloat.div => "Float64.div". +Extract Constant PrimFloat.of_int63 => "Float64.of_int63". +Extract Constant PrimFloat.normfr_mantissa => "Float64.normfr_mantissa". +Extract Constant PrimFloat.frshiftexp => "Float64.frshiftexp". +Extract Constant PrimFloat.ldshiftexp => "Float64.ldshiftexp". +Extract Constant PrimFloat.next_up => "Float64.next_up". +Extract Constant PrimFloat.next_down => "Float64.next_down". diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index cca212f332..04f5b66241 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -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 _ -> assert false + | Cast _ | LetIn _ | Construct _ | Int _ | Float _ -> assert false (*s Auxiliary function dealing with type application. Precondition: [r] is a type scheme represented by the signature [s], @@ -690,6 +690,7 @@ let rec extract_term env sg mle mlt c args = let extract_var mlt = put_magic (mlt,vty) (MLglob (GlobRef.VarRef v)) in extract_app env sg mle mlt extract_var args | Int i -> assert (args = []); MLuint i + | Float f -> assert (args = []); MLfloat f | Ind _ | Prod _ | Sort _ -> assert false (*s [extract_maybe_term] is [extract_term] for usual terms, else [MLdummy] *) diff --git a/plugins/extraction/haskell.ml b/plugins/extraction/haskell.ml index e4efbcff0c..4769bef475 100644 --- a/plugins/extraction/haskell.ml +++ b/plugins/extraction/haskell.ml @@ -215,6 +215,8 @@ let rec pp_expr par env args = | MLaxiom -> pp_par par (str "Prelude.error \"AXIOM TO BE REALIZED\"") | MLuint _ -> pp_par par (str "Prelude.error \"EXTRACTION OF UINT NOT IMPLEMENTED\"") + | MLfloat _ -> + pp_par par (str "Prelude.error \"EXTRACTION OF FLOAT 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 912a20f389..81b3e1bcdc 100644 --- a/plugins/extraction/json.ml +++ b/plugins/extraction/json.ml @@ -161,6 +161,10 @@ let rec json_expr env = function ("what", json_str "expr:int"); ("int", json_str (Uint63.to_string i)) ] + | MLfloat f -> json_dict [ + ("what", json_str "expr:float"); + ("float", json_str (Float64.to_string f)) + ] 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 8b69edbe4c..32e0d3c05d 100644 --- a/plugins/extraction/miniml.ml +++ b/plugins/extraction/miniml.ml @@ -126,7 +126,8 @@ and ml_ast = | MLdummy of kill_reason | MLaxiom | MLmagic of ml_ast - | MLuint of Uint63.t + | MLuint of Uint63.t + | MLfloat of Float64.t and ml_pattern = | Pcons of GlobRef.t * ml_pattern list diff --git a/plugins/extraction/miniml.mli b/plugins/extraction/miniml.mli index e3c9635c55..32e0d3c05d 100644 --- a/plugins/extraction/miniml.mli +++ b/plugins/extraction/miniml.mli @@ -127,6 +127,7 @@ and ml_ast = | MLaxiom | MLmagic of ml_ast | MLuint of Uint63.t + | MLfloat of Float64.t and ml_pattern = | Pcons of GlobRef.t * ml_pattern list diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml index 000df26858..44b95ae4c1 100644 --- a/plugins/extraction/mlutil.ml +++ b/plugins/extraction/mlutil.ml @@ -398,6 +398,7 @@ let rec eq_ml_ast t1 t2 = match t1, t2 with | MLaxiom, MLaxiom -> true | MLmagic t1, MLmagic t2 -> eq_ml_ast t1 t2 | MLuint i1, MLuint i2 -> Uint63.equal i1 i2 +| MLfloat f1, MLfloat f2 -> Float64.equal f1 f2 | _, _ -> false and eq_ml_pattern p1 p2 = match p1, p2 with @@ -430,7 +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 - | MLglob _ | MLexn _ | MLdummy _ | MLaxiom | MLuint _ -> () + | MLglob _ | MLexn _ | MLdummy _ | MLaxiom | MLuint _ | MLfloat _ -> () in iter 0 (*s Map over asts. *) @@ -449,7 +450,8 @@ 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) - | MLrel _ | MLglob _ | MLexn _ | MLdummy _ | MLaxiom | MLuint _ as a -> a + | MLrel _ | MLglob _ | MLexn _ | MLdummy _ | MLaxiom + | MLuint _ | MLfloat _ as a -> a (*s Map over asts, with binding depth as parameter. *) @@ -467,7 +469,8 @@ 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) - | MLrel _ | MLglob _ | MLexn _ | MLdummy _ | MLaxiom | MLuint _ as a -> a + | MLrel _ | MLglob _ | MLexn _ | MLdummy _ | MLaxiom + | MLuint _ | MLfloat _ as a -> a (*s Iter over asts. *) @@ -481,7 +484,8 @@ 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 - | MLrel _ | MLglob _ | MLexn _ | MLdummy _ | MLaxiom | MLuint _ -> () + | MLrel _ | MLglob _ | MLexn _ | MLdummy _ | MLaxiom + | MLuint _ | MLfloat _ -> () (*S Operations concerning De Bruijn indices. *) @@ -517,7 +521,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 - | MLglob _ | MLexn _ | MLdummy _ | MLaxiom | MLuint _ -> 0 + | MLglob _ | MLexn _ | MLdummy _ | MLaxiom | MLuint _ | MLfloat _ -> 0 in nb 1 (* Replace unused variables by _ *) @@ -569,7 +573,7 @@ let dump_unused_vars a = let b' = ren env b in if b' == b then a else MLmagic b' - | MLglob _ | MLexn _ | MLdummy _ | MLaxiom | MLuint _ -> a + | MLglob _ | MLexn _ | MLdummy _ | MLaxiom | MLuint _ | MLfloat _ -> a and ren_branch env ((ids,p,b) as tr) = let occs = List.map (fun _ -> ref false) ids in @@ -1402,7 +1406,8 @@ let rec ml_size = function | MLfix(_,_,f) -> ml_size_array f | MLletin (_,_,t) -> ml_size t | MLmagic t -> ml_size t - | MLglob _ | MLrel _ | MLexn _ | MLdummy _ | MLaxiom | MLuint _ -> 0 + | MLglob _ | MLrel _ | MLexn _ | MLdummy _ | MLaxiom + | MLuint _ | MLfloat _ -> 0 and ml_size_list l = List.fold_left (fun a t -> a + ml_size t) 0 l diff --git a/plugins/extraction/modutil.ml b/plugins/extraction/modutil.ml index 6b1eef7abb..fe49bfc1ec 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 _ -> () + | MLdummy _ | MLaxiom | MLmagic _ | MLuint _ | MLfloat _ -> () 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 e7004fe9af..34ddf57b40 100644 --- a/plugins/extraction/ocaml.ml +++ b/plugins/extraction/ocaml.ml @@ -307,6 +307,9 @@ let rec pp_expr par env args = | MLuint i -> assert (args=[]); str "(" ++ str (Uint63.compile i) ++ str ")" + | MLfloat f -> + assert (args=[]); + str "(" ++ str (Float64.compile f) ++ str ")" and pp_record_proj par env typ t pv args = diff --git a/plugins/extraction/scheme.ml b/plugins/extraction/scheme.ml index dd840cd929..c341ec8d57 100644 --- a/plugins/extraction/scheme.ml +++ b/plugins/extraction/scheme.ml @@ -131,6 +131,8 @@ let rec pp_expr env args = | MLaxiom -> paren (str "error \"AXIOM TO BE REALIZED\"") | MLuint _ -> paren (str "Prelude.error \"EXTRACTION OF UINT NOT IMPLEMENTED\"") + | MLfloat _ -> + paren (str "Prelude.error \"EXTRACTION OF FLOAT NOT IMPLEMENTED\"") and pp_cons_args env = function | MLcons (_,r,args) when is_coinductive r -> diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 7be049269c..6db0a1119b 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -692,13 +692,14 @@ let build_proof end | Cast(t,_,_) -> build_proof do_finalize {dyn_infos with info = t} g - | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ | Int _ -> + | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ | Int _ | Float _ -> do_finalize dyn_infos g | App(_,_) -> let f,args = decompose_app sigma dyn_infos.info in begin match EConstr.kind sigma f with - | Int _ -> user_err Pp.(str "integer cannot be applied") + | Int _ -> user_err Pp.(str "integer cannot be applied") + | Float _ -> user_err Pp.(str "float cannot be applied") | App _ -> assert false (* we have collected all the app in decompose_app *) | Proj _ -> assert false (*FIXME*) | Var _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ | Sort _ | Prod _ -> diff --git a/plugins/funind/gen_principle.ml b/plugins/funind/gen_principle.ml index 0452665585..6add56dd5b 100644 --- a/plugins/funind/gen_principle.ml +++ b/plugins/funind/gen_principle.ml @@ -68,7 +68,7 @@ let is_rec names = let check_id id names = Id.Set.mem id names in let rec lookup names gt = match DAst.get gt with | GVar(id) -> check_id id names - | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ | GInt _ -> false + | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ | GInt _ | GFloat _ -> false | GCast(b,_) -> lookup names b | GRec _ -> CErrors.user_err (Pp.str "GRec not handled") | GIf(b,_,lhs,rhs) -> diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 7c17ecdba0..895b6a37ee 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -478,7 +478,7 @@ let rec build_entry_lc env sigma funnames avoid rt : glob_constr build_entry_ret observe (str " Entering : " ++ Printer.pr_glob_constr_env env rt); let open CAst in match DAst.get rt with - | GRef _ | GVar _ | GEvar _ | GPatVar _ | GSort _ | GHole _ | GInt _ -> + | GRef _ | GVar _ | GEvar _ | GPatVar _ | GSort _ | GHole _ | GInt _ | GFloat _ -> (* do nothing (except changing type of course) *) mk_result [] rt avoid | GApp(_,_) -> @@ -590,6 +590,7 @@ let rec build_entry_lc env sigma funnames avoid rt : glob_constr build_entry_ret | GRec _ -> user_err Pp.(str "Not handled GRec") | 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") end (* end of the application treatement *) | GLambda(n,_,t,b) -> @@ -1231,7 +1232,7 @@ let rebuild_cons env nb_args relname args crossed_types rt = TODO: Find a valid way to deal with implicit arguments here! *) let rec compute_cst_params relnames params gt = DAst.with_val (function - | GRef _ | GVar _ | GEvar _ | GPatVar _ | GInt _ -> params + | GRef _ | GVar _ | GEvar _ | GPatVar _ | GInt _ | GFloat _ -> params | GApp(f,args) -> begin match DAst.get f with | GVar relname' when Id.Set.mem relname' relnames -> diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml index 8abccabae6..5f54bad598 100644 --- a/plugins/funind/glob_termops.ml +++ b/plugins/funind/glob_termops.ml @@ -115,6 +115,7 @@ let change_vars = | GSort _ as x -> x | GHole _ as x -> x | GInt _ as x -> x + | GFloat _ as x -> x | GCast(b,c) -> GCast(change_vars mapping b, Glob_ops.map_cast_type (change_vars mapping) c) @@ -295,6 +296,7 @@ let rec alpha_rt excluded rt = | GRec _ -> user_err Pp.(str "Not handled GRec") | GSort _ | GInt _ + | GFloat _ | GHole _ as rt -> rt | GCast (b,c) -> GCast(alpha_rt excluded b, @@ -354,7 +356,7 @@ 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 _ -> false + | GInt _ | GFloat _ -> false ) x and is_free_in_br {CAst.v=(ids,_,rt)} = (not (Id.List.mem id ids)) && is_free_in rt @@ -447,6 +449,7 @@ let replace_var_by_term x_id term = | GSort _ | GHole _ as rt -> rt | GInt _ as rt -> rt + | GFloat _ as rt -> rt | GCast(b,c) -> GCast(replace_var_by_pattern b, Glob_ops.map_cast_type replace_var_by_pattern c) @@ -529,7 +532,7 @@ let expand_as = | PatCstr(_,patl,_) -> List.fold_left add_as map patl in let rec expand_as map = DAst.map (function - | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ | GInt _ as rt -> rt + | GRef _ | GEvar _ | GPatVar _ | GSort _ | GHole _ | GInt _ | GFloat _ as rt -> rt | GVar id as rt -> begin try diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 29356df81d..66ed1961ba 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -270,7 +270,7 @@ let check_not_nested env sigma forbidden e = let rec check_not_nested e = match EConstr.kind sigma e with | Rel _ -> () - | Int _ -> () + | Int _ | Float _ -> () | Var x -> if Id.List.mem x forbidden then user_err ~hdr:"Recdef.check_not_nested" @@ -452,7 +452,7 @@ let rec travel_aux jinfo continuation_tac (expr_info:constr infos) g = | _ -> anomaly (Pp.str "travel_aux : unexpected "++ Printer.pr_leconstr_env env sigma expr_info.info ++ Pp.str ".") end | Cast(t,_,_) -> travel jinfo continuation_tac {expr_info with info=t} g - | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ | Int _ -> + | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ | Int _ | Float _ -> let new_continuation_tac = jinfo.otherS () expr_info continuation_tac in new_continuation_tac expr_info g diff --git a/plugins/micromega/DeclConstant.v b/plugins/micromega/DeclConstant.v index 0288728504..7ad5e313e3 100644 --- a/plugins/micromega/DeclConstant.v +++ b/plugins/micromega/DeclConstant.v @@ -51,7 +51,7 @@ Instance GT_APP2 {T1 T2 T3: Type} (F : T1 -> T2 -> T3) GT A1 -> GT A2 -> GT (F A1 A2). Defined. -Require Import ZArith. +Require Import QArith_base. Instance DO : DeclaredConstant O := {}. Instance DS : DeclaredConstant S := {}. @@ -64,6 +64,4 @@ Instance DZneg: DeclaredConstant Zneg := {}. Instance DZpow_pos : DeclaredConstant Z.pow_pos := {}. Instance DZpow : DeclaredConstant Z.pow := {}. -Require Import QArith. - Instance DQ : DeclaredConstant Qmake := {}. diff --git a/plugins/micromega/Lia.v b/plugins/micromega/Lia.v index 3351c7ef8a..55a93eade7 100644 --- a/plugins/micromega/Lia.v +++ b/plugins/micromega/Lia.v @@ -15,7 +15,7 @@ (************************************************************************) Require Import ZMicromega. -Require Import ZArith. +Require Import ZArith_base. Require Import RingMicromega. Require Import VarMap. Require Import DeclConstant. diff --git a/plugins/micromega/RMicromega.v b/plugins/micromega/RMicromega.v index 3651b54ed8..6c1852acbf 100644 --- a/plugins/micromega/RMicromega.v +++ b/plugins/micromega/RMicromega.v @@ -22,6 +22,7 @@ Require Import QArith. Require Import Qfield. Require Import Qreals. Require Import DeclConstant. +Require Import Lia. Require Setoid. (*Declare ML Module "micromega_plugin".*) @@ -192,7 +193,7 @@ Proof. destruct z ; try congruence. compute. congruence. compute. congruence. - generalize (Zle_0_nat n). auto with zarith. + generalize (Zle_0_nat n). auto using Z.le_ge. Qed. Definition CInvR0 (r : Rcst) := Qeq_bool (Q_of_Rcst r) (0 # 1). @@ -333,7 +334,7 @@ Proof. apply Qeq_bool_eq in C2. rewrite C2. simpl. - rewrite Qpower0 by auto with zarith. + rewrite Qpower0 by lia. apply Q2R_0. + rewrite Q2RpowerRZ. rewrite IHc. @@ -341,7 +342,7 @@ Proof. rewrite andb_false_iff in C. destruct C. simpl. apply Z.ltb_ge in H. - auto with zarith. + lia. left ; apply Qeq_bool_neq; auto. + simpl. rewrite <- IHc. diff --git a/plugins/micromega/VarMap.v b/plugins/micromega/VarMap.v index f93fe021f9..6db62e8401 100644 --- a/plugins/micromega/VarMap.v +++ b/plugins/micromega/VarMap.v @@ -15,7 +15,7 @@ (* *) (************************************************************************) -Require Import ZArith. +Require Import ZArith_base. Require Import Coq.Arith.Max. Require Import List. Set Implicit Arguments. diff --git a/plugins/micromega/ZCoeff.v b/plugins/micromega/ZCoeff.v index 26970faf0c..08f3f39204 100644 --- a/plugins/micromega/ZCoeff.v +++ b/plugins/micromega/ZCoeff.v @@ -12,9 +12,10 @@ Require Import OrderedRing. Require Import RingMicromega. -Require Import ZArith. +Require Import ZArith_base. Require Import InitialRing. Require Import Setoid. +Require Import ZArithRing. Import OrderedRingSyntax. diff --git a/plugins/micromega/ZMicromega.v b/plugins/micromega/ZMicromega.v index c160e11467..d709fdda14 100644 --- a/plugins/micromega/ZMicromega.v +++ b/plugins/micromega/ZMicromega.v @@ -21,7 +21,8 @@ Require Import RingMicromega. Require FSetPositive FSetEqProperties. Require Import ZCoeff. Require Import Refl. -Require Import ZArith. +Require Import ZArith_base. +Require Import ZArithRing. Require PreOmega. (*Declare ML Module "micromega_plugin".*) Local Open Scope Z_scope. diff --git a/plugins/ssr/ssrclasses.v b/plugins/ssr/ssrclasses.v new file mode 100644 index 0000000000..0ae3f8c6a5 --- /dev/null +++ b/plugins/ssr/ssrclasses.v @@ -0,0 +1,32 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(** #<style> .doc { font-family: monospace; white-space: pre; } </style># **) + +(** Compatibility layer for [under] and [setoid_rewrite]. + + Note: this file does not require [ssreflect]; it is both required by + [ssrsetoid] and required by [ssrunder]. + + Redefine [Coq.Classes.RelationClasses.Reflexive] here, so that doing + [Require Import ssreflect] does not [Require Import RelationClasses], + and conversely. **) + +Section Defs. + Context {A : Type}. + Class Reflexive (R : A -> A -> Prop) := + reflexivity : forall x : A, R x x. +End Defs. + +Register Reflexive as plugins.ssreflect.reflexive_type. +Register reflexivity as plugins.ssreflect.reflexive_proof. + +Instance eq_Reflexive {A : Type} : Reflexive (@eq A) := @eq_refl A. +Instance iff_Reflexive : Reflexive iff := iff_refl. diff --git a/plugins/ssr/ssreflect.v b/plugins/ssr/ssreflect.v index 9ebdf71329..bc4a57dedd 100644 --- a/plugins/ssr/ssreflect.v +++ b/plugins/ssr/ssreflect.v @@ -530,102 +530,32 @@ Lemma abstract_context T (P : T -> Type) x : Proof. by move=> /(_ P); apply. Qed. (*****************************************************************************) -(* Constants for under, to rewrite under binders using "Leibniz eta lemmas". *) - -Module Type UNDER_EQ. -Parameter Under_eq : - forall (R : Type), R -> R -> Prop. -Parameter Under_eq_from_eq : - forall (T : Type) (x y : T), @Under_eq T x y -> x = y. - -(** [Over_eq, over_eq, over_eq_done]: for "by rewrite over_eq" *) -Parameter Over_eq : - forall (R : Type), R -> R -> Prop. -Parameter over_eq : - forall (T : Type) (x : T) (y : T), @Under_eq T x y = @Over_eq T x y. -Parameter over_eq_done : - forall (T : Type) (x : T), @Over_eq T x x. -(* We need both hints below, otherwise the test-suite does not pass *) -Hint Extern 0 (@Over_eq _ _ _) => solve [ apply over_eq_done ] : core. -(* => for [test-suite/ssr/under.v:test_big_patt1] *) -Hint Resolve over_eq_done : core. -(* => for [test-suite/ssr/over.v:test_over_1_1] *) - -(** [under_eq_done]: for Ltac-style over *) -Parameter under_eq_done : - forall (T : Type) (x : T), @Under_eq T x x. -Notation "''Under[' x ]" := (@Under_eq _ x _) - (at level 8, format "''Under[' x ]", only printing). -End UNDER_EQ. - -Module Export Under_eq : UNDER_EQ. -Definition Under_eq := @eq. -Lemma Under_eq_from_eq (T : Type) (x y : T) : - @Under_eq T x y -> x = y. -Proof. by []. Qed. -Definition Over_eq := Under_eq. -Lemma over_eq : - forall (T : Type) (x : T) (y : T), @Under_eq T x y = @Over_eq T x y. -Proof. by []. Qed. -Lemma over_eq_done : - forall (T : Type) (x : T), @Over_eq T x x. -Proof. by []. Qed. -Lemma under_eq_done : - forall (T : Type) (x : T), @Under_eq T x x. -Proof. by []. Qed. -End Under_eq. - -Register Under_eq as plugins.ssreflect.Under_eq. -Register Under_eq_from_eq as plugins.ssreflect.Under_eq_from_eq. - -Module Type UNDER_IFF. -Parameter Under_iff : Prop -> Prop -> Prop. -Parameter Under_iff_from_iff : forall x y : Prop, @Under_iff x y -> x <-> y. - -(** [Over_iff, over_iff, over_iff_done]: for "by rewrite over_iff" *) -Parameter Over_iff : Prop -> Prop -> Prop. -Parameter over_iff : - forall (x : Prop) (y : Prop), @Under_iff x y = @Over_iff x y. -Parameter over_iff_done : - forall (x : Prop), @Over_iff x x. -Hint Extern 0 (@Over_iff _ _) => solve [ apply over_iff_done ] : core. -Hint Resolve over_iff_done : core. - -(** [under_iff_done]: for Ltac-style over *) -Parameter under_iff_done : - forall (x : Prop), @Under_iff x x. -Notation "''Under[' x ]" := (@Under_iff x _) - (at level 8, format "''Under[' x ]", only printing). -End UNDER_IFF. - -Module Export Under_iff : UNDER_IFF. -Definition Under_iff := iff. -Lemma Under_iff_from_iff (x y : Prop) : - @Under_iff x y -> x <-> y. -Proof. by []. Qed. -Definition Over_iff := Under_iff. -Lemma over_iff : - forall (x : Prop) (y : Prop), @Under_iff x y = @Over_iff x y. -Proof. by []. Qed. -Lemma over_iff_done : - forall (x : Prop), @Over_iff x x. -Proof. by []. Qed. -Lemma under_iff_done : - forall (x : Prop), @Under_iff x x. -Proof. by []. Qed. -End Under_iff. - -Register Under_iff as plugins.ssreflect.Under_iff. -Register Under_iff_from_iff as plugins.ssreflect.Under_iff_from_iff. - -Definition over := (over_eq, over_iff). +(* Material for under/over (to rewrite under binders using "context lemmas") *) +Require Export ssrunder. + +Hint Extern 0 (@Under_rel.Over_rel _ _ _ _) => + solve [ apply: Under_rel.over_rel_done ] : core. +Hint Resolve Under_rel.over_rel_done : core. + +Register Under_rel.Under_rel as plugins.ssreflect.Under_rel. +Register Under_rel.Under_rel_from_rel as plugins.ssreflect.Under_rel_from_rel. + +(** Closing rewrite rule *) +Definition over := over_rel. + +(** Closing tactic *) Ltac over := - by [ apply: Under_eq.under_eq_done - | apply: Under_iff.under_iff_done + by [ apply: Under_rel.under_rel_done | rewrite over ]. +(** Convenience rewrite rule to unprotect evars, e.g., to instantiate + them in another way than with reflexivity. *) +Definition UnderE := Under_relE. + +(*****************************************************************************) + (** An interface for non-Prop types; used to avoid improper instantiation of polymorphic lemmas with on-demand implicits when they are used as views. For example: Some_inj {T} : forall x y : T, Some x = Some y -> x = y. diff --git a/plugins/ssr/ssreflect_plugin.mlpack b/plugins/ssr/ssreflect_plugin.mlpack index 824348fee7..46669998b9 100644 --- a/plugins/ssr/ssreflect_plugin.mlpack +++ b/plugins/ssr/ssreflect_plugin.mlpack @@ -10,4 +10,3 @@ Ssripats Ssrfwd Ssrparser Ssrvernac - diff --git a/plugins/ssr/ssrequality.mli b/plugins/ssr/ssrequality.mli index 43aeeb2dae..baf5288725 100644 --- a/plugins/ssr/ssrequality.mli +++ b/plugins/ssr/ssrequality.mli @@ -42,6 +42,9 @@ val mk_rwarg : val norwmult : ssrdir * ssrmult val norwocc : (Ssrast.ssrclear option * Ssrast.ssrocc) * Ssrmatching.rpattern option +val ssr_is_setoid : + Environ.env -> Evd.evar_map -> EConstr.t -> EConstr.t array -> bool + val ssrinstancesofrule : Ltac_plugin.Tacinterp.interp_sign -> Ssrast.ssrdir -> diff --git a/plugins/ssr/ssrfwd.ml b/plugins/ssr/ssrfwd.ml index cca94c8c9b..b0f56c423f 100644 --- a/plugins/ssr/ssrfwd.ml +++ b/plugins/ssr/ssrfwd.ml @@ -340,6 +340,21 @@ let intro_lock ipats = let hnf' = Proofview.numgoals >>= fun ng -> Proofview.tclDISPATCH (ncons (ng - 1) ssrsmovetac @ [Proofview.tclUNIT ()]) in + let protect_subgoal env sigma hd args = + Tactics.New.refine ~typecheck:true (fun sigma -> + let lm2 = Array.length args - 2 in + let sigma, carrier = + Typing.type_of env sigma args.(lm2) in + let rel = EConstr.mkApp (hd, Array.sub args 0 lm2) in + let rel_args = Array.sub args lm2 2 in + let sigma, under_rel = + Ssrcommon.mkSsrConst "Under_rel" env sigma in + let sigma, under_from_rel = + Ssrcommon.mkSsrConst "Under_rel_from_rel" env sigma in + let under_rel_args = Array.append [|carrier; rel|] rel_args in + let ty = EConstr.mkApp (under_rel, under_rel_args) in + let sigma, t = Evarutil.new_evar env sigma ty in + sigma, EConstr.mkApp(under_from_rel,Array.append under_rel_args [|t|])) in let rec lock_eq () : unit Proofview.tactic = Proofview.Goal.enter begin fun _ -> Proofview.tclORELSE (Ssripats.tclIPAT [Ssripats.IOpTemporay; Ssripats.IOpEqGen (lock_eq ())]) @@ -349,30 +364,23 @@ let intro_lock ipats = let env = Proofview.Goal.env gl in match EConstr.kind_of_type sigma c with | Term.AtomicType(hd, args) when + Array.length args >= 2 && is_app_evar sigma (Array.last args) && + Ssrequality.ssr_is_setoid env sigma hd args + (* if the last condition above [ssr_is_setoid ...] holds + then [Coq.Classes.RelationClasses] has been required *) + || + (* if this is not the case, the tactic can still succeed + when the considered relation is [Coq.Init.Logic.iff] *) Ssrcommon.is_const_ref sigma hd (Coqlib.lib_ref "core.iff.type") && - Array.length args = 2 && is_app_evar sigma args.(1) -> - Tactics.New.refine ~typecheck:true (fun sigma -> - let sigma, under_iff = - Ssrcommon.mkSsrConst "Under_iff" env sigma in - let sigma, under_from_iff = - Ssrcommon.mkSsrConst "Under_iff_from_iff" env sigma in - let ty = EConstr.mkApp (under_iff,args) in - let sigma, t = Evarutil.new_evar env sigma ty in - sigma, EConstr.mkApp(under_from_iff,Array.append args [|t|])) + Array.length args = 2 && is_app_evar sigma args.(1) -> + protect_subgoal env sigma hd args | _ -> let t = Reductionops.whd_all env sigma c in match EConstr.kind_of_type sigma t with | Term.AtomicType(hd, args) when Ssrcommon.is_ind_ref sigma hd (Coqlib.lib_ref "core.eq.type") && Array.length args = 3 && is_app_evar sigma args.(2) -> - Tactics.New.refine ~typecheck:true (fun sigma -> - let sigma, under = - Ssrcommon.mkSsrConst "Under_eq" env sigma in - let sigma, under_from_eq = - Ssrcommon.mkSsrConst "Under_eq_from_eq" env sigma in - let ty = EConstr.mkApp (under,args) in - let sigma, t = Evarutil.new_evar env sigma ty in - sigma, EConstr.mkApp(under_from_eq,Array.append args [|t|])) + protect_subgoal env sigma hd args | _ -> ppdebug(lazy Pp.(str"under: stop:" ++ pr_econstr_env env sigma t)); diff --git a/plugins/ssr/ssrsetoid.v b/plugins/ssr/ssrsetoid.v new file mode 100644 index 0000000000..609c9d5ab8 --- /dev/null +++ b/plugins/ssr/ssrsetoid.v @@ -0,0 +1,122 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(** #<style> .doc { font-family: monospace; white-space: pre; } </style># **) + +(** Compatibility layer for [under] and [setoid_rewrite]. + + This file is intended to be required by [Require Import Setoid]. + + In particular, we can use the [under] tactic with other relations + than [eq] or [iff], e.g. a [RewriteRelation], by doing: + [Require Import ssreflect. Require Setoid.] + + This file's instances have priority 12 > other stdlib instances + and each [Under_rel] instance comes with a [Hint Cut] directive + (otherwise Ring_polynom.v won't compile because of unbounded search). + + (Note: this file could be skipped when porting [under] to stdlib2.) + *) + +Require Import ssrclasses. +Require Import ssrunder. +Require Import RelationClasses. +Require Import Relation_Definitions. + +(** Reconcile [Coq.Classes.RelationClasses.Reflexive] with + [Coq.ssr.ssrclasses.Reflexive] *) + +Instance compat_Reflexive : + forall {A} {R : relation A}, + RelationClasses.Reflexive R -> + ssrclasses.Reflexive R | 12. +Proof. now trivial. Qed. + +(** Add instances so that ['Under[ F i ]] terms, + that is, [Under_rel T R (F i) (?G i)] terms, + can be manipulated with rewrite/setoid_rewrite with lemmas on [R]. + Note that this requires that [R] is a [Prop] relation, otherwise + a [bool] relation may need to be "lifted": see the [TestPreOrder] + section in test-suite/ssr/under.v *) + +Instance Under_subrelation {A} (R : relation A) : subrelation R (Under_rel _ R) | 12. +Proof. now rewrite Under_relE. Qed. + +(* see also Morphisms.trans_co_eq_inv_impl_morphism *) + +Instance Under_Reflexive {A} (R : relation A) : + RelationClasses.Reflexive R -> + RelationClasses.Reflexive (Under_rel.Under_rel A R) | 12. +Proof. now rewrite Under_rel.Under_relE. Qed. + +Hint Cut [_* Under_Reflexive Under_Reflexive] : typeclass_instances. + +(* These instances are a bit off-topic given that (Under_rel A R) will + typically be reflexive, to be able to trigger the [over] terminator + +Instance under_Irreflexive {A} (R : relation A) : + RelationClasses.Irreflexive R -> + RelationClasses.Irreflexive (Under_rel.Under_rel A R) | 12. +Proof. now rewrite Under_rel.Under_relE. Qed. + +Hint Cut [_* Under_Irreflexive Under_Irreflexive] : typeclass_instances. + +Instance under_Asymmetric {A} (R : relation A) : + RelationClasses.Asymmetric R -> + RelationClasses.Asymmetric (Under_rel.Under_rel A R) | 12. +Proof. now rewrite Under_rel.Under_relE. Qed. + +Hint Cut [_* Under_Asymmetric Under_Asymmetric] : typeclass_instances. + +Instance under_StrictOrder {A} (R : relation A) : + RelationClasses.StrictOrder R -> + RelationClasses.StrictOrder (Under_rel.Under_rel A R) | 12. +Proof. now rewrite Under_rel.Under_relE. Qed. + +Hint Cut [_* Under_Strictorder Under_Strictorder] : typeclass_instances. + *) + +Instance Under_Symmetric {A} (R : relation A) : + RelationClasses.Symmetric R -> + RelationClasses.Symmetric (Under_rel.Under_rel A R) | 12. +Proof. now rewrite Under_rel.Under_relE. Qed. + +Hint Cut [_* Under_Symmetric Under_Symmetric] : typeclass_instances. + +Instance Under_Transitive {A} (R : relation A) : + RelationClasses.Transitive R -> + RelationClasses.Transitive (Under_rel.Under_rel A R) | 12. +Proof. now rewrite Under_rel.Under_relE. Qed. + +Hint Cut [_* Under_Transitive Under_Transitive] : typeclass_instances. + +Instance Under_PreOrder {A} (R : relation A) : + RelationClasses.PreOrder R -> + RelationClasses.PreOrder (Under_rel.Under_rel A R) | 12. +Proof. now rewrite Under_rel.Under_relE. Qed. + +Hint Cut [_* Under_PreOrder Under_PreOrder] : typeclass_instances. + +Instance Under_PER {A} (R : relation A) : + RelationClasses.PER R -> + RelationClasses.PER (Under_rel.Under_rel A R) | 12. +Proof. now rewrite Under_rel.Under_relE. Qed. + +Hint Cut [_* Under_PER Under_PER] : typeclass_instances. + +Instance Under_Equivalence {A} (R : relation A) : + RelationClasses.Equivalence R -> + RelationClasses.Equivalence (Under_rel.Under_rel A R) | 12. +Proof. now rewrite Under_rel.Under_relE. Qed. + +Hint Cut [_* Under_Equivalence Under_Equivalence] : typeclass_instances. + +(* Don't handle Antisymmetric and PartialOrder classes for now, + as these classes depend on two relation symbols... *) diff --git a/plugins/ssr/ssrunder.v b/plugins/ssr/ssrunder.v new file mode 100644 index 0000000000..7c529a6133 --- /dev/null +++ b/plugins/ssr/ssrunder.v @@ -0,0 +1,75 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(** #<style> .doc { font-family: monospace; white-space: pre; } </style># **) + +(** Constants for under/over, to rewrite under binders using "context lemmas" + + Note: this file does not require [ssreflect]; it is both required by + [ssrsetoid] and *exported* by [ssrunder]. + + This preserves the following feature: we can use [Setoid] without + requiring [ssreflect] and use [ssreflect] without requiring [Setoid]. +*) + +Require Import ssrclasses. + +Module Type UNDER_REL. +Parameter Under_rel : + forall (A : Type) (eqA : A -> A -> Prop), A -> A -> Prop. +Parameter Under_rel_from_rel : + forall (A : Type) (eqA : A -> A -> Prop) (x y : A), + @Under_rel A eqA x y -> eqA x y. +Parameter Under_relE : + forall (A : Type) (eqA : A -> A -> Prop), + @Under_rel A eqA = eqA. + +(** [Over_rel, over_rel, over_rel_done]: for "by rewrite over_rel" *) +Parameter Over_rel : + forall (A : Type) (eqA : A -> A -> Prop), A -> A -> Prop. +Parameter over_rel : + forall (A : Type) (eqA : A -> A -> Prop) (x y : A), + @Under_rel A eqA x y = @Over_rel A eqA x y. +Parameter over_rel_done : + forall (A : Type) (eqA : A -> A -> Prop) (EeqA : Reflexive eqA) (x : A), + @Over_rel A eqA x x. + +(** [under_rel_done]: for Ltac-style over *) +Parameter under_rel_done : + forall (A : Type) (eqA : A -> A -> Prop) (EeqA : Reflexive eqA) (x : A), + @Under_rel A eqA x x. +Notation "''Under[' x ]" := (@Under_rel _ _ x _) + (at level 8, format "''Under[' x ]", only printing). +End UNDER_REL. + +Module Export Under_rel : UNDER_REL. +Definition Under_rel (A : Type) (eqA : A -> A -> Prop) := + eqA. +Lemma Under_rel_from_rel : + forall (A : Type) (eqA : A -> A -> Prop) (x y : A), + @Under_rel A eqA x y -> eqA x y. +Proof. now trivial. Qed. +Lemma Under_relE (A : Type) (eqA : A -> A -> Prop) : + @Under_rel A eqA = eqA. +Proof. now trivial. Qed. +Definition Over_rel := Under_rel. +Lemma over_rel : + forall (A : Type) (eqA : A -> A -> Prop) (x y : A), + @Under_rel A eqA x y = @Over_rel A eqA x y. +Proof. now trivial. Qed. +Lemma over_rel_done : + forall (A : Type) (eqA : A -> A -> Prop) (EeqA : Reflexive eqA) (x : A), + @Over_rel A eqA x x. +Proof. now unfold Over_rel. Qed. +Lemma under_rel_done : + forall (A : Type) (eqA : A -> A -> Prop) (EeqA : Reflexive eqA) (x : A), + @Under_rel A eqA x x. +Proof. now trivial. Qed. +End Under_rel. diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index 4d7a04f5ee..9682487a22 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -319,7 +319,7 @@ let iter_constr_LR f c = match kind c with for i = 0 to Array.length t - 1 do f t.(i); f b.(i) done | Proj(_,a) -> f a | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _ - | Int _) -> () + | Int _ | Float _) -> () (* The comparison used to determine which subterms matches is KEYED *) (* CONVERSION. This looks for convertible terms that either have the same *) diff --git a/plugins/syntax/float_syntax.ml b/plugins/syntax/float_syntax.ml new file mode 100644 index 0000000000..3c2e217d1c --- /dev/null +++ b/plugins/syntax/float_syntax.ml @@ -0,0 +1,50 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2017 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Names +open Glob_term + +(* Poor's man DECLARE PLUGIN *) +let __coq_plugin_name = "float_syntax_plugin" +let () = Mltop.add_known_module __coq_plugin_name + +(*** Constants for locating float constructors ***) + +let make_dir l = DirPath.make (List.rev_map Id.of_string l) +let make_path dir id = Libnames.make_path (make_dir dir) (Id.of_string id) + +(*** Parsing for float in digital notation ***) + +let interp_float ?loc (sign,n) = + let sign = Constrexpr.(match sign with SPlus -> "" | SMinus -> "-") in + DAst.make ?loc (GFloat (Float64.of_string (sign ^ NumTok.to_string n))) + +(* Pretty printing is already handled in constrextern.ml *) + +let uninterp_float _ = None + +(* Actually declares the interpreter for float *) + +open Notation + +let at_declare_ml_module f x = + Mltop.declare_cache_obj (fun () -> f x) __coq_plugin_name + +let float_module = ["Coq"; "Floats"; "PrimFloat"] +let float_path = make_path float_module "float" +let float_scope = "float_scope" + +let _ = + register_rawnumeral_interpretation float_scope (interp_float,uninterp_float); + at_declare_ml_module enable_prim_token_interpretation + { pt_local = false; + pt_scope = float_scope; + pt_interp_info = Uid float_scope; + pt_required = (float_path,float_module); + pt_refs = []; + pt_in_match = false } diff --git a/plugins/syntax/float_syntax_plugin.mlpack b/plugins/syntax/float_syntax_plugin.mlpack new file mode 100644 index 0000000000..d69f49bcfe --- /dev/null +++ b/plugins/syntax/float_syntax_plugin.mlpack @@ -0,0 +1 @@ +Float_syntax diff --git a/plugins/syntax/plugin_base.dune b/plugins/syntax/plugin_base.dune index 7a23581768..512752135d 100644 --- a/plugins/syntax/plugin_base.dune +++ b/plugins/syntax/plugin_base.dune @@ -25,3 +25,10 @@ (synopsis "Coq syntax plugin: int63") (modules int63_syntax) (libraries coq.vernac)) + +(library + (name float_syntax_plugin) + (public_name coq.plugins.float_syntax) + (synopsis "Coq syntax plugin: float") + (modules float_syntax) + (libraries coq.vernac)) diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml index 43b94aed3d..c78f791a5a 100644 --- a/pretyping/cbv.ml +++ b/pretyping/cbv.ml @@ -220,14 +220,26 @@ module VNativeEntries = | _ -> raise Primred.NativeDestKO) | _ -> raise Primred.NativeDestKO + let get_float () e = + match e with + | VAL(_, cf) -> + (match kind cf with + | Float f -> f + | _ -> raise Primred.NativeDestKO) + | _ -> raise Primred.NativeDestKO + let mkInt env i = VAL(0, mkInt i) + let mkFloat env f = VAL(0, mkFloat f) + let mkBool env b = let (ct,cf) = get_bool_constructors env in CONSTR(Univ.in_punivs (if b then ct else cf), [||]) let int_ty env = VAL(0, mkConst @@ get_int_type env) + let float_ty env = VAL(0, mkConst @@ get_float_type env) + let mkCarry env b e = let (c0,c1) = get_carry_constructors env in CONSTR(Univ.in_punivs (if b then c1 else c0), [|int_ty env;e|]) @@ -237,6 +249,12 @@ module VNativeEntries = let c = get_pair_constructor env in CONSTR(Univ.in_punivs c, [|int_ty;int_ty;e1;e2|]) + let mkFloatIntPair env f i = + let float_ty = float_ty env in + let int_ty = int_ty env in + let c = get_pair_constructor env in + CONSTR(Univ.in_punivs c, [|float_ty;int_ty;f;i|]) + let mkLt env = let (_eq,lt,_gt) = get_cmp_constructors env in CONSTR(Univ.in_punivs lt, [||]) @@ -249,6 +267,66 @@ module VNativeEntries = let (_eq,_lt,gt) = get_cmp_constructors env in CONSTR(Univ.in_punivs gt, [||]) + let mkFLt env = + let (_eq,lt,_gt,_nc) = get_f_cmp_constructors env in + CONSTR(Univ.in_punivs lt, [||]) + + let mkFEq env = + let (eq,_lt,_gt,_nc) = get_f_cmp_constructors env in + CONSTR(Univ.in_punivs eq, [||]) + + let mkFGt env = + let (_eq,_lt,gt,_nc) = get_f_cmp_constructors env in + CONSTR(Univ.in_punivs gt, [||]) + + let mkFNotComparable env = + let (_eq,_lt,_gt,nc) = get_f_cmp_constructors env in + CONSTR(Univ.in_punivs nc, [||]) + + let mkPNormal env = + let (pNormal,_nNormal,_pSubn,_nSubn,_pZero,_nZero,_pInf,_nInf,_nan) = + get_f_class_constructors env in + CONSTR(Univ.in_punivs pNormal, [||]) + + let mkNNormal env = + let (_pNormal,nNormal,_pSubn,_nSubn,_pZero,_nZero,_pInf,_nInf,_nan) = + get_f_class_constructors env in + CONSTR(Univ.in_punivs nNormal, [||]) + + let mkPSubn env = + let (_pNormal,_nNormal,pSubn,_nSubn,_pZero,_nZero,_pInf,_nInf,_nan) = + get_f_class_constructors env in + CONSTR(Univ.in_punivs pSubn, [||]) + + let mkNSubn env = + let (_pNormal,_nNormal,_pSubn,nSubn,_pZero,_nZero,_pInf,_nInf,_nan) = + get_f_class_constructors env in + CONSTR(Univ.in_punivs nSubn, [||]) + + let mkPZero env = + let (_pNormal,_nNormal,_pSubn,_nSubn,pZero,_nZero,_pInf,_nInf,_nan) = + get_f_class_constructors env in + CONSTR(Univ.in_punivs pZero, [||]) + + let mkNZero env = + let (_pNormal,_nNormal,_pSubn,_nSubn,_pZero,nZero,_pInf,_nInf,_nan) = + get_f_class_constructors env in + CONSTR(Univ.in_punivs nZero, [||]) + + let mkPInf env = + let (_pNormal,_nNormal,_pSubn,_nSubn,_pZero,_nZero,pInf,_nInf,_nan) = + get_f_class_constructors env in + CONSTR(Univ.in_punivs pInf, [||]) + + let mkNInf env = + let (_pNormal,_nNormal,_pSubn,_nSubn,_pZero,_nZero,_pInf,nInf,_nan) = + get_f_class_constructors env in + CONSTR(Univ.in_punivs nInf, [||]) + + let mkNaN env = + let (_pNormal,_nNormal,_pSubn,_nSubn,_pZero,_nZero,_pInf,_nInf,nan) = + get_f_class_constructors env in + CONSTR(Univ.in_punivs nan, [||]) end module VredNative = RedNative(VNativeEntries) @@ -381,7 +459,7 @@ let rec norm_head info env t stack = | Construct c -> (CONSTR(c, [||]), stack) (* neutral cases *) - | (Sort _ | Meta _ | Ind _ | Int _) -> (VAL(0, t), stack) + | (Sort _ | Meta _ | Ind _ | Int _ | Float _) -> (VAL(0, t), stack) | Prod _ -> (CBN(t,env), stack) and norm_head_ref k info env stack normt t = diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index e85c888b2e..d1cc21d82f 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -406,9 +406,10 @@ let matches_core env sigma allow_bound_rels | PEvar (c1,args1), Evar (c2,args2) when Evar.equal c1 c2 -> Array.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 | (PRef _ | PVar _ | PRel _ | PApp _ | PProj _ | PLambda _ | PProd _ | PLetIn _ | PSort _ | PIf _ | PCase _ - | PFix _ | PCoFix _| PEvar _ | PInt _), _ -> raise PatternMatchingFailure + | PFix _ | PCoFix _| PEvar _ | PInt _ | PFloat _), _ -> raise PatternMatchingFailure in sorec [] env ((Id.Map.empty,Id.Set.empty), Id.Map.empty) pat c @@ -526,7 +527,7 @@ let sub_match ?(closed=true) env sigma pat c = aux env term mk_ctx next with Retyping.RetypeError _ -> next () end - | Construct _| Ind _|Evar _|Const _ | Rel _|Meta _|Var _|Sort _ | Int _ -> + | Construct _|Ind _|Evar _|Const _|Rel _|Meta _|Var _|Sort _|Int _|Float _ -> next () in here next diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index e8c83c7de9..5dd4772bcc 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -834,6 +834,7 @@ and detype_r d flags avoid env sigma t = | 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 and detype_eqns d flags avoid env sigma ci computable constructs consnargsl bl = try @@ -1027,6 +1028,7 @@ let rec subst_glob_constr env subst = DAst.map (function | GVar _ | GEvar _ | GInt _ + | GFloat _ | GPatVar _ as raw -> raw | GApp (r,rl) as raw -> diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 288a349b8b..73d0c6f821 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -138,7 +138,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 _ -> Rigid + | Lambda _ | Prod _ | Sort _ | Ind _ | Construct _ | CoFix _ | Int _ | Float _ -> Rigid | Meta _ -> Rigid | Fix _ -> Rigid (* happens when the fixpoint is partially applied *) | Cast _ | App _ | Case _ -> assert false @@ -220,7 +220,7 @@ let occur_rigidly flags env evd (evk,_) t = (match aux c with | Rigid b -> Rigid b | _ -> Reducible) - | Meta _ | Fix _ | CoFix _ | Int _ -> Reducible + | Meta _ | Fix _ | CoFix _ | Int _ | Float _ -> Reducible in match aux t with | Rigid b -> b @@ -899,7 +899,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 _) -> + | (Var _|Construct _|Ind _|Const _|Prod _|Sort _|Int _ |Float _) -> 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 | Const _, Const _ | Ind _, Ind _ | Construct _, Construct _ - | Int _, Int _ -> + | Int _, Int _ + | Float _, Float _ -> rigids env evd sk1 term1 sk2 term2 | Evar (sp1,al1), Evar (sp2,al2) -> (* Frozen evars *) @@ -1064,7 +1065,7 @@ 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 _ | Evar _ | Lambda _), _ -> + | (Ind _ | Sort _ | Prod _ | CoFix _ | Fix _ | Rel _ | Var _ | Const _ | Int _ | Float _ | Evar _ | Lambda _), _ -> UnifFailure (evd,NotSameHead) | _, (Ind _ | Sort _ | Prod _ | CoFix _ | Fix _ | Rel _ | Var _ | Const _ | Int _ | Evar _ | Lambda _) -> UnifFailure (evd,NotSameHead) diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml index 93f5923474..03bb633fa0 100644 --- a/pretyping/glob_ops.ml +++ b/pretyping/glob_ops.ml @@ -156,9 +156,10 @@ let mk_glob_constr_eq f c1 c2 = match DAst.get c1, DAst.get c2 with | GCast (c1, t1), GCast (c2, t2) -> 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 | (GRef _ | GVar _ | GEvar _ | GPatVar _ | GApp _ | GLambda _ | GProd _ | GLetIn _ | GCases _ | GLetTuple _ | GIf _ | GRec _ | GSort _ | GHole _ | GCast _ | - GInt _), _ -> false + GInt _ | GFloat _), _ -> false let rec glob_constr_eq c = mk_glob_constr_eq glob_constr_eq c @@ -219,7 +220,7 @@ 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) - | (GVar _ | GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _ | GInt _) as x -> x + | (GVar _ | GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _ | GInt _ | GFloat _) as x -> x ) let map_glob_constr = map_glob_constr_left_to_right @@ -251,7 +252,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 - | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _ | GInt _) -> acc + | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _ | GInt _ | GFloat _) -> acc ) let fold_return_type_with_binders f g v acc (na,tyopt) = Option.fold_left (f (Name.fold_right g na v)) acc tyopt @@ -293,7 +294,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 - | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _ | GInt _) -> acc)) + | (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 10e9d60fd5..44323441b6 100644 --- a/pretyping/glob_term.ml +++ b/pretyping/glob_term.ml @@ -91,6 +91,7 @@ type 'a glob_constr_r = | GHole of Evar_kinds.t * Namegen.intro_pattern_naming_expr * Genarg.glob_generic_argument option | GCast of 'a glob_constr_g * 'a glob_constr_g cast_type | GInt of Uint63.t + | GFloat of Float64.t 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 870df62500..7740628c21 100644 --- a/pretyping/heads.ml +++ b/pretyping/heads.ml @@ -79,7 +79,7 @@ and kind_of_head env t = | Proj (p,c) -> RigidHead RigidOther | Case (_,_,c,_) -> aux k [] c true - | Int _ -> ConstructorHead + | Int _ | Float _ -> ConstructorHead | Fix ((i,j),_) -> let n = i.(j) in try aux k [] (List.nth l n) true diff --git a/pretyping/keys.ml b/pretyping/keys.ml index f8eecd80d4..39a4a525ef 100644 --- a/pretyping/keys.ml +++ b/pretyping/keys.ml @@ -26,6 +26,7 @@ type key = | KCoFix | KRel | KInt + | KFloat module KeyOrdered = struct type t = key @@ -42,6 +43,7 @@ module KeyOrdered = struct | KCoFix -> 6 | KRel -> 7 | KInt -> 8 + | KFloat -> 9 let compare gr1 gr2 = match gr1, gr2 with @@ -135,6 +137,7 @@ let constr_key kind c = | Sort _ -> KSort | LetIn _ -> KLet | Int _ -> KInt + | Float _ -> KFloat in Some (aux c) with Not_found -> None @@ -151,6 +154,7 @@ let pr_key pr_global = function | KCoFix -> str"CoFix" | KRel -> str"Rel" | KInt -> str"Int" + | KFloat -> str"Float" 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 e5aed300a2..0178d5c009 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -208,6 +208,7 @@ let rec nf_val env sigma v typ = mkLambda(name,dom,body) | Vconst n -> construct_of_constr_const env sigma n typ | Vint64 i -> i |> Uint63.of_int64 |> mkInt + | Vfloat64 f -> f |> Float64.of_float |> mkFloat | 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 diff --git a/pretyping/pattern.ml b/pretyping/pattern.ml index e0beb383b5..2d7a152817 100644 --- a/pretyping/pattern.ml +++ b/pretyping/pattern.ml @@ -40,6 +40,7 @@ type constr_pattern = | PFix of (int array * int) * (Name.t array * constr_pattern array * constr_pattern array) | PCoFix of int * (Name.t array * constr_pattern array * constr_pattern array) | PInt of Uint63.t + | PFloat of Float64.t (** 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 ccc3b6e83c..0c4312dc77 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -62,9 +62,12 @@ let rec constr_pattern_eq p1 p2 = match p1, p2 with Projection.equal p1 p2 && constr_pattern_eq t1 t2 | PInt i1, PInt i2 -> Uint63.equal i1 i2 +| PFloat f1, PFloat f2 -> + Float64.equal f1 f2 | (PRef _ | PVar _ | PEvar _ | PRel _ | PApp _ | PSoApp _ | PLambda _ | PProd _ | PLetIn _ | PSort _ | PMeta _ - | PIf _ | PCase _ | PFix _ | PCoFix _ | PProj _ | PInt _), _ -> false + | PIf _ | PCase _ | PFix _ | PCoFix _ | PProj _ | PInt _ + | PFloat _), _ -> false (** FIXME: fixpoint and cofixpoint should be relativized to pattern *) and pattern_eq (i1, j1, p1) (i2, j2, p2) = @@ -92,7 +95,7 @@ let rec occur_meta_pattern = function (List.exists (fun (_,_,p) -> occur_meta_pattern p) br) | PMeta _ | PSoApp _ -> true | PEvar _ | PVar _ | PRef _ | PRel _ | PSort _ | PFix _ | PCoFix _ - | PInt _ -> false + | PInt _ | PFloat _ -> false let rec occurn_pattern n = function | PRel p -> Int.equal n p @@ -113,7 +116,7 @@ let rec occurn_pattern n = function (List.exists (fun (_,_,p) -> occurn_pattern n p) br) | PMeta _ | PSoApp _ -> true | PEvar (_,args) -> Array.exists (occurn_pattern n) args - | PVar _ | PRef _ | PSort _ | PInt _ -> false + | PVar _ | PRef _ | PSort _ | PInt _ | PFloat _ -> false | PFix (_,(_,tl,bl)) -> Array.exists (occurn_pattern n) tl || Array.exists (occurn_pattern (n+Array.length tl)) bl | PCoFix (_,(_,tl,bl)) -> @@ -136,7 +139,7 @@ let rec head_pattern_bound t = -> raise BoundPattern (* Perhaps they were arguments, but we don't beta-reduce *) | PLambda _ -> raise BoundPattern - | PCoFix _ | PInt _ -> anomaly ~label:"head_pattern_bound" (Pp.str "not a type.") + | PCoFix _ | PInt _ | PFloat _ -> 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 @@ -213,7 +216,8 @@ let pattern_of_constr env sigma t = let env' = Array.fold_left2 push env lna tl in 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 in + | Int i -> PInt i + | Float f -> PFloat f in pattern_of_constr env t (* To process patterns, we need a translation without typing at all. *) @@ -235,7 +239,8 @@ let map_pattern_with_binders g f l = function 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)) (* Non recursive *) - | (PVar _ | PEvar _ | PRel _ | PRef _ | PSort _ | PMeta _ | PInt _ as x) -> x + | (PVar _ | PEvar _ | PRel _ | PRef _ | PSort _ | PMeta _ | PInt _ + | PFloat _ as x) -> x let error_instantiate_pattern id l = let is = match l with @@ -290,7 +295,8 @@ let rec subst_pattern env sigma subst pat = | PVar _ | PEvar _ | PRel _ - | PInt _ -> pat + | PInt _ + | PFloat _ -> pat | PProj (p,c) -> let p' = Projection.map (subst_mind subst) p in let c' = subst_pattern env sigma subst c in @@ -495,6 +501,7 @@ let rec pat_of_raw metas vars = DAst.with_loc_val (fun ?loc -> function PCoFix (n, (names, tl, cl)) | GInt i -> PInt i + | GFloat f -> PFloat f | GPatVar _ | GIf _ | GLetTuple _ | GCases _ | GEvar _ -> err ?loc (Pp.str "Non supported pattern.")) diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 4fed526cfc..2e1cb9ff08 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -1026,6 +1026,13 @@ let rec pretype ~program_mode ~poly resolve_tc (tycon : type_constraint) (env : user_err ?loc ~hdr:"pretype" (str "Type of int63 should be registered first.") in inh_conv_coerce_to_tycon ?loc env sigma resj tycon + | GFloat f -> + 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 + inh_conv_coerce_to_tycon ?loc env sigma resj tycon and pretype_instance ~program_mode ~poly resolve_tc env sigma loc hyps evk update = let f decl (subst,update,sigma) = diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index df161b747a..2952466fbb 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -848,9 +848,17 @@ struct | Int i -> i | _ -> raise Primred.NativeDestKO + let get_float evd e = + match EConstr.kind evd e with + | Float f -> f + | _ -> raise Primred.NativeDestKO + let mkInt env i = mkInt i + let mkFloat env f = + mkFloat f + let mkBool env b = let (ct,cf) = get_bool_constructors env in mkConstruct (if b then ct else cf) @@ -865,6 +873,12 @@ struct let c = get_pair_constructor env in mkApp(mkConstruct c, [|int_ty;int_ty;e1;e2|]) + let mkFloatIntPair env f i = + let float_ty = mkConst @@ get_float_type env in + let int_ty = mkConst @@ get_int_type env in + let c = get_pair_constructor env in + mkApp(mkConstruct c, [|float_ty;int_ty;f;i|]) + let mkLt env = let (_eq, lt, _gt) = get_cmp_constructors env in mkConstruct lt @@ -877,6 +891,66 @@ struct let (_eq, _lt, gt) = get_cmp_constructors env in mkConstruct gt + let mkFLt env = + let (_eq, lt, _gt, _nc) = get_f_cmp_constructors env in + mkConstruct lt + + let mkFEq env = + let (eq, _lt, _gt, _nc) = get_f_cmp_constructors env in + mkConstruct eq + + let mkFGt env = + let (_eq, _lt, gt, _nc) = get_f_cmp_constructors env in + mkConstruct gt + + let mkFNotComparable env = + let (_eq, _lt, _gt, nc) = get_f_cmp_constructors env in + mkConstruct nc + + let mkPNormal env = + let (pNormal,_nNormal,_pSubn,_nSubn,_pZero,_nZero,_pInf,_nInf,_nan) = + get_f_class_constructors env in + mkConstruct pNormal + + let mkNNormal env = + let (_pNormal,nNormal,_pSubn,_nSubn,_pZero,_nZero,_pInf,_nInf,_nan) = + get_f_class_constructors env in + mkConstruct nNormal + + let mkPSubn env = + let (_pNormal,_nNormal,pSubn,_nSubn,_pZero,_nZero,_pInf,_nInf,_nan) = + get_f_class_constructors env in + mkConstruct pSubn + + let mkNSubn env = + let (_pNormal,_nNormal,_pSubn,nSubn,_pZero,_nZero,_pInf,_nInf,_nan) = + get_f_class_constructors env in + mkConstruct nSubn + + let mkPZero env = + let (_pNormal,_nNormal,_pSubn,_nSubn,pZero,_nZero,_pInf,_nInf,_nan) = + get_f_class_constructors env in + mkConstruct pZero + + let mkNZero env = + let (_pNormal,_nNormal,_pSubn,_nSubn,_pZero,nZero,_pInf,_nInf,_nan) = + get_f_class_constructors env in + mkConstruct nZero + + let mkPInf env = + let (_pNormal,_nNormal,_pSubn,_nSubn,_pZero,_nZero,pInf,_nInf,_nan) = + get_f_class_constructors env in + mkConstruct pInf + + let mkNInf env = + let (_pNormal,_nNormal,_pSubn,_nSubn,_pZero,_nZero,_pInf,nInf,_nan) = + get_f_class_constructors env in + mkConstruct nInf + + let mkNaN env = + let (_pNormal,_nNormal,_pSubn,_nSubn,_pZero,_nZero,_pInf,_nInf,nan) = + get_f_class_constructors env in + mkConstruct nan end module CredNative = RedNative(CNativeEntries) @@ -1135,7 +1209,7 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = |_ -> fold () else fold () - | Int i -> + | Int _ | Float _ -> begin match Stack.strip_app stack with | (_, Stack.Primitive(p,kn,rargs,kargs,cst_l')::s) -> let more_to_reduce = List.exists (fun k -> CPrimitives.Kwhnf = k) kargs in @@ -1238,7 +1312,7 @@ let local_whd_state_gen flags sigma = else s | Rel _ | Var _ | Sort _ | Prod _ | LetIn _ | Const _ | Ind _ | Proj _ - | Int _ -> s + | Int _ | Float _ -> s in whrec diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index cc341afac3..966c8f6e12 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -146,6 +146,7 @@ let retype ?(polyprop=true) sigma = | Cast (c,_, t) -> t | 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) and sort_of env t = match EConstr.kind sigma t with @@ -281,7 +282,7 @@ let relevance_of_term env sigma c = | Fix ((_,i),(lna,_,_)) -> (lna.(i)).binder_relevance | CoFix (i,(lna,_,_)) -> (lna.(i)).binder_relevance | Proj (p, _) -> Retypeops.relevance_of_projection env p - | Int _ -> Sorts.Relevant + | Int _ | Float _ -> Sorts.Relevant | Meta _ | Evar _ -> Sorts.Relevant diff --git a/pretyping/typing.ml b/pretyping/typing.ml index 2db5512ff4..1a145fe1b2 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -319,6 +319,9 @@ let type_of_constructor env sigma ((ind,_ as ctor),u) = let judge_of_int env v = Environ.on_judgment EConstr.of_constr (judge_of_int env v) +let judge_of_float env v = + Environ.on_judgment EConstr.of_constr (judge_of_float env v) + (* 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 = @@ -430,6 +433,9 @@ let rec execute env sigma cstr = | Int i -> sigma, judge_of_int env i + | Float f -> + sigma, judge_of_float env f + 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/typing.mli b/pretyping/typing.mli index 63fb0679f1..1b07b2bb78 100644 --- a/pretyping/typing.mli +++ b/pretyping/typing.mli @@ -57,3 +57,4 @@ val judge_of_product : Environ.env -> Name.t -> unsafe_type_judgment -> unsafe_type_judgment -> unsafe_judgment val judge_of_projection : env -> evar_map -> Projection.t -> unsafe_judgment -> unsafe_judgment val judge_of_int : Environ.env -> Uint63.t -> unsafe_judgment +val judge_of_float : Environ.env -> Float64.t -> unsafe_judgment diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 4d34139ec0..7147580b3d 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -566,7 +566,7 @@ 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 _ -> true + | Construct _ | Int _ | Float _ -> true | Fix _ | CoFix _ -> true | Rel _ | Var _ | Meta _ | Evar _ | Sort _ | Cast (_, _, _) | Prod _ | Lambda _ | LetIn _ | App (_, _) | Case (_, _, _, _) @@ -661,7 +661,7 @@ let rec is_neutral env sigma ts t = | Evar _ | Meta _ -> true | Case (_, p, c, cl) -> is_neutral env sigma ts c | Proj (p, c) -> is_neutral env sigma ts c - | Lambda _ | LetIn _ | Construct _ | CoFix _ | Int _ -> false + | Lambda _ | LetIn _ | Construct _ | CoFix _ | Int _ | Float _ -> false | Sort _ | Cast (_, _, _) | Prod (_, _, _) | Ind _ -> false (* Really? *) | Fix _ -> false (* This is an approximation *) | App _ -> assert false @@ -1821,7 +1821,7 @@ let w_unify_to_subterm env evd ?(flags=default_unify_flags ()) (op,cl) = | Cast (_, _, _) (* Is this expected? *) | Rel _ | Var _ | Meta _ | Evar _ | Sort _ | Const _ | Ind _ - | Construct _ | Int _ -> user_err Pp.(str "Match_subterm"))) + | Construct _ | Int _ | Float _ -> user_err Pp.(str "Match_subterm"))) in try matchrec cl with ex when precatchable_exception ex -> @@ -1890,7 +1890,7 @@ let w_unify_to_subterm_all env evd ?(flags=default_unify_flags ()) (op,cl) = | Cast (_, _, _) -> fail "Match_subterm" (* Is this expected? *) | Rel _ | Var _ | Meta _ | Evar _ | Sort _ | Const _ | Ind _ - | Construct _ | Int _ -> fail "Match_subterm")) + | Construct _ | Int _ | Float _ -> fail "Match_subterm")) in let res = matchrec cl [] in diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index da0a92f284..d15eb578c3 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -169,6 +169,7 @@ and nf_whd env sigma whd typ = let args = nf_bargs env sigma b ofs ctyp in mkApp(capp,args) | Vint64 i -> i |> Uint63.of_int64 |> mkInt + | Vfloat64 f -> f |> Float64.of_float |> mkFloat | Vatom_stk(Aid idkey, stk) -> constr_type_of_idkey env sigma idkey stk | Vatom_stk(Aind ((mi,i) as ind), stk) -> diff --git a/printing/printing.mllib b/printing/printing.mllib index deb52ad270..5b5b6590a4 100644 --- a/printing/printing.mllib +++ b/printing/printing.mllib @@ -4,4 +4,3 @@ Ppconstr Proof_diffs Printer Printmod -Prettyp diff --git a/stm/stm.ml b/stm/stm.ml index 5c6df26cbb..2b68e1778d 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -2801,13 +2801,21 @@ let handle_failure (e, info) vcs = VCS.print (); Exninfo.iraise (e, info) -let snapshot_vio ~doc ~output_native_objects ldir long_f_dot_vo = +let snapshot_vio ~create_vos ~doc ~output_native_objects ldir long_f_dot_vo = let doc = finish ~doc in if List.length (VCS.branches ()) > 1 then CErrors.user_err ~hdr:"stm" (str"Cannot dump a vio with open proofs"); - Library.save_library_to ~todo:(dump_snapshot ()) ~output_native_objects - ldir long_f_dot_vo - (Global.opaque_tables ()); + (* LATER: when create_vos is true, it could be more efficient to not allocate the futures; but for now it seems useful for synchronization of the workers, + below, [snapshot] gets computed even if [create_vos] is true. *) + let (tasks,counters) = dump_snapshot() in + let except = List.fold_left (fun e (r,_) -> + Future.UUIDSet.add r.Stateid.uuid e) Future.UUIDSet.empty tasks in + let todo_proofs = + if create_vos + then Library.ProofsTodoSomeEmpty except + else Library.ProofsTodoSome (except,tasks,counters) + in + Library.save_library_to todo_proofs ~output_native_objects ldir long_f_dot_vo (Global.opaque_tables ()); doc let reset_task_queue = Slaves.reset_task_queue @@ -2884,7 +2892,7 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) | VtStartProof (guarantee, names) -> if not (get_allow_nested_proofs ()) && VCS.proof_nesting () > 0 then - "Nested proofs are not allowed unless you turn option Nested Proofs Allowed on." + "Nested proofs are not allowed unless you turn the Nested Proofs Allowed flag on." |> Pp.str |> (fun s -> (UserError (None, s), Exninfo.null)) |> State.exn_on ~valid:Stateid.dummy newtip diff --git a/stm/stm.mli b/stm/stm.mli index 29e4b02e3f..841adcf05b 100644 --- a/stm/stm.mli +++ b/stm/stm.mli @@ -159,8 +159,10 @@ val join : doc:doc -> doc - if the worker pool is empty, all tasks are saved - if the worker proof is not empty, then it waits until all workers are done with their current jobs and then dumps (or fails if one - of the completed tasks is a failure) *) -val snapshot_vio : doc:doc -> output_native_objects:bool -> DirPath.t -> string -> doc + of the completed tasks is a failure). + Note: the create_vos argument is used in the "-vos" mode, where the + proof tasks are not dumped into the output file. *) +val snapshot_vio : create_vos:bool -> doc:doc -> output_native_objects:bool -> DirPath.t -> string -> doc (* Empties the task queue, can be used only if the worker pool is empty (E.g. * after having built a .vio in batch mode *) diff --git a/tactics/term_dnet.ml b/tactics/term_dnet.ml index ccd7a818b9..58db147b10 100644 --- a/tactics/term_dnet.ml +++ b/tactics/term_dnet.ml @@ -45,6 +45,7 @@ struct | DFix of int array * int * 't array * 't array | DCoFix of int * 't array * 't array | DInt of Uint63.t + | DFloat of Float64.t (* special constructors only inside the left-hand side of DCtx or DApp. Used to encode lists of foralls/letins/apps as contexts *) @@ -63,6 +64,7 @@ struct | DFix _ -> str "fix" | DCoFix _ -> str "cofix" | DInt _ -> str "INT" + | DFloat _ -> str "FLOAT" | DCons ((t,dopt),tl) -> f t ++ (match dopt with Some t' -> str ":=" ++ f t' | None -> str "") ++ spc() ++ str "::" ++ spc() ++ f tl @@ -74,7 +76,7 @@ struct *) let map f = function - | (DRel | DSort | DNil | DRef _ | DInt _) as c -> c + | (DRel | DSort | DNil | DRef _ | DInt _ | DFloat _) as c -> c | DCtx (ctx,c) -> DCtx (f ctx, f c) | DLambda (t,c) -> DLambda (f t, f c) | DApp (t,u) -> DApp (f t,f u) @@ -151,6 +153,10 @@ struct | DInt _, _ -> -1 | _, DInt _ -> 1 + | DFloat f1, DFloat f2 -> Float64.total_compare f1 f2 + + | DFloat _, _ -> -1 | _, DFloat _ -> 1 + | DCons ((t1, ot1), u1), DCons ((t2, ot2), u2) -> let c = cmp t1 t2 in if Int.equal c 0 then @@ -163,7 +169,7 @@ struct | DNil, DNil -> 0 let fold f acc = function - | (DRel | DNil | DSort | DRef _ | DInt _) -> acc + | (DRel | DNil | DSort | DRef _ | DInt _ | DFloat _) -> acc | DCtx (ctx,c) -> f (f acc ctx) c | DLambda (t,c) -> f (f acc t) c | DApp (t,u) -> f (f acc t) u @@ -175,7 +181,7 @@ struct | DCons ((t,topt),u) -> f (Option.fold_left f (f acc t) topt) u let choose f = function - | (DRel | DSort | DNil | DRef _ | DInt _) -> invalid_arg "choose" + | (DRel | DSort | DNil | DRef _ | DInt _ | DFloat _) -> invalid_arg "choose" | DCtx (ctx,c) -> f ctx | DLambda (t,c) -> f t | DApp (t,u) -> f u @@ -192,7 +198,7 @@ struct then invalid_arg "fold2:compare" else match c1,c2 with | (DRel, DRel | DNil, DNil | DSort, DSort | DRef _, DRef _ - | DInt _, DInt _) -> acc + | DInt _, DInt _ | DFloat _, DFloat _) -> acc | (DCtx (c1,t1), DCtx (c2,t2) | DApp (c1,t1), DApp (c2,t2) | DLambda (c1,t1), DLambda (c2,t2)) -> f (f acc c1 c2) t1 t2 @@ -205,7 +211,7 @@ struct | 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 _), _ -> assert false + | DFix _ | DCoFix _ | DCons _ | DInt _ | DFloat _), _ -> assert false let map2 (f:'a -> 'b -> 'c) (c1:'a t) (c2:'b t) : 'c t = let head w = map (fun _ -> ()) w in @@ -213,7 +219,7 @@ struct then invalid_arg "map2_t:compare" else match c1,c2 with | (DRel, DRel | DSort, DSort | DNil, DNil | DRef _, DRef _ - | DInt _, DInt _) as cc -> + | DInt _, DInt _ | DFloat _, DFloat _) as cc -> let (c,_) = cc in c | DCtx (c1,t1), DCtx (c2,t2) -> DCtx (f c1 c2, f t1 t2) | DLambda (t1,c1), DLambda (t2,c2) -> DLambda (f t1 t2, f c1 c2) @@ -227,10 +233,10 @@ struct | 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 _), _ -> assert false + | DFix _ | DCoFix _ | DCons _ | DInt _ | DFloat _), _ -> assert false let terminal = function - | (DRel | DSort | DNil | DRef _ | DInt _) -> true + | (DRel | DSort | DNil | DRef _ | DInt _ | DFloat _) -> true | DLambda _ | DApp _ | DCase _ | DFix _ | DCoFix _ | DCtx _ | DCons _ -> false @@ -325,6 +331,7 @@ struct | Proj (p,c) -> Term (DApp (Term (DRef (ConstRef (Projection.constant p))), pat_of_constr c)) | Int i -> Term (DInt i) + | Float f -> Term (DFloat f) 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 c60f39231e..1744138d29 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -102,7 +102,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 arithmetic ltac2 + coqdoc ssr primitive/uint63 primitive/float ltac2 # All subsystems SUBSYSTEMS := $(VSUBSYSTEMS) misc bugs ide vio coqchk coqwc coq-makefile tools $(UNIT_TESTS) @@ -131,9 +131,10 @@ bugs: $(BUGS) clean: rm -f trace .nia.cache .lia.cache output/MExtraction.out + rm -f vos/Makefile vos/Makefile.conf $(SHOW) 'RM <**/*.stamp> <**/*.vo> <**/*.vio> <**/*.log> <**/*.glob>' $(HIDE)find . \( \ - -name '*.stamp' -o -name '*.vo' -o -name '*.vio' -o -name '*.log' -o -name '*.glob' \ + -name '*.stamp' -o -name '*.vo' -o -name '*.vio' -o -name '*.vos' -o -name '*.vok' -o -name '*.log' -o -name '*.glob' \ \) -exec rm -f {} + $(SHOW) 'RM <**/*.cmx> <**/*.cmi> <**/*.o> <**/*.test>' $(HIDE)find unit-tests \( \ @@ -174,6 +175,7 @@ summary: $(call summary_dir, "Miscellaneous tests", misc); \ $(call summary_dir, "Complexity tests", complexity); \ $(call summary_dir, "Module tests", modules); \ + $(call summary_dir, "Primitive tests", primitive); \ $(call summary_dir, "STM tests", stm); \ $(call summary_dir, "SSR tests", ssr); \ $(call summary_dir, "IDE tests", ide); \ @@ -329,7 +331,7 @@ $(addsuffix .log,$(wildcard prerequisite/*.v)): %.v.log: %.v } > "$@" ssr: $(wildcard ssr/*.v:%.v=%.v.log) -$(addsuffix .log,$(wildcard ssr/*.v success/*.v micromega/*.v modules/*.v arithmetic/*.v ltac2/*.v)): %.v.log: %.v $(PREREQUISITELOG) +$(addsuffix .log,$(wildcard ssr/*.v success/*.v micromega/*.v modules/*.v primitive/*/*.v ltac2/*.v)): %.v.log: %.v $(PREREQUISITELOG) @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ opts="$(if $(findstring modules/,$<),-R modules Mods)"; \ @@ -748,3 +750,23 @@ tools/%.log : tools/%/run.sh $(FAIL); \ fi; \ ) > "$@" + +# vos/ + +vos: vos/run.log + +vos/run.log: $(wildcard vos/*.sh) $(wildcard vos/*.v) + @echo "TEST vos" + $(HIDE)(\ + export COQBIN=$(BIN);\ + cd vos && \ + bash run.sh 2>&1; \ + if [ $$? = 0 ]; then \ + echo $(log_success); \ + echo " $<...Ok"; \ + else \ + echo $(log_failure); \ + echo " $<...Error!"; \ + $(FAIL); \ + fi; \ + ) > "$@" diff --git a/test-suite/bugs/closed/bug_10097.v b/test-suite/bugs/closed/bug_10097.v new file mode 100644 index 0000000000..12f2d4cc58 --- /dev/null +++ b/test-suite/bugs/closed/bug_10097.v @@ -0,0 +1,14 @@ +From Ltac2 Require Import Ltac2. + +(* #10097 *) +Ltac2 Type s := [X(int)]. +Fail Ltac2 Type s. +Fail Ltac2 Type s := []. + +Ltac2 Type r := [..]. +Fail Ltac2 Type r := []. + +Module Other. + Ltac2 Type s. + Ltac2 Type r := []. +End Other. diff --git a/test-suite/bugs/closed/bug_10116.v b/test-suite/bugs/closed/bug_10116.v new file mode 100644 index 0000000000..58caa59786 --- /dev/null +++ b/test-suite/bugs/closed/bug_10116.v @@ -0,0 +1,3 @@ +From Ltac2 Require Import Ltac2. + +Ltac2 Eval true :: [], false. diff --git a/test-suite/bugs/closed/bug_10196.v b/test-suite/bugs/closed/bug_10196.v new file mode 100644 index 0000000000..d003ab323d --- /dev/null +++ b/test-suite/bugs/closed/bug_10196.v @@ -0,0 +1,26 @@ +From Ltac2 Require Import Ltac2. + +(* true and false are valid constructors even though they are lowercase *) +Ltac2 Eval true. +Ltac2 Eval false. + +(* Otherwise constructors have to be Uppercase *) +Ltac2 Type good_constructor := [Uppercased]. +Ltac2 Type good_constructors := [Uppercased1 | Uppercased2]. + +Ltac2 Eval Uppercased2. + +Fail Ltac2 Type bad_constructor := [ notUppercased ]. +Fail Ltac2 Type bad_constructors := [ | notUppercased1 | notUppercased2 ]. + +Fail Ltac2 Eval notUppercased2. + +(* And the same for open types*) +Ltac2 Type open_type := [ .. ]. +Fail Ltac2 Type open_type ::= [ notUppercased3 ]. +Ltac2 Type open_type ::= [ Uppercased3 ]. + +Fail Ltac2 Eval notUppercased3. +Ltac2 Eval Uppercased3. + +Fail Ltac2 Type foo ::= [ | bar1 | bar2 ]. diff --git a/test-suite/bugs/closed/bug_11046.v b/test-suite/bugs/closed/bug_11046.v new file mode 100644 index 0000000000..528cc4c8ff --- /dev/null +++ b/test-suite/bugs/closed/bug_11046.v @@ -0,0 +1,19 @@ +From Ltac2 Require Import Ltac2. + +Ltac2 Type t := [..]. +Ltac2 Type t ::= [A(int)]. + +(* t cannot be extended with two constructors with the same name *) +Fail Ltac2 Type t ::= [A(bool)]. +Fail Ltac2 Type t ::= [B | B(bool)]. + +(* constructors cannot be shadowed in the same module *) +Fail Ltac2 Type s := [A]. + +(* constructors with the same name can be defined in distinct modules *) +Module Other. + Ltac2 Type t ::= [A(bool)]. +End Other. +Module YetAnother. + Ltac2 Type t := [A]. +End YetAnother. diff --git a/test-suite/bugs/closed/bug_4502.v b/test-suite/bugs/closed/bug_4502.v new file mode 100644 index 0000000000..f1dcae9773 --- /dev/null +++ b/test-suite/bugs/closed/bug_4502.v @@ -0,0 +1,17 @@ +Require Import FunInd. + +Set Universe Polymorphism. +Set Primitive Projections. +Set Implicit Arguments. +Set Strongly Strict Implicit. + +Function first_false (n : nat) (f : nat -> bool) : option nat := + match n with + | O => None + | S m => + match first_false m f with + | (Some _) as s => s + | None => if f m then None else Some m + end + end. +(* undefined universe *) diff --git a/test-suite/coq-makefile/coqdoc1/run.sh b/test-suite/coq-makefile/coqdoc1/run.sh index 88237815b1..0d9b9ea867 100755 --- a/test-suite/coq-makefile/coqdoc1/run.sh +++ b/test-suite/coq-makefile/coqdoc1/run.sh @@ -28,10 +28,12 @@ sort -u > desired <<EOT ./test/test.glob ./test/test.v ./test/test.vo +./test/test.vos ./test/sub ./test/sub/testsub.glob ./test/sub/testsub.v ./test/sub/testsub.vo +./test/sub/testsub.vos ./test/mlihtml ./test/mlihtml/index_exceptions.html ./test/mlihtml/index.html diff --git a/test-suite/coq-makefile/coqdoc2/run.sh b/test-suite/coq-makefile/coqdoc2/run.sh index 5811dd17e4..852ac372f4 100755 --- a/test-suite/coq-makefile/coqdoc2/run.sh +++ b/test-suite/coq-makefile/coqdoc2/run.sh @@ -26,10 +26,12 @@ sort -u > desired <<EOT ./test/test.glob ./test/test.v ./test/test.vo +./test/test.vos ./test/sub ./test/sub/testsub.glob ./test/sub/testsub.v ./test/sub/testsub.vo +./test/sub/testsub.vos ./test/mlihtml ./test/mlihtml/index_exceptions.html ./test/mlihtml/index.html diff --git a/test-suite/coq-makefile/mlpack1/run.sh b/test-suite/coq-makefile/mlpack1/run.sh index bbd2fc460c..1303aa90b6 100755 --- a/test-suite/coq-makefile/mlpack1/run.sh +++ b/test-suite/coq-makefile/mlpack1/run.sh @@ -19,5 +19,6 @@ sort > desired <<EOT ./test/test_plugin.cmxs ./test/test.v ./test/test.vo +./test/test.vos EOT exec diff -u desired actual diff --git a/test-suite/coq-makefile/mlpack2/run.sh b/test-suite/coq-makefile/mlpack2/run.sh index bbd2fc460c..1303aa90b6 100755 --- a/test-suite/coq-makefile/mlpack2/run.sh +++ b/test-suite/coq-makefile/mlpack2/run.sh @@ -19,5 +19,6 @@ sort > desired <<EOT ./test/test_plugin.cmxs ./test/test.v ./test/test.vo +./test/test.vos EOT exec diff -u desired actual diff --git a/test-suite/coq-makefile/multiroot/run.sh b/test-suite/coq-makefile/multiroot/run.sh index 45bf1481df..3a5425c8bf 100755 --- a/test-suite/coq-makefile/multiroot/run.sh +++ b/test-suite/coq-makefile/multiroot/run.sh @@ -29,10 +29,12 @@ sort > desired <<EOT ./test/test_plugin.cmxs ./test/test.v ./test/test.vo +./test/test.vos ./test2 ./test2/test.glob ./test2/test.v ./test2/test.vo +./test2/test.vos ./orphan_test_test2_test ./orphan_test_test2_test/html ./orphan_test_test2_test/html/coqdoc.css diff --git a/test-suite/coq-makefile/native1/run.sh b/test-suite/coq-makefile/native1/run.sh index 8f9ab9a711..588de82613 100755 --- a/test-suite/coq-makefile/native1/run.sh +++ b/test-suite/coq-makefile/native1/run.sh @@ -22,6 +22,7 @@ sort > desired <<EOT ./test/test_plugin.cmxs ./test/test.v ./test/test.vo +./test/test.vos ./test/.coq-native ./test/.coq-native/Ntest_test.cmi ./test/.coq-native/Ntest_test.cmx diff --git a/test-suite/coq-makefile/plugin1/run.sh b/test-suite/coq-makefile/plugin1/run.sh index 1e2bd979b3..cd47187582 100755 --- a/test-suite/coq-makefile/plugin1/run.sh +++ b/test-suite/coq-makefile/plugin1/run.sh @@ -22,5 +22,6 @@ sort > desired <<EOT ./test/test_plugin.cmxs ./test/test.v ./test/test.vo +./test/test.vos EOT exec diff -u desired actual diff --git a/test-suite/coq-makefile/plugin2/run.sh b/test-suite/coq-makefile/plugin2/run.sh index 1e2bd979b3..cd47187582 100755 --- a/test-suite/coq-makefile/plugin2/run.sh +++ b/test-suite/coq-makefile/plugin2/run.sh @@ -22,5 +22,6 @@ sort > desired <<EOT ./test/test_plugin.cmxs ./test/test.v ./test/test.vo +./test/test.vos EOT exec diff -u desired actual diff --git a/test-suite/coq-makefile/plugin3/run.sh b/test-suite/coq-makefile/plugin3/run.sh index 1e2bd979b3..cd47187582 100755 --- a/test-suite/coq-makefile/plugin3/run.sh +++ b/test-suite/coq-makefile/plugin3/run.sh @@ -22,5 +22,6 @@ sort > desired <<EOT ./test/test_plugin.cmxs ./test/test.v ./test/test.vo +./test/test.vos EOT exec diff -u desired actual diff --git a/test-suite/ltac2/term_notations.v b/test-suite/ltac2/term_notations.v new file mode 100644 index 0000000000..85eb858d4e --- /dev/null +++ b/test-suite/ltac2/term_notations.v @@ -0,0 +1,33 @@ +Require Import Ltac2.Ltac2. + +(* Preterms are not terms *) +Fail Notation "[ x ]" := $x. + +Section Foo. + +Notation "[ x ]" := ltac2:(Control.refine (fun _ => Constr.pretype x)). + +Goal [ True ]. +Proof. +constructor. +Qed. + +End Foo. + +Section Bar. + +(* Have fun with context capture *) +Notation "[ x ]" := ltac2:( + let c () := Constr.pretype x in + refine constr:(forall n : nat, n = ltac2:(Notations.exact0 true c)) +). + +Goal forall n : nat, [ n ]. +Proof. +reflexivity. +Qed. + +(* This fails currently, which is arguably a bug *) +Fail Goal [ n ]. + +End Bar. diff --git a/test-suite/misc/deps/deps.out b/test-suite/misc/deps/deps.out index 5b79349fc2..d0263b8935 100644 --- a/test-suite/misc/deps/deps.out +++ b/test-suite/misc/deps/deps.out @@ -1 +1 @@ -misc/deps/client/bar.vo misc/deps/client/bar.glob misc/deps/client/bar.v.beautified: misc/deps/client/bar.v misc/deps/client/foo.vo misc/deps/lib/foo.vo +misc/deps/client/bar.vo misc/deps/client/bar.glob misc/deps/client/bar.v.beautified misc/deps/client/bar.required_vo: misc/deps/client/bar.v misc/deps/client/foo.vo misc/deps/lib/foo.vo diff --git a/test-suite/output/Arguments.out b/test-suite/output/Arguments.out index 3c1e27ba9d..6704337f80 100644 --- a/test-suite/output/Arguments.out +++ b/test-suite/output/Arguments.out @@ -1,14 +1,14 @@ Nat.sub : nat -> nat -> nat Nat.sub is not universe polymorphic -Argument scopes are [nat_scope nat_scope] +Arguments Nat.sub _%nat_scope _%nat_scope : simpl nomatch The reduction tactics unfold Nat.sub but avoid exposing match constructs Nat.sub is transparent Expands to: Constant Coq.Init.Nat.sub Nat.sub : nat -> nat -> nat Nat.sub is not universe polymorphic -Argument scopes are [nat_scope nat_scope] +Arguments Nat.sub _%nat_scope / _%nat_scope : simpl nomatch The reduction tactics unfold Nat.sub when applied to 1 argument but avoid exposing match constructs Nat.sub is transparent @@ -16,7 +16,7 @@ Expands to: Constant Coq.Init.Nat.sub Nat.sub : nat -> nat -> nat Nat.sub is not universe polymorphic -Argument scopes are [nat_scope nat_scope] +Arguments Nat.sub !_%nat_scope / _%nat_scope : simpl nomatch The reduction tactics unfold Nat.sub when the 1st argument evaluates to a constructor and when applied to 1 argument but avoid exposing match constructs @@ -25,7 +25,7 @@ Expands to: Constant Coq.Init.Nat.sub Nat.sub : nat -> nat -> nat Nat.sub is not universe polymorphic -Argument scopes are [nat_scope nat_scope] +Arguments Nat.sub !_%nat_scope !_%nat_scope / The reduction tactics unfold Nat.sub when the 1st and 2nd arguments evaluate to a constructor and when applied to 2 arguments Nat.sub is transparent @@ -33,7 +33,7 @@ Expands to: Constant Coq.Init.Nat.sub Nat.sub : nat -> nat -> nat Nat.sub is not universe polymorphic -Argument scopes are [nat_scope nat_scope] +Arguments Nat.sub !_%nat_scope !_%nat_scope The reduction tactics unfold Nat.sub when the 1st and 2nd arguments evaluate to a constructor Nat.sub is transparent @@ -43,37 +43,34 @@ forall D1 C1 : Type, (D1 -> C1) -> forall D2 C2 : Type, (D2 -> C2) -> D1 * D2 -> C1 * C2 pf is not universe polymorphic -Arguments D2, C2 are implicit -Arguments D1, C1 are implicit and maximally inserted -Argument scopes are [foo_scope type_scope _ _ _ _ _] +Arguments pf {D1%foo_scope} {C1%type_scope} _ [D2] [C2] : simpl never The reduction tactics never unfold pf pf is transparent Expands to: Constant Arguments.pf fcomp : forall A B C : Type, (B -> C) -> (A -> B) -> A -> C fcomp is not universe polymorphic -Arguments A, B, C are implicit and maximally inserted -Argument scopes are [type_scope type_scope type_scope _ _ _] +Arguments fcomp {A%type_scope} {B%type_scope} {C%type_scope} _ _ _ / The reduction tactics unfold fcomp when applied to 6 arguments fcomp is transparent Expands to: Constant Arguments.fcomp volatile : nat -> nat volatile is not universe polymorphic -Argument scope is [nat_scope] +Arguments volatile / _%nat_scope The reduction tactics always unfold volatile volatile is transparent Expands to: Constant Arguments.volatile f : T1 -> T2 -> nat -> unit -> nat -> nat f is not universe polymorphic -Argument scopes are [_ _ nat_scope _ nat_scope] +Arguments f _ _ _%nat_scope _ _%nat_scope f is transparent Expands to: Constant Arguments.S1.S2.f f : T1 -> T2 -> nat -> unit -> nat -> nat f is not universe polymorphic -Argument scopes are [_ _ nat_scope _ nat_scope] +Arguments f _ _ !_%nat_scope !_ !_%nat_scope The reduction tactics unfold f when the 3rd, 4th and 5th arguments evaluate to a constructor f is transparent @@ -81,8 +78,7 @@ Expands to: Constant Arguments.S1.S2.f f : forall T2 : Type, T1 -> T2 -> nat -> unit -> nat -> nat f is not universe polymorphic -Argument T2 is implicit -Argument scopes are [type_scope _ _ nat_scope _ nat_scope] +Arguments f [T2%type_scope] _ _ !_%nat_scope !_ !_%nat_scope The reduction tactics unfold f when the 4th, 5th and 6th arguments evaluate to a constructor f is transparent @@ -90,8 +86,7 @@ Expands to: Constant Arguments.S1.f f : forall T1 T2 : Type, T1 -> T2 -> nat -> unit -> nat -> nat f is not universe polymorphic -Arguments T1, T2 are implicit -Argument scopes are [type_scope type_scope _ _ nat_scope _ nat_scope] +Arguments f [T1%type_scope] [T2%type_scope] _ _ !_%nat_scope !_ !_%nat_scope The reduction tactics unfold f when the 5th, 6th and 7th arguments evaluate to a constructor f is transparent @@ -103,6 +98,7 @@ Expands to: Constant Arguments.f f : forall T1 T2 : Type, T1 -> T2 -> nat -> unit -> nat -> nat f is not universe polymorphic +Arguments f _ _ _ _ !_ !_ !_ The reduction tactics unfold f when the 5th, 6th and 7th arguments evaluate to a constructor f is transparent @@ -118,7 +114,7 @@ Extra arguments: _, _. volatilematch : nat -> nat volatilematch is not universe polymorphic -Argument scope is [nat_scope] +Arguments volatilematch / _%nat_scope : simpl nomatch The reduction tactics always unfold volatilematch but avoid exposing match constructs volatilematch is transparent diff --git a/test-suite/output/ArgumentsScope.out b/test-suite/output/ArgumentsScope.out index 69ba329ff1..7b25fd40f8 100644 --- a/test-suite/output/ArgumentsScope.out +++ b/test-suite/output/ArgumentsScope.out @@ -1,29 +1,29 @@ a : bool -> bool a is not universe polymorphic -Argument scope is [bool_scope] +Arguments a _%bool_scope Expands to: Variable a b : bool -> bool b is not universe polymorphic -Argument scope is [bool_scope] +Arguments b _%bool_scope Expands to: Variable b negb'' : bool -> bool negb'' is not universe polymorphic -Argument scope is [bool_scope] +Arguments negb'' _%bool_scope negb'' is transparent Expands to: Constant ArgumentsScope.A.B.negb'' negb' : bool -> bool negb' is not universe polymorphic -Argument scope is [bool_scope] +Arguments negb' _%bool_scope negb' is transparent Expands to: Constant ArgumentsScope.A.negb' negb : bool -> bool negb is not universe polymorphic -Argument scope is [bool_scope] +Arguments negb _%bool_scope negb is transparent Expands to: Constant Coq.Init.Datatypes.negb a : bool -> bool diff --git a/test-suite/output/Arguments_renaming.out b/test-suite/output/Arguments_renaming.out index 65c902202d..53d5624f6f 100644 --- a/test-suite/output/Arguments_renaming.out +++ b/test-suite/output/Arguments_renaming.out @@ -13,36 +13,21 @@ where ?y : [ |- nat] Inductive eq (A : Type) (x : A) : A -> Prop := eq_refl : x = x -For eq_refl: Arguments are renamed to B, y -For eq: Argument A is implicit and maximally inserted -For eq_refl, when applied to no arguments: - Arguments B, y are implicit and maximally inserted -For eq_refl, when applied to 1 argument: - Argument B is implicit -For eq: Argument scopes are [type_scope _ _] -For eq_refl: Argument scopes are [type_scope _] +Arguments eq {A%type_scope} +Arguments eq_refl {B%type_scope} {y}, [B] _ eq_refl : forall (A : Type) (x : A), x = x eq_refl is not universe polymorphic -Arguments are renamed to B, y -When applied to no arguments: - Arguments B, y are implicit and maximally inserted -When applied to 1 argument: - Argument B is implicit -Argument scopes are [type_scope _] +Arguments eq_refl {B%type_scope} {y}, [B] _ Expands to: Constructor Coq.Init.Logic.eq_refl Inductive myEq (B : Type) (x : A) : A -> Prop := myrefl : B -> myEq B x x -For myrefl: Arguments are renamed to C, x, _ -For myrefl: Argument C is implicit and maximally inserted -For myEq: Argument scopes are [type_scope _ _] -For myrefl: Argument scopes are [type_scope _ _] +Arguments myEq _%type_scope +Arguments myrefl {C%type_scope} x : rename myrefl : forall (B : Type) (x : A), B -> myEq B x x myrefl is not universe polymorphic -Arguments are renamed to C, x, _ -Argument C is implicit and maximally inserted -Argument scopes are [type_scope _ _] +Arguments myrefl {C%type_scope} x : rename Expands to: Constructor Arguments_renaming.Test1.myrefl myplus = fix myplus (T : Type) (t : T) (n m : nat) {struct n} : nat := @@ -52,15 +37,11 @@ fix myplus (T : Type) (t : T) (n m : nat) {struct n} : nat := end : forall T : Type, T -> nat -> nat -> nat -Arguments are renamed to Z, t, n, m -Argument Z is implicit and maximally inserted -Argument scopes are [type_scope _ nat_scope nat_scope] +Arguments myplus {Z%type_scope} !t !n%nat_scope m%nat_scope : rename myplus : forall T : Type, T -> nat -> nat -> nat myplus is not universe polymorphic -Arguments are renamed to Z, t, n, m -Argument Z is implicit and maximally inserted -Argument scopes are [type_scope _ nat_scope nat_scope] +Arguments myplus {Z%type_scope} !t !n%nat_scope m%nat_scope : rename The reduction tactics unfold myplus when the 2nd and 3rd arguments evaluate to a constructor myplus is transparent @@ -70,16 +51,12 @@ Expands to: Constant Arguments_renaming.Test1.myplus Inductive myEq (A B : Type) (x : A) : A -> Prop := myrefl : B -> myEq A B x x -For myrefl: Arguments are renamed to A, C, x, _ -For myrefl: Argument C is implicit and maximally inserted -For myEq: Argument scopes are [type_scope type_scope _ _] -For myrefl: Argument scopes are [type_scope type_scope _ _] +Arguments myEq _%type_scope _%type_scope +Arguments myrefl A%type_scope {C%type_scope} x : rename myrefl : forall (A B : Type) (x : A), B -> myEq A B x x myrefl is not universe polymorphic -Arguments are renamed to A, C, x, _ -Argument C is implicit and maximally inserted -Argument scopes are [type_scope type_scope _ _] +Arguments myrefl A%type_scope {C%type_scope} x : rename Expands to: Constructor Arguments_renaming.myrefl myrefl : forall (A C : Type) (x : A), C -> myEq A C x x @@ -91,15 +68,11 @@ fix myplus (T : Type) (t : T) (n m : nat) {struct n} : nat := end : forall T : Type, T -> nat -> nat -> nat -Arguments are renamed to Z, t, n, m -Argument Z is implicit and maximally inserted -Argument scopes are [type_scope _ nat_scope nat_scope] +Arguments myplus {Z%type_scope} !t !n%nat_scope m%nat_scope : rename myplus : forall T : Type, T -> nat -> nat -> nat myplus is not universe polymorphic -Arguments are renamed to Z, t, n, m -Argument Z is implicit and maximally inserted -Argument scopes are [type_scope _ nat_scope nat_scope] +Arguments myplus {Z%type_scope} !t !n%nat_scope m%nat_scope : rename The reduction tactics unfold myplus when the 2nd and 3rd arguments evaluate to a constructor myplus is transparent diff --git a/test-suite/output/Cases.out b/test-suite/output/Cases.out index cb835ab48d..7489b8987e 100644 --- a/test-suite/output/Cases.out +++ b/test-suite/output/Cases.out @@ -7,7 +7,7 @@ fix F (t : t) : P t := : forall P : t -> Type, (let x := t in forall x0 : x, P x0 -> P (k x0)) -> forall t : t, P t -Argument scopes are [function_scope function_scope _] +Arguments t_rect _%function_scope _%function_scope = fun d : TT => match d with | {| f3 := b |} => b end @@ -26,7 +26,7 @@ match Nat.eq_dec x y with end : forall (x y : nat) (P : nat -> Type), P x -> P y -> P y -Argument scopes are [nat_scope nat_scope function_scope _ _] +Arguments proj _%nat_scope _%nat_scope _%function_scope foo = fix foo (A : Type) (l : list A) {struct l} : option A := match l with @@ -36,14 +36,14 @@ fix foo (A : Type) (l : list A) {struct l} : option A := end : forall A : Type, list A -> option A -Argument scopes are [type_scope list_scope] +Arguments foo _%type_scope _%list_scope uncast = fun (A : Type) (x : I A) => match x with | x0 <: _ => x0 end : forall A : Type, I A -> A -Argument scopes are [type_scope _] +Arguments uncast _%type_scope foo' = if A 0 then true else false : bool f = @@ -82,7 +82,7 @@ lem2 = fun dd : bool => if dd as aa return (aa = aa) then eq_refl else eq_refl : forall k : bool, k = k -Argument scope is [bool_scope] +Arguments lem2 _%bool_scope lem3 = fun dd : nat * nat => let (bb, cc) as aa return (aa = aa) := dd in eq_refl : forall k : nat * nat, k = k diff --git a/test-suite/output/FloatExtraction.out b/test-suite/output/FloatExtraction.out new file mode 100644 index 0000000000..cfd6633752 --- /dev/null +++ b/test-suite/output/FloatExtraction.out @@ -0,0 +1,67 @@ + +(** val infinity : Float64.t **) + +let infinity = + (Float64.of_float (infinity)) + +(** val neg_infinity : Float64.t **) + +let neg_infinity = + (Float64.of_float (neg_infinity)) + +(** val nan : Float64.t **) + +let nan = + (Float64.of_float (nan)) + +(** val one : Float64.t **) + +let one = + (Float64.of_float (0x1p+0)) + +(** val zero : Float64.t **) + +let zero = + (Float64.of_float (0x0p+0)) + +(** val two : Float64.t **) + +let two = + (Float64.of_float (0x1p+1)) + +(** val list_floats : Float64.t list **) + +let list_floats = + nan :: (infinity :: (neg_infinity :: (zero :: (one :: (two :: ((Float64.of_float (0x1p-1)) :: ((Float64.of_float (0x1.47ae147ae147bp-7)) :: ((Float64.of_float (-0x1p-1)) :: ((Float64.of_float (-0x1.47ae147ae147bp-7)) :: ((Float64.of_float (0x1.e42d130773b76p+1023)) :: ((Float64.of_float (-0x0.c396c98f8d899p-1022)) :: []))))))))))) + + +(** val sqrt : Float64.t -> Float64.t **) + +let sqrt = Float64.sqrt + +(** val opp : Float64.t -> Float64.t **) + +let opp = Float64.opp + +(** val mul : Float64.t -> Float64.t -> Float64.t **) + +let mul = Float64.mul + +(** val sub : Float64.t -> Float64.t -> Float64.t **) + +let sub = Float64.sub + +(** val div : Float64.t -> Float64.t -> Float64.t **) + +let div = Float64.div + +(** val discr : Float64.t -> Float64.t -> Float64.t -> Float64.t **) + +let discr a b c = + sub (mul b b) (mul (mul (Float64.of_float (0x1p+2)) a) c) + +(** val x1 : Float64.t -> Float64.t -> Float64.t -> Float64.t **) + +let x1 a b c = + div (sub (opp b) (sqrt (discr a b c))) (mul (Float64.of_float (0x1p+1)) a) + diff --git a/test-suite/output/FloatExtraction.v b/test-suite/output/FloatExtraction.v new file mode 100644 index 0000000000..f296e8e871 --- /dev/null +++ b/test-suite/output/FloatExtraction.v @@ -0,0 +1,33 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +Require Import Floats ExtrOCamlFloats. + +Require Import List. Import ListNotations. + +(* from Require Import ExtrOcamlBasic. *) +Extract Inductive list => list [ "[]" "( :: )" ]. + +Local Open Scope float_scope. + +(* Avoid exponents with less than three digits as they are usually + displayed with two digits (1e7 is displayed 1e+07) except on + Windows where three digits are used (1e+007). *) +Definition list_floats := + [nan; infinity; neg_infinity; zero; one; two; + 0.5; 0.01; -0.5; -0.01; 1.7e+308; -1.7e-308]. + +Recursive Extraction list_floats. + +Definition discr a b c := b * b - 4.0 * a * c. + +Definition x1 a b c := (- b - sqrt (discr a b c)) / (2.0 * a). + +Recursive Extraction x1. diff --git a/test-suite/output/FloatSyntax.out b/test-suite/output/FloatSyntax.out new file mode 100644 index 0000000000..668a55977d --- /dev/null +++ b/test-suite/output/FloatSyntax.out @@ -0,0 +1,40 @@ +2%float + : float +2.5%float + : float +(-2.5)%float + : float +2.4999999999999999e+123%float + : float +(-2.5000000000000001e-123)%float + : float +(2 + 2)%float + : float +(2.5 + 2.5)%float + : float +2 + : float +2.5 + : float +-2.5 + : float +2.4999999999999999e+123 + : float +-2.5000000000000001e-123 + : float +2 + 2 + : float +2.5 + 2.5 + : float +2 + : nat +2%float + : float +t = 2%flt + : float +t = 2%flt + : float +2 + : nat +2 + : float diff --git a/test-suite/output/FloatSyntax.v b/test-suite/output/FloatSyntax.v new file mode 100644 index 0000000000..85f611352c --- /dev/null +++ b/test-suite/output/FloatSyntax.v @@ -0,0 +1,37 @@ +Require Import Floats. + +Check 2%float. +Check 2.5%float. +Check (-2.5)%float. +(* Avoid exponents with less than three digits as they are usually + displayed with two digits (1e7 is displayed 1e+07) except on + Windows where three digits are used (1e+007). *) +Check 2.5e123%float. +Check (-2.5e-123)%float. +Check (2 + 2)%float. +Check (2.5 + 2.5)%float. + +Open Scope float_scope. + +Check 2. +Check 2.5. +Check (-2.5). +Check 2.5e123. +Check (-2.5e-123). +Check (2 + 2). +Check (2.5 + 2.5). + +Open Scope nat_scope. + +Check 2. +Check 2%float. + +Delimit Scope float_scope with flt. +Definition t := 2%float. +Print t. +Delimit Scope nat_scope with float. +Print t. +Check 2. +Close Scope nat_scope. +Check 2. +Close Scope float_scope. diff --git a/test-suite/output/Implicit.out b/test-suite/output/Implicit.out index 3b65003c29..d65d2a8f55 100644 --- a/test-suite/output/Implicit.out +++ b/test-suite/output/Implicit.out @@ -5,8 +5,7 @@ ex_intro (P:=fun _ : nat => True) (x:=0) I d2 = fun x : nat => d1 (y:=x) : forall x x0 : nat, x0 = x -> x0 = x -Arguments x, x0 are implicit -Argument scopes are [nat_scope nat_scope _] +Arguments d2 [x%nat_scope] [x0%nat_scope] map id (1 :: nil) : list nat map id' (1 :: nil) diff --git a/test-suite/output/Inductive.out b/test-suite/output/Inductive.out index af202ea01c..8ff571ae55 100644 --- a/test-suite/output/Inductive.out +++ b/test-suite/output/Inductive.out @@ -3,5 +3,5 @@ Last occurrence of "list'" must have "A" as 1st argument in "A -> list' A -> list' (A * A)%type". Inductive foo (A : Type) (x : A) (y : A := x) : Prop := Foo : foo A x -For foo: Argument scopes are [type_scope _] -For Foo: Argument scopes are [type_scope _] +Arguments foo _%type_scope +Arguments Foo _%type_scope diff --git a/test-suite/output/InitSyntax.out b/test-suite/output/InitSyntax.out index c17c63e724..ce058a6d34 100644 --- a/test-suite/output/InitSyntax.out +++ b/test-suite/output/InitSyntax.out @@ -1,11 +1,8 @@ Inductive sig2 (A : Type) (P Q : A -> Prop) : Type := exist2 : forall x : A, P x -> Q x -> {x : A | P x & Q x} -For sig2: Argument A is implicit -For exist2: Argument A is implicit -For sig2: Argument scopes are [type_scope type_scope type_scope] -For exist2: Argument scopes are [type_scope function_scope function_scope _ _ - _] +Arguments sig2 [A%type_scope] _%type_scope _%type_scope +Arguments exist2 [A%type_scope] _%function_scope _%function_scope exists x : nat, x = x : Prop fun b : bool => if b then b else b diff --git a/test-suite/output/Notations3.out b/test-suite/output/Notations3.out index d32cf67e28..abada44da7 100644 --- a/test-suite/output/Notations3.out +++ b/test-suite/output/Notations3.out @@ -230,7 +230,7 @@ fun l : list nat => match l with end : list nat -> list nat -Argument scope is [list_scope] +Arguments foo _%list_scope Notation "'exists' x .. y , p" := ex (fun x => .. (ex (fun y => p)) ..) : type_scope (default interpretation) diff --git a/test-suite/output/NumeralNotations.out b/test-suite/output/NumeralNotations.out index 460c77879c..505dc52ebe 100644 --- a/test-suite/output/NumeralNotations.out +++ b/test-suite/output/NumeralNotations.out @@ -180,3 +180,41 @@ let v := 4%Zlike in v : Zlike : Zlike 0%Zlike : Zlike +let v := 0%kt in v : ty + : ty +let v := 1%kt in v : ty + : ty +let v := 2%kt in v : ty + : ty +let v := 3%kt in v : ty + : ty +let v := 4%kt in v : ty + : ty +let v := 5%kt in v : ty + : ty +The command has indeed failed with message: +Cannot interpret this number as a value of type ty + = 0%kt + : ty + = 1%kt + : ty + = 2%kt + : ty + = 3%kt + : ty + = 4%kt + : ty + = 5%kt + : ty +let v : ty := Build_ty Empty_set zero in v : ty + : ty +let v : ty := Build_ty unit one in v : ty + : ty +let v : ty := Build_ty bool two in v : ty + : ty +let v : ty := Build_ty Prop prop in v : ty + : ty +let v : ty := Build_ty Set set in v : ty + : ty +let v : ty := Build_ty Type type in v : ty + : ty diff --git a/test-suite/output/NumeralNotations.v b/test-suite/output/NumeralNotations.v index 44805ad09d..c306b15ef3 100644 --- a/test-suite/output/NumeralNotations.v +++ b/test-suite/output/NumeralNotations.v @@ -391,3 +391,68 @@ Module Test19. Check {| summands := (cons 1 (cons 2 (cons (-1) nil)))%Z |}. Check {| summands := nil |}. End Test19. + +Module Test20. + (** Test Sorts *) + Local Set Universe Polymorphism. + Inductive known_type : Type -> Type := + | prop : known_type Prop + | set : known_type Set + | type : known_type Type + | zero : known_type Empty_set + | one : known_type unit + | two : known_type bool. + + Existing Class known_type. + Existing Instances zero one two prop. + Existing Instance set | 2. + Existing Instance type | 4. + + Record > ty := { t : Type ; kt : known_type t }. + + Definition ty_of_uint (x : Decimal.uint) : option ty + := match Nat.of_uint x with + | 0 => @Some ty zero + | 1 => @Some ty one + | 2 => @Some ty two + | 3 => @Some ty prop + | 4 => @Some ty set + | 5 => @Some ty type + | _ => None + end. + Definition uint_of_ty (x : ty) : Decimal.uint + := Nat.to_uint match kt x with + | prop => 3 + | set => 4 + | type => 5 + | zero => 0 + | one => 1 + | two => 2 + end. + + Declare Scope kt_scope. + Delimit Scope kt_scope with kt. + + Numeral Notation ty ty_of_uint uint_of_ty : kt_scope. + + Check let v := 0%kt in v : ty. + Check let v := 1%kt in v : ty. + Check let v := 2%kt in v : ty. + Check let v := 3%kt in v : ty. + Check let v := 4%kt in v : ty. + Check let v := 5%kt in v : ty. + Fail Check let v := 6%kt in v : ty. + Eval cbv in (_ : known_type Empty_set) : ty. + Eval cbv in (_ : known_type unit) : ty. + Eval cbv in (_ : known_type bool) : ty. + Eval cbv in (_ : known_type Prop) : ty. + Eval cbv in (_ : known_type Set) : ty. + Eval cbv in (_ : known_type Type) : ty. + Local Set Printing All. + Check let v := 0%kt in v : ty. + Check let v := 1%kt in v : ty. + Check let v := 2%kt in v : ty. + Check let v := 3%kt in v : ty. + Check let v := 4%kt in v : ty. + Check let v := 5%kt in v : ty. +End Test20. diff --git a/test-suite/output/PatternsInBinders.out b/test-suite/output/PatternsInBinders.out index 8a6d94c732..2952b6d94b 100644 --- a/test-suite/output/PatternsInBinders.out +++ b/test-suite/output/PatternsInBinders.out @@ -15,8 +15,7 @@ swap = fun (A B : Type) '(x, y) => (y, x) : forall A B : Type, A * B -> B * A -Arguments A, B are implicit and maximally inserted -Argument scopes are [type_scope type_scope _] +Arguments swap {A%type_scope} {B%type_scope} fun (A B : Type) '(x, y) => swap (x, y) = (y, x) : forall A B : Type, A * B -> Prop forall (A B : Type) '(x, y), swap (x, y) = (y, x) @@ -42,6 +41,6 @@ fun (pat : nat) '(x, y) => x + y = pat f = fun x : nat => x + x : nat -> nat -Argument scope is [nat_scope] +Arguments f _%nat_scope fun x : nat => x + x : nat -> nat diff --git a/test-suite/output/PrintInfos.out b/test-suite/output/PrintInfos.out index e788977fb7..7d0d81a3e8 100644 --- a/test-suite/output/PrintInfos.out +++ b/test-suite/output/PrintInfos.out @@ -1,36 +1,24 @@ existT : forall (A : Type) (P : A -> Type) (x : A), P x -> {x : A & P x} existT is template universe polymorphic on sigT.u0 sigT.u1 -Argument A is implicit -Argument scopes are [type_scope function_scope _ _] +Arguments existT [A%type_scope] _%function_scope Expands to: Constructor Coq.Init.Specif.existT Inductive sigT (A : Type) (P : A -> Type) : Type := existT : forall x : A, P x -> {x : A & P x} -For sigT: Argument A is implicit -For existT: Argument A is implicit -For sigT: Argument scopes are [type_scope type_scope] -For existT: Argument scopes are [type_scope function_scope _ _] +Arguments sigT [A%type_scope] _%type_scope +Arguments existT [A%type_scope] _%function_scope existT : forall (A : Type) (P : A -> Type) (x : A), P x -> {x : A & P x} Argument A is implicit Inductive eq (A : Type) (x : A) : A -> Prop := eq_refl : x = x -For eq: Argument A is implicit and maximally inserted -For eq_refl, when applied to no arguments: - Arguments A, x are implicit and maximally inserted -For eq_refl, when applied to 1 argument: - Argument A is implicit -For eq: Argument scopes are [type_scope _ _] -For eq_refl: Argument scopes are [type_scope _] +Arguments eq {A%type_scope} +Arguments eq_refl {A%type_scope} {x}, [A] _ eq_refl : forall (A : Type) (x : A), x = x eq_refl is not universe polymorphic -When applied to no arguments: - Arguments A, x are implicit and maximally inserted -When applied to 1 argument: - Argument A is implicit -Argument scopes are [type_scope _] +Arguments eq_refl {A%type_scope} {x}, [A] _ Expands to: Constructor Coq.Init.Logic.eq_refl eq_refl : forall (A : Type) (x : A), x = x @@ -46,11 +34,11 @@ fix add (n m : nat) {struct n} : nat := end : nat -> nat -> nat -Argument scopes are [nat_scope nat_scope] +Arguments Nat.add _%nat_scope _%nat_scope Nat.add : nat -> nat -> nat Nat.add is not universe polymorphic -Argument scopes are [nat_scope nat_scope] +Arguments Nat.add _%nat_scope _%nat_scope Nat.add is transparent Expands to: Constant Coq.Init.Nat.add Nat.add : nat -> nat -> nat @@ -58,17 +46,15 @@ Nat.add : nat -> nat -> nat plus_n_O : forall n : nat, n = n + 0 plus_n_O is not universe polymorphic -Argument scope is [nat_scope] +Arguments plus_n_O _%nat_scope plus_n_O is opaque Expands to: Constant Coq.Init.Peano.plus_n_O Inductive le (n : nat) : nat -> Prop := le_n : n <= n | le_S : forall m : nat, n <= m -> n <= S m -For le_S: Argument m is implicit -For le_S: Argument n is implicit and maximally inserted -For le: Argument scopes are [nat_scope nat_scope] -For le_n: Argument scope is [nat_scope] -For le_S: Argument scopes are [nat_scope nat_scope _] +Arguments le _%nat_scope _%nat_scope +Arguments le_n _%nat_scope +Arguments le_S {n%nat_scope} [m%nat_scope] comparison : Set comparison is not universe polymorphic @@ -81,26 +67,21 @@ bar is not universe polymorphic Expanded type for implicit arguments bar : forall x : nat, x = 0 -Argument x is implicit and maximally inserted +Arguments bar {x} Expands to: Constant PrintInfos.bar *** [ bar : foo ] Expanded type for implicit arguments bar : forall x : nat, x = 0 -Argument x is implicit and maximally inserted +Arguments bar {x} Module Coq.Init.Peano Notation sym_eq := eq_sym Expands to: Notation Coq.Init.Logic.sym_eq Inductive eq (A : Type) (x : A) : A -> Prop := eq_refl : x = x -For eq: Argument A is implicit and maximally inserted -For eq_refl, when applied to no arguments: - Arguments A, x are implicit and maximally inserted -For eq_refl, when applied to 1 argument: - Argument A is implicit and maximally inserted -For eq: Argument scopes are [type_scope _ _] -For eq_refl: Argument scopes are [type_scope _] +Arguments eq {A%type_scope} +Arguments eq_refl {A%type_scope} {x}, {A} _ n:nat Hypothesis of the goal context. diff --git a/test-suite/output/StringSyntax.out b/test-suite/output/StringSyntax.out index 9366113c0c..e9cf4282dc 100644 --- a/test-suite/output/StringSyntax.out +++ b/test-suite/output/StringSyntax.out @@ -433,7 +433,7 @@ end P "167" -> P "168" -> P "169" -> P "170" -> P "171" -> P "172" -> P "173" -> P "174" -> P "175" -> P "176" -> P "177" -> P "178" -> P "179" -> P "180" -> P "181" -> P "182" -> P "183" -> P "184" -> P "185" -> P "186" -> P "187" -> P "188" -> P "189" -> P "190" -> P "191" -> P "192" -> P "193" -> P "194" -> P "195" -> P "196" -> P "197" -> P "198" -> P "199" -> P "200" -> P "201" -> P "202" -> P "203" -> P "204" -> P "205" -> P "206" -> P "207" -> P "208" -> P "209" -> P "210" -> P "211" -> P "212" -> P "213" -> P "214" -> P "215" -> P "216" -> P "217" -> P "218" -> P "219" -> P "220" -> P "221" -> P "222" -> P "223" -> P "224" -> P "225" -> P "226" -> P "227" -> P "228" -> P "229" -> P "230" -> P "231" -> P "232" -> P "233" -> P "234" -> P "235" -> P "236" -> P "237" -> P "238" -> P "239" -> P "240" -> P "241" -> P "242" -> P "243" -> P "244" -> P "245" -> P "246" -> P "247" -> P "248" -> P "249" -> P "250" -> P "251" -> P "252" -> P "253" -> P "254" -> P "255" -> forall b : byte, P b -Argument scopes are [function_scope _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ byte_scope] +Arguments byte_rect _%function_scope _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _%byte_scope byte_rec = fun P : byte -> Set => byte_rect P : forall P : byte -> Set, @@ -607,7 +607,7 @@ fun P : byte -> Set => byte_rect P P "167" -> P "168" -> P "169" -> P "170" -> P "171" -> P "172" -> P "173" -> P "174" -> P "175" -> P "176" -> P "177" -> P "178" -> P "179" -> P "180" -> P "181" -> P "182" -> P "183" -> P "184" -> P "185" -> P "186" -> P "187" -> P "188" -> P "189" -> P "190" -> P "191" -> P "192" -> P "193" -> P "194" -> P "195" -> P "196" -> P "197" -> P "198" -> P "199" -> P "200" -> P "201" -> P "202" -> P "203" -> P "204" -> P "205" -> P "206" -> P "207" -> P "208" -> P "209" -> P "210" -> P "211" -> P "212" -> P "213" -> P "214" -> P "215" -> P "216" -> P "217" -> P "218" -> P "219" -> P "220" -> P "221" -> P "222" -> P "223" -> P "224" -> P "225" -> P "226" -> P "227" -> P "228" -> P "229" -> P "230" -> P "231" -> P "232" -> P "233" -> P "234" -> P "235" -> P "236" -> P "237" -> P "238" -> P "239" -> P "240" -> P "241" -> P "242" -> P "243" -> P "244" -> P "245" -> P "246" -> P "247" -> P "248" -> P "249" -> P "250" -> P "251" -> P "252" -> P "253" -> P "254" -> P "255" -> forall b : byte, P b -Argument scopes are [function_scope _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ byte_scope] +Arguments byte_rec _%function_scope _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _%byte_scope byte_ind = fun (P : byte -> Prop) (f : P "000") (f0 : P "001") (f1 : P "002") (f2 : P "003") (f3 : P "004") (f4 : P "005") (f5 : P "006") (f6 : P "007") (f7 : P "008") (f8 : P "009") (f9 : P "010") (f10 : P "011") (f11 : P "012") (f12 : P "013") (f13 : P "014") (f14 : P "015") (f15 : P "016") (f16 : P "017") (f17 : P "018") (f18 : P "019") (f19 : P "020") (f20 : P "021") (f21 : P "022") (f22 : P "023") (f23 : P "024") (f24 : P "025") (f25 : P "026") (f26 : P "027") (f27 : P "028") (f28 : P "029") (f29 : P "030") (f30 : P "031") (f31 : P " ") (f32 : P "!") (f33 : P """") (f34 : P "#") (f35 : P "$") (f36 : P "%") (f37 : P "&") (f38 : P "'") (f39 : P "(") (f40 : P ")") (f41 : P "*") (f42 : P "+") (f43 : P ",") (f44 : P "-") (f45 : P ".") (f46 : P "/") (f47 : P "0") (f48 : P "1") (f49 : P "2") (f50 : P "3") (f51 : P "4") (f52 : P "5") (f53 : P "6") (f54 : P "7") (f55 : P "8") (f56 : P "9") (f57 : P ":") (f58 : P ";") (f59 : P "<") (f60 : P "=") (f61 : P ">") (f62 : P "?") (f63 : P "@") (f64 : P "A") (f65 : P "B") (f66 : P "C") (f67 : P "D") (f68 : P "E") (f69 : P "F") (f70 : P "G") (f71 : P "H") (f72 : P "I") (f73 : P "J") (f74 : P "K") (f75 : P "L") (f76 : P "M") (f77 : P "N") (f78 : P "O") (f79 : P "P") (f80 : P "Q") (f81 : P "R") (f82 : P "S") (f83 : P "T") (f84 : P "U") (f85 : P "V") (f86 : P "W") (f87 : P "X") (f88 : P "Y") (f89 : P "Z") (f90 : P "[") (f91 : P "\") (f92 : P "]") (f93 : P "^") (f94 : P "_") (f95 : P "`") (f96 : P "a") (f97 : P "b") (f98 : P "c") (f99 : P "d") (f100 : P "e") (f101 : P "f") (f102 : P "g") (f103 : P "h") (f104 : P "i") (f105 : P "j") (f106 : P "k") (f107 : P "l") (f108 : P "m") (f109 : P "n") (f110 : P "o") (f111 : P "p") (f112 : P "q") (f113 : P "r") (f114 : P "s") (f115 : P "t") (f116 : P "u") (f117 : P "v") (f118 : P "w") (f119 : P "x") (f120 : P "y") (f121 : P "z") (f122 : P "{") (f123 : P "|") (f124 : P "}") (f125 : P "~") (f126 : P "127") (f127 : P "128") (f128 : P "129") (f129 : P "130") @@ -1043,7 +1043,7 @@ end P "167" -> P "168" -> P "169" -> P "170" -> P "171" -> P "172" -> P "173" -> P "174" -> P "175" -> P "176" -> P "177" -> P "178" -> P "179" -> P "180" -> P "181" -> P "182" -> P "183" -> P "184" -> P "185" -> P "186" -> P "187" -> P "188" -> P "189" -> P "190" -> P "191" -> P "192" -> P "193" -> P "194" -> P "195" -> P "196" -> P "197" -> P "198" -> P "199" -> P "200" -> P "201" -> P "202" -> P "203" -> P "204" -> P "205" -> P "206" -> P "207" -> P "208" -> P "209" -> P "210" -> P "211" -> P "212" -> P "213" -> P "214" -> P "215" -> P "216" -> P "217" -> P "218" -> P "219" -> P "220" -> P "221" -> P "222" -> P "223" -> P "224" -> P "225" -> P "226" -> P "227" -> P "228" -> P "229" -> P "230" -> P "231" -> P "232" -> P "233" -> P "234" -> P "235" -> P "236" -> P "237" -> P "238" -> P "239" -> P "240" -> P "241" -> P "242" -> P "243" -> P "244" -> P "245" -> P "246" -> P "247" -> P "248" -> P "249" -> P "250" -> P "251" -> P "252" -> P "253" -> P "254" -> P "255" -> forall b : byte, P b -Argument scopes are [function_scope _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ byte_scope] +Arguments byte_ind _%function_scope _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _%byte_scope "000" : byte "a" diff --git a/test-suite/output/UnivBinders.out b/test-suite/output/UnivBinders.out index d48d8b900f..298a0789c4 100644 --- a/test-suite/output/UnivBinders.out +++ b/test-suite/output/UnivBinders.out @@ -4,37 +4,36 @@ Record PWrap (A : Type@{u}) : Type@{u} := pwrap { punwrap : A } (* u |= *) PWrap has primitive projections with eta conversion. -For PWrap: Argument scope is [type_scope] -For pwrap: Argument scopes are [type_scope _] +Arguments PWrap _%type_scope +Arguments pwrap _%type_scope punwrap@{u} = fun (A : Type@{u}) (p : PWrap@{u} A) => punwrap _ p : forall A : Type@{u}, PWrap@{u} A -> A (* u |= *) -Argument scopes are [type_scope _] +Arguments punwrap _%type_scope Record RWrap (A : Type@{u}) : Type@{u} := rwrap { runwrap : A } (* u |= *) -For RWrap: Argument scope is [type_scope] -For rwrap: Argument scopes are [type_scope _] +Arguments RWrap _%type_scope +Arguments rwrap _%type_scope runwrap@{u} = fun (A : Type@{u}) (r : RWrap@{u} A) => let (runwrap) := r in runwrap : forall A : Type@{u}, RWrap@{u} A -> A (* u |= *) -Argument scopes are [type_scope _] +Arguments runwrap _%type_scope Wrap@{u} = fun A : Type@{u} => A : Type@{u} -> Type@{u} (* u |= *) -Argument scope is [type_scope] +Arguments Wrap _%type_scope wrap@{u} = fun (A : Type@{u}) (Wrap : Wrap@{u} A) => Wrap : forall A : Type@{u}, Wrap@{u} A -> A (* u |= *) -Arguments A, Wrap are implicit and maximally inserted -Argument scopes are [type_scope _] +Arguments wrap {A%type_scope} {Wrap} bar@{u} = nat : Wrap@{u} Set (* u |= Set < u *) @@ -87,13 +86,13 @@ Record PWrap (A : Type@{E}) : Type@{E} := pwrap { punwrap : A } (* E |= *) PWrap has primitive projections with eta conversion. -For PWrap: Argument scope is [type_scope] -For pwrap: Argument scopes are [type_scope _] +Arguments PWrap _%type_scope +Arguments pwrap _%type_scope punwrap@{K} : forall A : Type@{K}, PWrap@{K} A -> A (* K |= *) punwrap is universe polymorphic -Argument scopes are [type_scope _] +Arguments punwrap _%type_scope punwrap is transparent Expands to: Constant UnivBinders.punwrap The command has indeed failed with message: @@ -118,7 +117,7 @@ Inductive insecind@{k} : Type@{k+1} := inseccstr : Type@{k} -> insecind@{k} (* k |= *) -For inseccstr: Argument scope is [type_scope] +Arguments inseccstr _%type_scope insec@{u v} = Type@{u} -> Type@{v} : Type@{max(u+1,v+1)} (* u v |= *) @@ -126,7 +125,7 @@ Inductive insecind@{u k} : Type@{k+1} := inseccstr : Type@{k} -> insecind@{u k} (* u k |= *) -For inseccstr: Argument scope is [type_scope] +Arguments inseccstr _%type_scope insec2@{u} = Prop : Type@{Set+1} (* u |= *) @@ -148,24 +147,24 @@ Type@{UnivBinders.59} -> Type@{i} (* i UnivBinders.59 UnivBinders.60 |= *) axfoo is universe polymorphic -Argument scope is [type_scope] +Arguments axfoo _%type_scope Expands to: Constant UnivBinders.axfoo axbar@{i UnivBinders.59 UnivBinders.60} : Type@{UnivBinders.60} -> Type@{i} (* i UnivBinders.59 UnivBinders.60 |= *) axbar is universe polymorphic -Argument scope is [type_scope] +Arguments axbar _%type_scope Expands to: Constant UnivBinders.axbar axfoo' : Type@{axfoo'.u0} -> Type@{axfoo'.i} axfoo' is not universe polymorphic -Argument scope is [type_scope] +Arguments axfoo' _%type_scope Expands to: Constant UnivBinders.axfoo' axbar' : Type@{axfoo'.u0} -> Type@{axfoo'.i} axbar' is not universe polymorphic -Argument scope is [type_scope] +Arguments axbar' _%type_scope Expands to: Constant UnivBinders.axbar' The command has indeed failed with message: When declaring multiple axioms in one command, only the first is allowed a universe binder (which will be shared by the whole block). diff --git a/test-suite/primitive/float/add.v b/test-suite/primitive/float/add.v new file mode 100644 index 0000000000..f8c5939d0a --- /dev/null +++ b/test-suite/primitive/float/add.v @@ -0,0 +1,63 @@ +Require Import ZArith Int63 Floats. + +Open Scope float_scope. + +Definition two := Eval compute in of_int63 2%int63. +Definition three := Eval compute in of_int63 3%int63. +Definition five := Eval compute in of_int63 5%int63. + +Check (eq_refl : two + three = five). +Check (eq_refl five <: two + three = five). +Check (eq_refl five <<: two + three = five). +Definition compute1 := Eval compute in two + three. +Check (eq_refl compute1 : five = five). + +Definition huge := Eval compute in ldexp one 1023%Z. +Definition tiny := Eval compute in ldexp one (-1023)%Z. + +Check (eq_refl : huge + tiny = huge). +Check (eq_refl huge <: huge + tiny = huge). +Check (eq_refl huge <<: huge + tiny = huge). +Definition compute2 := Eval compute in huge + tiny. +Check (eq_refl compute2 : huge = huge). + +Check (eq_refl : huge + huge = infinity). +Check (eq_refl infinity <: huge + huge = infinity). +Check (eq_refl infinity <<: huge + huge = infinity). +Definition compute3 := Eval compute in huge + huge. +Check (eq_refl compute3 : infinity = infinity). + +Check (eq_refl : one + nan = nan). +Check (eq_refl nan <: one + nan = nan). +Check (eq_refl nan <<: one + nan = nan). +Definition compute4 := Eval compute in one + nan. +Check (eq_refl compute4 : nan = nan). + +Check (eq_refl : infinity + infinity = infinity). +Check (eq_refl infinity <: infinity + infinity = infinity). +Check (eq_refl infinity <<: infinity + infinity = infinity). +Definition compute5 := Eval compute in infinity + infinity. +Check (eq_refl compute5 : infinity = infinity). + +Check (eq_refl : infinity + neg_infinity = nan). +Check (eq_refl nan <: infinity + neg_infinity = nan). +Check (eq_refl nan <<: infinity + neg_infinity = nan). +Definition compute6 := Eval compute in infinity + neg_infinity. +Check (eq_refl compute6 : nan = nan). + +Check (eq_refl : zero + zero = zero). +Check (eq_refl zero <: zero + zero = zero). +Check (eq_refl zero <<: zero + zero = zero). +Check (eq_refl : neg_zero + zero = zero). +Check (eq_refl zero <: neg_zero + zero = zero). +Check (eq_refl zero <<: neg_zero + zero = zero). +Check (eq_refl : neg_zero + neg_zero = neg_zero). +Check (eq_refl neg_zero <: neg_zero + neg_zero = neg_zero). +Check (eq_refl neg_zero <<: neg_zero + neg_zero = neg_zero). +Check (eq_refl : zero + neg_zero = zero). +Check (eq_refl zero <: zero + neg_zero = zero). +Check (eq_refl zero <<: zero + neg_zero = zero). + +Check (eq_refl : huge + neg_infinity = neg_infinity). +Check (eq_refl neg_infinity <: huge + neg_infinity = neg_infinity). +Check (eq_refl neg_infinity <<: huge + neg_infinity = neg_infinity). diff --git a/test-suite/primitive/float/classify.v b/test-suite/primitive/float/classify.v new file mode 100644 index 0000000000..22e3fca844 --- /dev/null +++ b/test-suite/primitive/float/classify.v @@ -0,0 +1,33 @@ +Require Import ZArith Floats. + +Definition epsilon := Eval compute in ldexp one (-1024)%Z. + +Check (eq_refl : classify one = PNormal). +Check (eq_refl : classify (- one)%float = NNormal). +Check (eq_refl : classify epsilon = PSubn). +Check (eq_refl : classify (- epsilon)%float = NSubn). +Check (eq_refl : classify zero = PZero). +Check (eq_refl : classify neg_zero = NZero). +Check (eq_refl : classify infinity = PInf). +Check (eq_refl : classify neg_infinity = NInf). +Check (eq_refl : classify nan = NaN). + +Check (eq_refl PNormal <: classify one = PNormal). +Check (eq_refl NNormal <: classify (- one)%float = NNormal). +Check (eq_refl PSubn <: classify epsilon = PSubn). +Check (eq_refl NSubn <: classify (- epsilon)%float = NSubn). +Check (eq_refl PZero <: classify zero = PZero). +Check (eq_refl NZero <: classify neg_zero = NZero). +Check (eq_refl PInf <: classify infinity = PInf). +Check (eq_refl NInf <: classify neg_infinity = NInf). +Check (eq_refl NaN <: classify nan = NaN). + +Check (eq_refl PNormal <<: classify one = PNormal). +Check (eq_refl NNormal <<: classify (- one)%float = NNormal). +Check (eq_refl PSubn <<: classify epsilon = PSubn). +Check (eq_refl NSubn <<: classify (- epsilon)%float = NSubn). +Check (eq_refl PZero <<: classify zero = PZero). +Check (eq_refl NZero <<: classify neg_zero = NZero). +Check (eq_refl PInf <<: classify infinity = PInf). +Check (eq_refl NInf <<: classify neg_infinity = NInf). +Check (eq_refl NaN <<: classify nan = NaN). diff --git a/test-suite/primitive/float/compare.v b/test-suite/primitive/float/compare.v new file mode 100644 index 0000000000..23d1e5bbae --- /dev/null +++ b/test-suite/primitive/float/compare.v @@ -0,0 +1,385 @@ +(* DO NOT EDIT THIS FILE: automatically generated by ./gen_compare.sh *) +Require Import ZArith Floats. +Local Open Scope float_scope. + +Definition min_denorm := Eval compute in ldexp one (-1074)%Z. + +Definition min_norm := Eval compute in ldexp one (-1024)%Z. + +Check (eq_refl false : nan == nan = false). +Check (eq_refl false : nan == nan = false). +Check (eq_refl false : nan < nan = false). +Check (eq_refl false : nan < nan = false). +Check (eq_refl false : nan <= nan = false). +Check (eq_refl false : nan <= nan = false). +Check (eq_refl FNotComparable : nan ?= nan = FNotComparable). +Check (eq_refl FNotComparable : nan ?= nan = FNotComparable). + +Check (eq_refl false <: nan == nan = false). +Check (eq_refl false <: nan == nan = false). +Check (eq_refl false <: nan < nan = false). +Check (eq_refl false <: nan < nan = false). +Check (eq_refl false <: nan <= nan = false). +Check (eq_refl false <: nan <= nan = false). +Check (eq_refl FNotComparable <: nan ?= nan = FNotComparable). +Check (eq_refl FNotComparable <: nan ?= nan = FNotComparable). + +Check (eq_refl false <<: nan == nan = false). +Check (eq_refl false <<: nan == nan = false). +Check (eq_refl false <<: nan < nan = false). +Check (eq_refl false <<: nan < nan = false). +Check (eq_refl false <<: nan <= nan = false). +Check (eq_refl false <<: nan <= nan = false). +Check (eq_refl FNotComparable <<: nan ?= nan = FNotComparable). +Check (eq_refl FNotComparable <<: nan ?= nan = FNotComparable). + +Check (eq_refl false : nan == - nan = false). +Check (eq_refl false : - nan == nan = false). +Check (eq_refl false : nan < - nan = false). +Check (eq_refl false : - nan < nan = false). +Check (eq_refl false : nan <= - nan = false). +Check (eq_refl false : - nan <= nan = false). +Check (eq_refl FNotComparable : nan ?= - nan = FNotComparable). +Check (eq_refl FNotComparable : - nan ?= nan = FNotComparable). + +Check (eq_refl false <: nan == - nan = false). +Check (eq_refl false <: - nan == nan = false). +Check (eq_refl false <: nan < - nan = false). +Check (eq_refl false <: - nan < nan = false). +Check (eq_refl false <: nan <= - nan = false). +Check (eq_refl false <: - nan <= nan = false). +Check (eq_refl FNotComparable <: nan ?= - nan = FNotComparable). +Check (eq_refl FNotComparable <: - nan ?= nan = FNotComparable). + +Check (eq_refl false <<: nan == - nan = false). +Check (eq_refl false <<: - nan == nan = false). +Check (eq_refl false <<: nan < - nan = false). +Check (eq_refl false <<: - nan < nan = false). +Check (eq_refl false <<: nan <= - nan = false). +Check (eq_refl false <<: - nan <= nan = false). +Check (eq_refl FNotComparable <<: nan ?= - nan = FNotComparable). +Check (eq_refl FNotComparable <<: - nan ?= nan = FNotComparable). + +Check (eq_refl true : one == one = true). +Check (eq_refl true : one == one = true). +Check (eq_refl false : one < one = false). +Check (eq_refl false : one < one = false). +Check (eq_refl true : one <= one = true). +Check (eq_refl true : one <= one = true). +Check (eq_refl FEq : one ?= one = FEq). +Check (eq_refl FEq : one ?= one = FEq). + +Check (eq_refl true <: one == one = true). +Check (eq_refl true <: one == one = true). +Check (eq_refl false <: one < one = false). +Check (eq_refl false <: one < one = false). +Check (eq_refl true <: one <= one = true). +Check (eq_refl true <: one <= one = true). +Check (eq_refl FEq <: one ?= one = FEq). +Check (eq_refl FEq <: one ?= one = FEq). + +Check (eq_refl true <<: one == one = true). +Check (eq_refl true <<: one == one = true). +Check (eq_refl false <<: one < one = false). +Check (eq_refl false <<: one < one = false). +Check (eq_refl true <<: one <= one = true). +Check (eq_refl true <<: one <= one = true). +Check (eq_refl FEq <<: one ?= one = FEq). +Check (eq_refl FEq <<: one ?= one = FEq). + +Check (eq_refl true : zero == zero = true). +Check (eq_refl true : zero == zero = true). +Check (eq_refl false : zero < zero = false). +Check (eq_refl false : zero < zero = false). +Check (eq_refl true : zero <= zero = true). +Check (eq_refl true : zero <= zero = true). +Check (eq_refl FEq : zero ?= zero = FEq). +Check (eq_refl FEq : zero ?= zero = FEq). + +Check (eq_refl true <: zero == zero = true). +Check (eq_refl true <: zero == zero = true). +Check (eq_refl false <: zero < zero = false). +Check (eq_refl false <: zero < zero = false). +Check (eq_refl true <: zero <= zero = true). +Check (eq_refl true <: zero <= zero = true). +Check (eq_refl FEq <: zero ?= zero = FEq). +Check (eq_refl FEq <: zero ?= zero = FEq). + +Check (eq_refl true <<: zero == zero = true). +Check (eq_refl true <<: zero == zero = true). +Check (eq_refl false <<: zero < zero = false). +Check (eq_refl false <<: zero < zero = false). +Check (eq_refl true <<: zero <= zero = true). +Check (eq_refl true <<: zero <= zero = true). +Check (eq_refl FEq <<: zero ?= zero = FEq). +Check (eq_refl FEq <<: zero ?= zero = FEq). + +Check (eq_refl true : zero == - zero = true). +Check (eq_refl true : - zero == zero = true). +Check (eq_refl false : zero < - zero = false). +Check (eq_refl false : - zero < zero = false). +Check (eq_refl true : zero <= - zero = true). +Check (eq_refl true : - zero <= zero = true). +Check (eq_refl FEq : zero ?= - zero = FEq). +Check (eq_refl FEq : - zero ?= zero = FEq). + +Check (eq_refl true <: zero == - zero = true). +Check (eq_refl true <: - zero == zero = true). +Check (eq_refl false <: zero < - zero = false). +Check (eq_refl false <: - zero < zero = false). +Check (eq_refl true <: zero <= - zero = true). +Check (eq_refl true <: - zero <= zero = true). +Check (eq_refl FEq <: zero ?= - zero = FEq). +Check (eq_refl FEq <: - zero ?= zero = FEq). + +Check (eq_refl true <<: zero == - zero = true). +Check (eq_refl true <<: - zero == zero = true). +Check (eq_refl false <<: zero < - zero = false). +Check (eq_refl false <<: - zero < zero = false). +Check (eq_refl true <<: zero <= - zero = true). +Check (eq_refl true <<: - zero <= zero = true). +Check (eq_refl FEq <<: zero ?= - zero = FEq). +Check (eq_refl FEq <<: - zero ?= zero = FEq). + +Check (eq_refl true : - zero == - zero = true). +Check (eq_refl true : - zero == - zero = true). +Check (eq_refl false : - zero < - zero = false). +Check (eq_refl false : - zero < - zero = false). +Check (eq_refl true : - zero <= - zero = true). +Check (eq_refl true : - zero <= - zero = true). +Check (eq_refl FEq : - zero ?= - zero = FEq). +Check (eq_refl FEq : - zero ?= - zero = FEq). + +Check (eq_refl true <: - zero == - zero = true). +Check (eq_refl true <: - zero == - zero = true). +Check (eq_refl false <: - zero < - zero = false). +Check (eq_refl false <: - zero < - zero = false). +Check (eq_refl true <: - zero <= - zero = true). +Check (eq_refl true <: - zero <= - zero = true). +Check (eq_refl FEq <: - zero ?= - zero = FEq). +Check (eq_refl FEq <: - zero ?= - zero = FEq). + +Check (eq_refl true <<: - zero == - zero = true). +Check (eq_refl true <<: - zero == - zero = true). +Check (eq_refl false <<: - zero < - zero = false). +Check (eq_refl false <<: - zero < - zero = false). +Check (eq_refl true <<: - zero <= - zero = true). +Check (eq_refl true <<: - zero <= - zero = true). +Check (eq_refl FEq <<: - zero ?= - zero = FEq). +Check (eq_refl FEq <<: - zero ?= - zero = FEq). + +Check (eq_refl true : infinity == infinity = true). +Check (eq_refl true : infinity == infinity = true). +Check (eq_refl false : infinity < infinity = false). +Check (eq_refl false : infinity < infinity = false). +Check (eq_refl true : infinity <= infinity = true). +Check (eq_refl true : infinity <= infinity = true). +Check (eq_refl FEq : infinity ?= infinity = FEq). +Check (eq_refl FEq : infinity ?= infinity = FEq). + +Check (eq_refl true <: infinity == infinity = true). +Check (eq_refl true <: infinity == infinity = true). +Check (eq_refl false <: infinity < infinity = false). +Check (eq_refl false <: infinity < infinity = false). +Check (eq_refl true <: infinity <= infinity = true). +Check (eq_refl true <: infinity <= infinity = true). +Check (eq_refl FEq <: infinity ?= infinity = FEq). +Check (eq_refl FEq <: infinity ?= infinity = FEq). + +Check (eq_refl true <<: infinity == infinity = true). +Check (eq_refl true <<: infinity == infinity = true). +Check (eq_refl false <<: infinity < infinity = false). +Check (eq_refl false <<: infinity < infinity = false). +Check (eq_refl true <<: infinity <= infinity = true). +Check (eq_refl true <<: infinity <= infinity = true). +Check (eq_refl FEq <<: infinity ?= infinity = FEq). +Check (eq_refl FEq <<: infinity ?= infinity = FEq). + +Check (eq_refl true : - infinity == - infinity = true). +Check (eq_refl true : - infinity == - infinity = true). +Check (eq_refl false : - infinity < - infinity = false). +Check (eq_refl false : - infinity < - infinity = false). +Check (eq_refl true : - infinity <= - infinity = true). +Check (eq_refl true : - infinity <= - infinity = true). +Check (eq_refl FEq : - infinity ?= - infinity = FEq). +Check (eq_refl FEq : - infinity ?= - infinity = FEq). + +Check (eq_refl true <: - infinity == - infinity = true). +Check (eq_refl true <: - infinity == - infinity = true). +Check (eq_refl false <: - infinity < - infinity = false). +Check (eq_refl false <: - infinity < - infinity = false). +Check (eq_refl true <: - infinity <= - infinity = true). +Check (eq_refl true <: - infinity <= - infinity = true). +Check (eq_refl FEq <: - infinity ?= - infinity = FEq). +Check (eq_refl FEq <: - infinity ?= - infinity = FEq). + +Check (eq_refl true <<: - infinity == - infinity = true). +Check (eq_refl true <<: - infinity == - infinity = true). +Check (eq_refl false <<: - infinity < - infinity = false). +Check (eq_refl false <<: - infinity < - infinity = false). +Check (eq_refl true <<: - infinity <= - infinity = true). +Check (eq_refl true <<: - infinity <= - infinity = true). +Check (eq_refl FEq <<: - infinity ?= - infinity = FEq). +Check (eq_refl FEq <<: - infinity ?= - infinity = FEq). + +Check (eq_refl false : min_denorm == min_norm = false). +Check (eq_refl false : min_norm == min_denorm = false). +Check (eq_refl true : min_denorm < min_norm = true). +Check (eq_refl false : min_norm < min_denorm = false). +Check (eq_refl true : min_denorm <= min_norm = true). +Check (eq_refl false : min_norm <= min_denorm = false). +Check (eq_refl FLt : min_denorm ?= min_norm = FLt). +Check (eq_refl FGt : min_norm ?= min_denorm = FGt). + +Check (eq_refl false <: min_denorm == min_norm = false). +Check (eq_refl false <: min_norm == min_denorm = false). +Check (eq_refl true <: min_denorm < min_norm = true). +Check (eq_refl false <: min_norm < min_denorm = false). +Check (eq_refl true <: min_denorm <= min_norm = true). +Check (eq_refl false <: min_norm <= min_denorm = false). +Check (eq_refl FLt <: min_denorm ?= min_norm = FLt). +Check (eq_refl FGt <: min_norm ?= min_denorm = FGt). + +Check (eq_refl false <<: min_denorm == min_norm = false). +Check (eq_refl false <<: min_norm == min_denorm = false). +Check (eq_refl true <<: min_denorm < min_norm = true). +Check (eq_refl false <<: min_norm < min_denorm = false). +Check (eq_refl true <<: min_denorm <= min_norm = true). +Check (eq_refl false <<: min_norm <= min_denorm = false). +Check (eq_refl FLt <<: min_denorm ?= min_norm = FLt). +Check (eq_refl FGt <<: min_norm ?= min_denorm = FGt). + +Check (eq_refl false : min_denorm == one = false). +Check (eq_refl false : one == min_denorm = false). +Check (eq_refl true : min_denorm < one = true). +Check (eq_refl false : one < min_denorm = false). +Check (eq_refl true : min_denorm <= one = true). +Check (eq_refl false : one <= min_denorm = false). +Check (eq_refl FLt : min_denorm ?= one = FLt). +Check (eq_refl FGt : one ?= min_denorm = FGt). + +Check (eq_refl false <: min_denorm == one = false). +Check (eq_refl false <: one == min_denorm = false). +Check (eq_refl true <: min_denorm < one = true). +Check (eq_refl false <: one < min_denorm = false). +Check (eq_refl true <: min_denorm <= one = true). +Check (eq_refl false <: one <= min_denorm = false). +Check (eq_refl FLt <: min_denorm ?= one = FLt). +Check (eq_refl FGt <: one ?= min_denorm = FGt). + +Check (eq_refl false <<: min_denorm == one = false). +Check (eq_refl false <<: one == min_denorm = false). +Check (eq_refl true <<: min_denorm < one = true). +Check (eq_refl false <<: one < min_denorm = false). +Check (eq_refl true <<: min_denorm <= one = true). +Check (eq_refl false <<: one <= min_denorm = false). +Check (eq_refl FLt <<: min_denorm ?= one = FLt). +Check (eq_refl FGt <<: one ?= min_denorm = FGt). + +Check (eq_refl false : min_norm == one = false). +Check (eq_refl false : one == min_norm = false). +Check (eq_refl true : min_norm < one = true). +Check (eq_refl false : one < min_norm = false). +Check (eq_refl true : min_norm <= one = true). +Check (eq_refl false : one <= min_norm = false). +Check (eq_refl FLt : min_norm ?= one = FLt). +Check (eq_refl FGt : one ?= min_norm = FGt). + +Check (eq_refl false <: min_norm == one = false). +Check (eq_refl false <: one == min_norm = false). +Check (eq_refl true <: min_norm < one = true). +Check (eq_refl false <: one < min_norm = false). +Check (eq_refl true <: min_norm <= one = true). +Check (eq_refl false <: one <= min_norm = false). +Check (eq_refl FLt <: min_norm ?= one = FLt). +Check (eq_refl FGt <: one ?= min_norm = FGt). + +Check (eq_refl false <<: min_norm == one = false). +Check (eq_refl false <<: one == min_norm = false). +Check (eq_refl true <<: min_norm < one = true). +Check (eq_refl false <<: one < min_norm = false). +Check (eq_refl true <<: min_norm <= one = true). +Check (eq_refl false <<: one <= min_norm = false). +Check (eq_refl FLt <<: min_norm ?= one = FLt). +Check (eq_refl FGt <<: one ?= min_norm = FGt). + +Check (eq_refl false : one == infinity = false). +Check (eq_refl false : infinity == one = false). +Check (eq_refl true : one < infinity = true). +Check (eq_refl false : infinity < one = false). +Check (eq_refl true : one <= infinity = true). +Check (eq_refl false : infinity <= one = false). +Check (eq_refl FLt : one ?= infinity = FLt). +Check (eq_refl FGt : infinity ?= one = FGt). + +Check (eq_refl false <: one == infinity = false). +Check (eq_refl false <: infinity == one = false). +Check (eq_refl true <: one < infinity = true). +Check (eq_refl false <: infinity < one = false). +Check (eq_refl true <: one <= infinity = true). +Check (eq_refl false <: infinity <= one = false). +Check (eq_refl FLt <: one ?= infinity = FLt). +Check (eq_refl FGt <: infinity ?= one = FGt). + +Check (eq_refl false <<: one == infinity = false). +Check (eq_refl false <<: infinity == one = false). +Check (eq_refl true <<: one < infinity = true). +Check (eq_refl false <<: infinity < one = false). +Check (eq_refl true <<: one <= infinity = true). +Check (eq_refl false <<: infinity <= one = false). +Check (eq_refl FLt <<: one ?= infinity = FLt). +Check (eq_refl FGt <<: infinity ?= one = FGt). + +Check (eq_refl false : - infinity == infinity = false). +Check (eq_refl false : infinity == - infinity = false). +Check (eq_refl true : - infinity < infinity = true). +Check (eq_refl false : infinity < - infinity = false). +Check (eq_refl true : - infinity <= infinity = true). +Check (eq_refl false : infinity <= - infinity = false). +Check (eq_refl FLt : - infinity ?= infinity = FLt). +Check (eq_refl FGt : infinity ?= - infinity = FGt). + +Check (eq_refl false <: - infinity == infinity = false). +Check (eq_refl false <: infinity == - infinity = false). +Check (eq_refl true <: - infinity < infinity = true). +Check (eq_refl false <: infinity < - infinity = false). +Check (eq_refl true <: - infinity <= infinity = true). +Check (eq_refl false <: infinity <= - infinity = false). +Check (eq_refl FLt <: - infinity ?= infinity = FLt). +Check (eq_refl FGt <: infinity ?= - infinity = FGt). + +Check (eq_refl false <<: - infinity == infinity = false). +Check (eq_refl false <<: infinity == - infinity = false). +Check (eq_refl true <<: - infinity < infinity = true). +Check (eq_refl false <<: infinity < - infinity = false). +Check (eq_refl true <<: - infinity <= infinity = true). +Check (eq_refl false <<: infinity <= - infinity = false). +Check (eq_refl FLt <<: - infinity ?= infinity = FLt). +Check (eq_refl FGt <<: infinity ?= - infinity = FGt). + +Check (eq_refl false : - infinity == one = false). +Check (eq_refl false : one == - infinity = false). +Check (eq_refl true : - infinity < one = true). +Check (eq_refl false : one < - infinity = false). +Check (eq_refl true : - infinity <= one = true). +Check (eq_refl false : one <= - infinity = false). +Check (eq_refl FLt : - infinity ?= one = FLt). +Check (eq_refl FGt : one ?= - infinity = FGt). + +Check (eq_refl false <: - infinity == one = false). +Check (eq_refl false <: one == - infinity = false). +Check (eq_refl true <: - infinity < one = true). +Check (eq_refl false <: one < - infinity = false). +Check (eq_refl true <: - infinity <= one = true). +Check (eq_refl false <: one <= - infinity = false). +Check (eq_refl FLt <: - infinity ?= one = FLt). +Check (eq_refl FGt <: one ?= - infinity = FGt). + +Check (eq_refl false <<: - infinity == one = false). +Check (eq_refl false <<: one == - infinity = false). +Check (eq_refl true <<: - infinity < one = true). +Check (eq_refl false <<: one < - infinity = false). +Check (eq_refl true <<: - infinity <= one = true). +Check (eq_refl false <<: one <= - infinity = false). +Check (eq_refl FLt <<: - infinity ?= one = FLt). +Check (eq_refl FGt <<: one ?= - infinity = FGt). diff --git a/test-suite/primitive/float/coq_env_double_array.v b/test-suite/primitive/float/coq_env_double_array.v new file mode 100644 index 0000000000..754ccb69aa --- /dev/null +++ b/test-suite/primitive/float/coq_env_double_array.v @@ -0,0 +1,13 @@ +Require Import Floats. + +Goal True. +pose (f := one). +pose (f' := (-f)%float). + +(* this used to segfault when the coq_env array given to the + coq_interprete C function was an unboxed OCaml Double_array + (created by Array.map in csymtable.ml just before calling + eval_tcode) *) +vm_compute in f'. + +Abort. diff --git a/test-suite/primitive/float/div.v b/test-suite/primitive/float/div.v new file mode 100644 index 0000000000..8e971f575b --- /dev/null +++ b/test-suite/primitive/float/div.v @@ -0,0 +1,87 @@ +Require Import ZArith Int63 Floats. + +Open Scope float_scope. + +Definition two := Eval compute in of_int63 2%int63. +Definition three := Eval compute in of_int63 3%int63. +Definition six := Eval compute in of_int63 6%int63. + +Check (eq_refl : six / three = two). +Check (eq_refl two <: six / three = two). +Check (eq_refl two <<: six / three = two). +Definition compute1 := Eval compute in six / three. +Check (eq_refl compute1 : two = two). + +Definition huge := Eval compute in ldexp one 1023%Z. +Definition tiny := Eval compute in ldexp one (-1023)%Z. + +Check (eq_refl : huge / tiny = infinity). +Check (eq_refl infinity <: huge / tiny = infinity). +Check (eq_refl infinity <<: huge / tiny = infinity). +Definition compute2 := Eval compute in huge / tiny. +Check (eq_refl compute2 : infinity = infinity). + +Check (eq_refl : huge / huge = one). +Check (eq_refl one <: huge / huge = one). +Check (eq_refl one <<: huge / huge = one). +Definition compute3 := Eval compute in huge / huge. +Check (eq_refl compute3 : one = one). + +Check (eq_refl : one / nan = nan). +Check (eq_refl nan <: one / nan = nan). +Check (eq_refl nan <<: one / nan = nan). +Definition compute4 := Eval compute in one / nan. +Check (eq_refl compute4 : nan = nan). + +Check (eq_refl : infinity / infinity = nan). +Check (eq_refl nan <: infinity / infinity = nan). +Check (eq_refl nan <<: infinity / infinity = nan). +Definition compute5 := Eval compute in infinity / infinity. +Check (eq_refl compute5 : nan = nan). + +Check (eq_refl : infinity / neg_infinity = nan). +Check (eq_refl nan <: infinity / neg_infinity = nan). +Check (eq_refl nan <<: infinity / neg_infinity = nan). +Definition compute6 := Eval compute in infinity / neg_infinity. +Check (eq_refl compute6 : nan = nan). + +Check (eq_refl : zero / zero = nan). +Check (eq_refl nan <: zero / zero = nan). +Check (eq_refl nan <<: zero / zero = nan). +Check (eq_refl : neg_zero / zero = nan). +Check (eq_refl nan <: neg_zero / zero = nan). +Check (eq_refl nan <<: neg_zero / zero = nan). + +Check (eq_refl : huge / neg_infinity = neg_zero). +Check (eq_refl neg_zero <: huge / neg_infinity = neg_zero). +Check (eq_refl neg_zero <<: huge / neg_infinity = neg_zero). + +Check (eq_refl : one / tiny = huge). +Check (eq_refl huge <: one / tiny = huge). +Check (eq_refl huge <<: one / tiny = huge). +Check (eq_refl : one / huge = tiny). +Check (eq_refl tiny <: one / huge = tiny). +Check (eq_refl tiny <<: one / huge = tiny). +Check (eq_refl : zero / huge = zero). +Check (eq_refl zero <: zero / huge = zero). +Check (eq_refl zero <<: zero / huge = zero). +Check (eq_refl : zero / (-huge) = neg_zero). +Check (eq_refl neg_zero <: zero / (-huge) = neg_zero). +Check (eq_refl neg_zero <<: zero / (-huge) = neg_zero). + +Check (eq_refl : tiny / one = tiny). +Check (eq_refl tiny <: tiny / one = tiny). +Check (eq_refl tiny <<: tiny / one = tiny). +Check (eq_refl : huge / one = huge). +Check (eq_refl huge <: huge / one = huge). +Check (eq_refl huge <<: huge / one = huge). +Check (eq_refl : infinity / one = infinity). +Check (eq_refl infinity <: infinity / one = infinity). +Check (eq_refl infinity <<: infinity / one = infinity). + +Check (eq_refl : zero / infinity = zero). +Check (eq_refl zero <: zero / infinity = zero). +Check (eq_refl zero <<: zero / infinity = zero). +Check (eq_refl : infinity / zero = infinity). +Check (eq_refl infinity <: infinity / zero = infinity). +Check (eq_refl infinity <<: infinity / zero = infinity). diff --git a/test-suite/primitive/float/double_rounding.v b/test-suite/primitive/float/double_rounding.v new file mode 100644 index 0000000000..e2356cdd7b --- /dev/null +++ b/test-suite/primitive/float/double_rounding.v @@ -0,0 +1,38 @@ +Require Import Floats ZArith. + +(* This test check that there is no double rounding with 80 bits registers inside float computations *) + +Definition big_cbn := Eval cbn in ldexp one (53)%Z. +Definition small_cbn := Eval cbn in (one + ldexp one (-52)%Z)%float. +Definition result_cbn := Eval cbn in (big_cbn + small_cbn)%float. +Definition check_cbn := Eval cbn in (big_cbn + one)%float. + +Check (eq_refl : (result_cbn ?= big_cbn)%float = FGt). +Check (eq_refl : (check_cbn ?= big_cbn)%float = FEq). + + +Definition big_cbv := Eval cbv in ldexp one (53)%Z. +Definition small_cbv := Eval cbv in (one + ldexp one (-52)%Z)%float. +Definition result_cbv := Eval cbv in (big_cbv + small_cbv)%float. +Definition check_cbv := Eval cbv in (big_cbv + one)%float. + +Check (eq_refl : (result_cbv ?= big_cbv)%float = FGt). +Check (eq_refl : (check_cbv ?= big_cbv)%float = FEq). + + +Definition big_vm := Eval vm_compute in ldexp one (53)%Z. +Definition small_vm := Eval vm_compute in (one + ldexp one (-52)%Z)%float. +Definition result_vm := Eval vm_compute in (big_vm + small_vm)%float. +Definition check_vm := Eval vm_compute in (big_vm + one)%float. + +Check (eq_refl : (result_vm ?= big_vm)%float = FGt). +Check (eq_refl : (check_vm ?= big_vm)%float = FEq). + + +Definition big_native := Eval native_compute in ldexp one (53)%Z. +Definition small_native := Eval native_compute in (one + ldexp one (-52)%Z)%float. +Definition result_native := Eval native_compute in (big_native + small_native)%float. +Definition check_native := Eval native_compute in (big_native + one)%float. + +Check (eq_refl : (result_native ?= big_native)%float = FGt). +Check (eq_refl : (check_native ?= big_native)%float = FEq). diff --git a/test-suite/primitive/float/frexp.v b/test-suite/primitive/float/frexp.v new file mode 100644 index 0000000000..2a600429b1 --- /dev/null +++ b/test-suite/primitive/float/frexp.v @@ -0,0 +1,28 @@ +Require Import ZArith Floats. + +Definition denorm := Eval compute in ldexp one (-1074)%Z. +Definition neg_one := Eval compute in (-one)%float. + +Check (eq_refl : let (m,e) := frexp infinity in (Prim2SF m, e) = SFfrexp prec emax (Prim2SF infinity)). +Check (eq_refl (SFfrexp prec emax (Prim2SF infinity)) <: let (m,e) := frexp infinity in (Prim2SF m, e) = SFfrexp prec emax (Prim2SF infinity)). +Check (eq_refl (SFfrexp prec emax (Prim2SF infinity)) <<: let (m,e) := frexp infinity in (Prim2SF m, e) = SFfrexp prec emax (Prim2SF infinity)). + +Check (eq_refl : let (m,e) := frexp nan in (Prim2SF m, e) = SFfrexp prec emax (Prim2SF nan)). +Check (eq_refl (SFfrexp prec emax (Prim2SF nan)) <: let (m,e) := frexp nan in (Prim2SF m, e) = SFfrexp prec emax (Prim2SF nan)). +Check (eq_refl (SFfrexp prec emax (Prim2SF nan)) <<: let (m,e) := frexp nan in (Prim2SF m, e) = SFfrexp prec emax (Prim2SF nan)). + +Check (eq_refl : let (m,e) := frexp zero in (Prim2SF m, e) = SFfrexp prec emax (Prim2SF zero)). +Check (eq_refl (SFfrexp prec emax (Prim2SF zero)) <: let (m,e) := frexp zero in (Prim2SF m, e) = SFfrexp prec emax (Prim2SF zero)). +Check (eq_refl (SFfrexp prec emax (Prim2SF zero)) <<: let (m,e) := frexp zero in (Prim2SF m, e) = SFfrexp prec emax (Prim2SF zero)). + +Check (eq_refl : let (m,e) := frexp one in (Prim2SF m, e) = SFfrexp prec emax (Prim2SF one)). +Check (eq_refl (SFfrexp prec emax (Prim2SF one)) <: let (m,e) := frexp one in (Prim2SF m, e) = SFfrexp prec emax (Prim2SF one)). +Check (eq_refl (SFfrexp prec emax (Prim2SF one)) <<: let (m,e) := frexp one in (Prim2SF m, e) = SFfrexp prec emax (Prim2SF one)). + +Check (eq_refl : let (m,e) := frexp neg_one in (Prim2SF m, e) = SFfrexp prec emax (Prim2SF neg_one)). +Check (eq_refl (SFfrexp prec emax (Prim2SF neg_one)) <: let (m,e) := frexp neg_one in (Prim2SF m, e) = SFfrexp prec emax (Prim2SF neg_one)). +Check (eq_refl (SFfrexp prec emax (Prim2SF neg_one)) <<: let (m,e) := frexp neg_one in (Prim2SF m, e) = SFfrexp prec emax (Prim2SF neg_one)). + +Check (eq_refl : let (m,e) := frexp denorm in (Prim2SF m, e) = SFfrexp prec emax (Prim2SF denorm)). +Check (eq_refl (SFfrexp prec emax (Prim2SF denorm)) <: let (m,e) := frexp denorm in (Prim2SF m, e) = SFfrexp prec emax (Prim2SF denorm)). +Check (eq_refl (SFfrexp prec emax (Prim2SF denorm)) <<: let (m,e) := frexp denorm in (Prim2SF m, e) = SFfrexp prec emax (Prim2SF denorm)). diff --git a/test-suite/primitive/float/gen_compare.sh b/test-suite/primitive/float/gen_compare.sh new file mode 100755 index 0000000000..cd87eb4e5b --- /dev/null +++ b/test-suite/primitive/float/gen_compare.sh @@ -0,0 +1,65 @@ +#!/bin/bash +# -*- compile-command: "mv -f compare.v{,~} && ./gen_compare.sh" -*- +set -e + +exec > compare.v + +cat <<EOF +(* DO NOT EDIT THIS FILE: automatically generated by ./gen_compare.sh *) +Require Import ZArith Floats. +Local Open Scope float_scope. + +Definition min_denorm := Eval compute in ldexp one (-1074)%Z. + +Definition min_norm := Eval compute in ldexp one (-1024)%Z. + +EOF + +genTest() { + if [ $# -ne 10 ]; then + echo >&2 "genTest expects 10 arguments" + fi + TACTICS=(":" "<:" "<<:") + OPS=("==" "<" "<=" "?=") + x="$1" + y="$2" + OPS1=("$3" "$4" "$5" "$6") # for x y + OPS2=("$7" "$8" "$9" "${10}") # for y x + for tac in "${TACTICS[@]}"; do + for i in {0..3}; do + op="${OPS[$i]}" + op1="${OPS1[$i]}" + op2="${OPS2[$i]}" + echo "Check (eq_refl $op1 $tac $x $op $y = $op1)." + echo "Check (eq_refl $op2 $tac $y $op $x = $op2)." + done + echo + done +} + +genTest nan nan \ + false false false FNotComparable \ + false false false FNotComparable +genTest nan "- nan" \ + false false false FNotComparable \ + false false false FNotComparable + +EQ=(true false true FEq \ + true false true FEq) + +genTest one one "${EQ[@]}" +genTest zero zero "${EQ[@]}" +genTest zero "- zero" "${EQ[@]}" +genTest "- zero" "- zero" "${EQ[@]}" +genTest infinity infinity "${EQ[@]}" +genTest "- infinity" "- infinity" "${EQ[@]}" + +LT=(false true true FLt \ + false false false FGt) + +genTest min_denorm min_norm "${LT[@]}" +genTest min_denorm one "${LT[@]}" +genTest min_norm one "${LT[@]}" +genTest one infinity "${LT[@]}" +genTest "- infinity" infinity "${LT[@]}" +genTest "- infinity" one "${LT[@]}" diff --git a/test-suite/primitive/float/ldexp.v b/test-suite/primitive/float/ldexp.v new file mode 100644 index 0000000000..a725deeeca --- /dev/null +++ b/test-suite/primitive/float/ldexp.v @@ -0,0 +1,21 @@ +Require Import ZArith Int63 Floats. + +Check (eq_refl : ldexp one 9223372036854773807%Z = infinity). +Check (eq_refl infinity <: ldexp one 9223372036854773807%Z = infinity). +Check (eq_refl infinity <<: ldexp one 9223372036854773807%Z = infinity). + +Check (eq_refl : ldshiftexp one 9223372036854775807 = infinity). +Check (eq_refl infinity <: ldshiftexp one 9223372036854775807 = infinity). +Check (eq_refl infinity <<: ldshiftexp one 9223372036854775807 = infinity). + +Check (eq_refl : ldexp one (-2102) = 0%float). +Check (eq_refl 0%float <: ldexp one (-2102) = 0%float). +Check (eq_refl 0%float <<: ldexp one (-2102) = 0%float). + +Check (eq_refl : ldexp one (-3) = 0.125%float). +Check (eq_refl 0.125%float <: ldexp one (-3) = 0.125%float). +Check (eq_refl 0.125%float <<: ldexp one (-3) = 0.125%float). + +Check (eq_refl : ldexp one 3 = 8%float). +Check (eq_refl 8%float <: ldexp one 3 = 8%float). +Check (eq_refl 8%float <<: ldexp one 3 = 8%float). diff --git a/test-suite/primitive/float/mul.v b/test-suite/primitive/float/mul.v new file mode 100644 index 0000000000..91fe7e9791 --- /dev/null +++ b/test-suite/primitive/float/mul.v @@ -0,0 +1,83 @@ +Require Import ZArith Int63 Floats. + +Open Scope float_scope. + +Definition two := Eval compute in of_int63 2%int63. +Definition three := Eval compute in of_int63 3%int63. +Definition six := Eval compute in of_int63 6%int63. + +Check (eq_refl : three * two = six). +Check (eq_refl six <: three * two = six). +Check (eq_refl six <<: three * two = six). +Definition compute1 := Eval compute in three * two. +Check (eq_refl compute1 : six = six). + +Definition huge := Eval compute in ldexp one 1023%Z. +Definition tiny := Eval compute in ldexp one (-1023)%Z. + +Check (eq_refl : huge * tiny = one). +Check (eq_refl one <: huge * tiny = one). +Check (eq_refl one <<: huge * tiny = one). +Definition compute2 := Eval compute in huge * tiny. +Check (eq_refl compute2 : one = one). + +Check (eq_refl : huge * huge = infinity). +Check (eq_refl infinity <: huge * huge = infinity). +Check (eq_refl infinity <<: huge * huge = infinity). +Definition compute3 := Eval compute in huge * huge. +Check (eq_refl compute3 : infinity = infinity). + +Check (eq_refl : one * nan = nan). +Check (eq_refl nan <: one * nan = nan). +Check (eq_refl nan <<: one * nan = nan). +Definition compute4 := Eval compute in one * nan. +Check (eq_refl compute4 : nan = nan). + +Check (eq_refl : infinity * infinity = infinity). +Check (eq_refl infinity <: infinity * infinity = infinity). +Check (eq_refl infinity <<: infinity * infinity = infinity). +Definition compute5 := Eval compute in infinity * infinity. +Check (eq_refl compute5 : infinity = infinity). + +Check (eq_refl : infinity * neg_infinity = neg_infinity). +Check (eq_refl neg_infinity <: infinity * neg_infinity = neg_infinity). +Check (eq_refl neg_infinity <<: infinity * neg_infinity = neg_infinity). +Definition compute6 := Eval compute in infinity * neg_infinity. +Check (eq_refl compute6 : neg_infinity = neg_infinity). + +Check (eq_refl : zero * zero = zero). +Check (eq_refl zero <: zero * zero = zero). +Check (eq_refl zero <<: zero * zero = zero). +Check (eq_refl : neg_zero * zero = neg_zero). +Check (eq_refl neg_zero <: neg_zero * zero = neg_zero). +Check (eq_refl neg_zero <<: neg_zero * zero = neg_zero). +Check (eq_refl : neg_zero * neg_zero = zero). +Check (eq_refl zero <: neg_zero * neg_zero = zero). +Check (eq_refl zero <<: neg_zero * neg_zero = zero). +Check (eq_refl : zero * neg_zero = neg_zero). +Check (eq_refl neg_zero <: zero * neg_zero = neg_zero). +Check (eq_refl neg_zero <<: zero * neg_zero = neg_zero). + +Check (eq_refl : huge * neg_infinity = neg_infinity). +Check (eq_refl neg_infinity <: huge * neg_infinity = neg_infinity). +Check (eq_refl neg_infinity <<: huge * neg_infinity = neg_infinity). + +Check (eq_refl : one * tiny = tiny). +Check (eq_refl tiny <: one * tiny = tiny). +Check (eq_refl tiny <<: one * tiny = tiny). +Check (eq_refl : one * huge = huge). +Check (eq_refl huge <: one * huge = huge). +Check (eq_refl huge <<: one * huge = huge). +Check (eq_refl : zero * huge = zero). +Check (eq_refl zero <: zero * huge = zero). +Check (eq_refl zero <<: zero * huge = zero). +Check (eq_refl : zero * (-huge) = neg_zero). +Check (eq_refl neg_zero <: zero * (-huge) = neg_zero). +Check (eq_refl neg_zero <<: zero * (-huge) = neg_zero). + +Check (eq_refl : zero * infinity = nan). +Check (eq_refl nan <: zero * infinity = nan). +Check (eq_refl nan <<: zero * infinity = nan). +Check (eq_refl : neg_infinity * zero = nan). +Check (eq_refl nan <: neg_infinity * zero = nan). +Check (eq_refl nan <<: neg_infinity * zero = nan). diff --git a/test-suite/primitive/float/next_up_down.v b/test-suite/primitive/float/next_up_down.v new file mode 100644 index 0000000000..4f8427dc5b --- /dev/null +++ b/test-suite/primitive/float/next_up_down.v @@ -0,0 +1,122 @@ +Require Import ZArith Int63 Floats. + +Open Scope float_scope. + +Definition f0 := zero. +Definition f1 := neg_zero. +Definition f2 := Eval compute in ldexp one 0. +Definition f3 := Eval compute in -f1. +(* smallest positive float *) +Definition f4 := Eval compute in ldexp one (-1074). +Definition f5 := Eval compute in -f3. +Definition f6 := infinity. +Definition f7 := neg_infinity. +Definition f8 := Eval compute in ldexp one (-1). +Definition f9 := Eval compute in -f8. +Definition f10 := Eval compute in of_int63 42. +Definition f11 := Eval compute in -f10. +(* max float *) +Definition f12 := Eval compute in ldexp (of_int63 9007199254740991) 1024. +Definition f13 := Eval compute in -f12. +(* smallest positive normalized float *) +Definition f14 := Eval compute in ldexp one (-1022). +Definition f15 := Eval compute in -f14. + +Check (eq_refl : Prim2SF (next_up f0) = SF64succ (Prim2SF f0)). +Check (eq_refl : Prim2SF (next_down f0) = SF64pred (Prim2SF f0)). +Check (eq_refl : Prim2SF (next_up f1) = SF64succ (Prim2SF f1)). +Check (eq_refl : Prim2SF (next_down f1) = SF64pred (Prim2SF f1)). +Check (eq_refl : Prim2SF (next_up f2) = SF64succ (Prim2SF f2)). +Check (eq_refl : Prim2SF (next_down f2) = SF64pred (Prim2SF f2)). +Check (eq_refl : Prim2SF (next_up f3) = SF64succ (Prim2SF f3)). +Check (eq_refl : Prim2SF (next_down f3) = SF64pred (Prim2SF f3)). +Check (eq_refl : Prim2SF (next_up f4) = SF64succ (Prim2SF f4)). +Check (eq_refl : Prim2SF (next_down f4) = SF64pred (Prim2SF f4)). +Check (eq_refl : Prim2SF (next_up f5) = SF64succ (Prim2SF f5)). +Check (eq_refl : Prim2SF (next_down f5) = SF64pred (Prim2SF f5)). +Check (eq_refl : Prim2SF (next_up f6) = SF64succ (Prim2SF f6)). +Check (eq_refl : Prim2SF (next_down f6) = SF64pred (Prim2SF f6)). +Check (eq_refl : Prim2SF (next_up f7) = SF64succ (Prim2SF f7)). +Check (eq_refl : Prim2SF (next_down f7) = SF64pred (Prim2SF f7)). +Check (eq_refl : Prim2SF (next_up f8) = SF64succ (Prim2SF f8)). +Check (eq_refl : Prim2SF (next_down f8) = SF64pred (Prim2SF f8)). +Check (eq_refl : Prim2SF (next_up f9) = SF64succ (Prim2SF f9)). +Check (eq_refl : Prim2SF (next_down f9) = SF64pred (Prim2SF f9)). +Check (eq_refl : Prim2SF (next_up f10) = SF64succ (Prim2SF f10)). +Check (eq_refl : Prim2SF (next_down f10) = SF64pred (Prim2SF f10)). +Check (eq_refl : Prim2SF (next_up f11) = SF64succ (Prim2SF f11)). +Check (eq_refl : Prim2SF (next_down f11) = SF64pred (Prim2SF f11)). +Check (eq_refl : Prim2SF (next_up f12) = SF64succ (Prim2SF f12)). +Check (eq_refl : Prim2SF (next_down f12) = SF64pred (Prim2SF f12)). +Check (eq_refl : Prim2SF (next_up f13) = SF64succ (Prim2SF f13)). +Check (eq_refl : Prim2SF (next_down f13) = SF64pred (Prim2SF f13)). +Check (eq_refl : Prim2SF (next_up f14) = SF64succ (Prim2SF f14)). +Check (eq_refl : Prim2SF (next_down f14) = SF64pred (Prim2SF f14)). +Check (eq_refl : Prim2SF (next_up f15) = SF64succ (Prim2SF f15)). +Check (eq_refl : Prim2SF (next_down f15) = SF64pred (Prim2SF f15)). + +Check (eq_refl (SF64succ (Prim2SF f0)) <: Prim2SF (next_up f0) = SF64succ (Prim2SF f0)). +Check (eq_refl (SF64pred (Prim2SF f0)) <: Prim2SF (next_down f0) = SF64pred (Prim2SF f0)). +Check (eq_refl (SF64succ (Prim2SF f1)) <: Prim2SF (next_up f1) = SF64succ (Prim2SF f1)). +Check (eq_refl (SF64pred (Prim2SF f1)) <: Prim2SF (next_down f1) = SF64pred (Prim2SF f1)). +Check (eq_refl (SF64succ (Prim2SF f2)) <: Prim2SF (next_up f2) = SF64succ (Prim2SF f2)). +Check (eq_refl (SF64pred (Prim2SF f2)) <: Prim2SF (next_down f2) = SF64pred (Prim2SF f2)). +Check (eq_refl (SF64succ (Prim2SF f3)) <: Prim2SF (next_up f3) = SF64succ (Prim2SF f3)). +Check (eq_refl (SF64pred (Prim2SF f3)) <: Prim2SF (next_down f3) = SF64pred (Prim2SF f3)). +Check (eq_refl (SF64succ (Prim2SF f4)) <: Prim2SF (next_up f4) = SF64succ (Prim2SF f4)). +Check (eq_refl (SF64pred (Prim2SF f4)) <: Prim2SF (next_down f4) = SF64pred (Prim2SF f4)). +Check (eq_refl (SF64succ (Prim2SF f5)) <: Prim2SF (next_up f5) = SF64succ (Prim2SF f5)). +Check (eq_refl (SF64pred (Prim2SF f5)) <: Prim2SF (next_down f5) = SF64pred (Prim2SF f5)). +Check (eq_refl (SF64succ (Prim2SF f6)) <: Prim2SF (next_up f6) = SF64succ (Prim2SF f6)). +Check (eq_refl (SF64pred (Prim2SF f6)) <: Prim2SF (next_down f6) = SF64pred (Prim2SF f6)). +Check (eq_refl (SF64succ (Prim2SF f7)) <: Prim2SF (next_up f7) = SF64succ (Prim2SF f7)). +Check (eq_refl (SF64pred (Prim2SF f7)) <: Prim2SF (next_down f7) = SF64pred (Prim2SF f7)). +Check (eq_refl (SF64succ (Prim2SF f8)) <: Prim2SF (next_up f8) = SF64succ (Prim2SF f8)). +Check (eq_refl (SF64pred (Prim2SF f8)) <: Prim2SF (next_down f8) = SF64pred (Prim2SF f8)). +Check (eq_refl (SF64succ (Prim2SF f9)) <: Prim2SF (next_up f9) = SF64succ (Prim2SF f9)). +Check (eq_refl (SF64pred (Prim2SF f9)) <: Prim2SF (next_down f9) = SF64pred (Prim2SF f9)). +Check (eq_refl (SF64succ (Prim2SF f10)) <: Prim2SF (next_up f10) = SF64succ (Prim2SF f10)). +Check (eq_refl (SF64pred (Prim2SF f10)) <: Prim2SF (next_down f10) = SF64pred (Prim2SF f10)). +Check (eq_refl (SF64succ (Prim2SF f11)) <: Prim2SF (next_up f11) = SF64succ (Prim2SF f11)). +Check (eq_refl (SF64pred (Prim2SF f11)) <: Prim2SF (next_down f11) = SF64pred (Prim2SF f11)). +Check (eq_refl (SF64succ (Prim2SF f12)) <: Prim2SF (next_up f12) = SF64succ (Prim2SF f12)). +Check (eq_refl (SF64pred (Prim2SF f12)) <: Prim2SF (next_down f12) = SF64pred (Prim2SF f12)). +Check (eq_refl (SF64succ (Prim2SF f13)) <: Prim2SF (next_up f13) = SF64succ (Prim2SF f13)). +Check (eq_refl (SF64pred (Prim2SF f13)) <: Prim2SF (next_down f13) = SF64pred (Prim2SF f13)). +Check (eq_refl (SF64succ (Prim2SF f14)) <: Prim2SF (next_up f14) = SF64succ (Prim2SF f14)). +Check (eq_refl (SF64pred (Prim2SF f14)) <: Prim2SF (next_down f14) = SF64pred (Prim2SF f14)). +Check (eq_refl (SF64succ (Prim2SF f15)) <: Prim2SF (next_up f15) = SF64succ (Prim2SF f15)). +Check (eq_refl (SF64pred (Prim2SF f15)) <: Prim2SF (next_down f15) = SF64pred (Prim2SF f15)). + +Check (eq_refl (SF64succ (Prim2SF f0)) <<: Prim2SF (next_up f0) = SF64succ (Prim2SF f0)). +Check (eq_refl (SF64pred (Prim2SF f0)) <<: Prim2SF (next_down f0) = SF64pred (Prim2SF f0)). +Check (eq_refl (SF64succ (Prim2SF f1)) <<: Prim2SF (next_up f1) = SF64succ (Prim2SF f1)). +Check (eq_refl (SF64pred (Prim2SF f1)) <<: Prim2SF (next_down f1) = SF64pred (Prim2SF f1)). +Check (eq_refl (SF64succ (Prim2SF f2)) <<: Prim2SF (next_up f2) = SF64succ (Prim2SF f2)). +Check (eq_refl (SF64pred (Prim2SF f2)) <<: Prim2SF (next_down f2) = SF64pred (Prim2SF f2)). +Check (eq_refl (SF64succ (Prim2SF f3)) <<: Prim2SF (next_up f3) = SF64succ (Prim2SF f3)). +Check (eq_refl (SF64pred (Prim2SF f3)) <<: Prim2SF (next_down f3) = SF64pred (Prim2SF f3)). +Check (eq_refl (SF64succ (Prim2SF f4)) <<: Prim2SF (next_up f4) = SF64succ (Prim2SF f4)). +Check (eq_refl (SF64pred (Prim2SF f4)) <<: Prim2SF (next_down f4) = SF64pred (Prim2SF f4)). +Check (eq_refl (SF64succ (Prim2SF f5)) <<: Prim2SF (next_up f5) = SF64succ (Prim2SF f5)). +Check (eq_refl (SF64pred (Prim2SF f5)) <<: Prim2SF (next_down f5) = SF64pred (Prim2SF f5)). +Check (eq_refl (SF64succ (Prim2SF f6)) <<: Prim2SF (next_up f6) = SF64succ (Prim2SF f6)). +Check (eq_refl (SF64pred (Prim2SF f6)) <<: Prim2SF (next_down f6) = SF64pred (Prim2SF f6)). +Check (eq_refl (SF64succ (Prim2SF f7)) <<: Prim2SF (next_up f7) = SF64succ (Prim2SF f7)). +Check (eq_refl (SF64pred (Prim2SF f7)) <<: Prim2SF (next_down f7) = SF64pred (Prim2SF f7)). +Check (eq_refl (SF64succ (Prim2SF f8)) <<: Prim2SF (next_up f8) = SF64succ (Prim2SF f8)). +Check (eq_refl (SF64pred (Prim2SF f8)) <<: Prim2SF (next_down f8) = SF64pred (Prim2SF f8)). +Check (eq_refl (SF64succ (Prim2SF f9)) <<: Prim2SF (next_up f9) = SF64succ (Prim2SF f9)). +Check (eq_refl (SF64pred (Prim2SF f9)) <<: Prim2SF (next_down f9) = SF64pred (Prim2SF f9)). +Check (eq_refl (SF64succ (Prim2SF f10)) <<: Prim2SF (next_up f10) = SF64succ (Prim2SF f10)). +Check (eq_refl (SF64pred (Prim2SF f10)) <<: Prim2SF (next_down f10) = SF64pred (Prim2SF f10)). +Check (eq_refl (SF64succ (Prim2SF f11)) <<: Prim2SF (next_up f11) = SF64succ (Prim2SF f11)). +Check (eq_refl (SF64pred (Prim2SF f11)) <<: Prim2SF (next_down f11) = SF64pred (Prim2SF f11)). +Check (eq_refl (SF64succ (Prim2SF f12)) <<: Prim2SF (next_up f12) = SF64succ (Prim2SF f12)). +Check (eq_refl (SF64pred (Prim2SF f12)) <<: Prim2SF (next_down f12) = SF64pred (Prim2SF f12)). +Check (eq_refl (SF64succ (Prim2SF f13)) <<: Prim2SF (next_up f13) = SF64succ (Prim2SF f13)). +Check (eq_refl (SF64pred (Prim2SF f13)) <<: Prim2SF (next_down f13) = SF64pred (Prim2SF f13)). +Check (eq_refl (SF64succ (Prim2SF f14)) <<: Prim2SF (next_up f14) = SF64succ (Prim2SF f14)). +Check (eq_refl (SF64pred (Prim2SF f14)) <<: Prim2SF (next_down f14) = SF64pred (Prim2SF f14)). +Check (eq_refl (SF64succ (Prim2SF f15)) <<: Prim2SF (next_up f15) = SF64succ (Prim2SF f15)). +Check (eq_refl (SF64pred (Prim2SF f15)) <<: Prim2SF (next_down f15) = SF64pred (Prim2SF f15)). diff --git a/test-suite/primitive/float/normfr_mantissa.v b/test-suite/primitive/float/normfr_mantissa.v new file mode 100644 index 0000000000..28bd1c03f5 --- /dev/null +++ b/test-suite/primitive/float/normfr_mantissa.v @@ -0,0 +1,28 @@ +Require Import Int63 ZArith Floats. + +Definition half := ldexp one (-1)%Z. +Definition three_quarters := (half + (ldexp one (-2)%Z))%float. + +Check (eq_refl : normfr_mantissa one = 0%int63). +Check (eq_refl : normfr_mantissa half = (1 << 52)%int63). +Check (eq_refl : normfr_mantissa (-half) = (1 << 52)%int63). +Check (eq_refl : normfr_mantissa (-one) = 0%int63). +Check (eq_refl : normfr_mantissa zero = 0%int63). +Check (eq_refl : normfr_mantissa nan = 0%int63). +Check (eq_refl : normfr_mantissa three_quarters = (3 << 51)%int63). + +Check (eq_refl 0%int63 <: normfr_mantissa one = 0%int63). +Check (eq_refl (1 << 52)%int63 <: normfr_mantissa half = (1 << 52)%int63). +Check (eq_refl (1 << 52)%int63 <: normfr_mantissa (-half) = (1 << 52)%int63). +Check (eq_refl 0%int63 <: normfr_mantissa (-one) = 0%int63). +Check (eq_refl 0%int63 <: normfr_mantissa zero = 0%int63). +Check (eq_refl 0%int63 <: normfr_mantissa nan = 0%int63). +Check (eq_refl (3 << 51)%int63 <: normfr_mantissa three_quarters = (3 << 51)%int63). + +Check (eq_refl 0%int63 <<: normfr_mantissa one = 0%int63). +Check (eq_refl (1 << 52)%int63 <<: normfr_mantissa half = (1 << 52)%int63). +Check (eq_refl (1 << 52)%int63 <<: normfr_mantissa (-half) = (1 << 52)%int63). +Check (eq_refl 0%int63 <<: normfr_mantissa (-one) = 0%int63). +Check (eq_refl 0%int63 <<: normfr_mantissa zero = 0%int63). +Check (eq_refl 0%int63 <<: normfr_mantissa nan = 0%int63). +Check (eq_refl (3 << 51)%int63 <<: normfr_mantissa three_quarters = (3 << 51)%int63). diff --git a/test-suite/primitive/float/spec_conv.v b/test-suite/primitive/float/spec_conv.v new file mode 100644 index 0000000000..a610d39671 --- /dev/null +++ b/test-suite/primitive/float/spec_conv.v @@ -0,0 +1,46 @@ +Require Import ZArith Floats. + +Definition two := Eval compute in (one + one)%float. +Definition half := Eval compute in (one / two)%float. +Definition huge := Eval compute in ldexp one (1023)%Z. +Definition tiny := Eval compute in ldexp one (-1023)%Z. +Definition denorm := Eval compute in ldexp one (-1074)%Z. + +Check (eq_refl : SF2Prim (Prim2SF zero) = zero). +Check (eq_refl : SF2Prim (Prim2SF neg_zero) = neg_zero). +Check (eq_refl : SF2Prim (Prim2SF one) = one). +Check (eq_refl : SF2Prim (Prim2SF (-one)) = (-one)%float). +Check (eq_refl : SF2Prim (Prim2SF infinity) = infinity). +Check (eq_refl : SF2Prim (Prim2SF neg_infinity) = neg_infinity). +Check (eq_refl : SF2Prim (Prim2SF huge) = huge). +Check (eq_refl : SF2Prim (Prim2SF tiny) = tiny). +Check (eq_refl : SF2Prim (Prim2SF denorm) = denorm). +Check (eq_refl : SF2Prim (Prim2SF nan) = nan). +Check (eq_refl : SF2Prim (Prim2SF two) = two). +Check (eq_refl : SF2Prim (Prim2SF half) = half). + +Check (eq_refl zero <: SF2Prim (Prim2SF zero) = zero). +Check (eq_refl neg_zero <: SF2Prim (Prim2SF neg_zero) = neg_zero). +Check (eq_refl one <: SF2Prim (Prim2SF one) = one). +Check (eq_refl (-one)%float <: SF2Prim (Prim2SF (-one)) = (-one)%float). +Check (eq_refl infinity <: SF2Prim (Prim2SF infinity) = infinity). +Check (eq_refl neg_infinity <: SF2Prim (Prim2SF neg_infinity) = neg_infinity). +Check (eq_refl huge <: SF2Prim (Prim2SF huge) = huge). +Check (eq_refl tiny <: SF2Prim (Prim2SF tiny) = tiny). +Check (eq_refl denorm <: SF2Prim (Prim2SF denorm) = denorm). +Check (eq_refl nan <: SF2Prim (Prim2SF nan) = nan). +Check (eq_refl two <: SF2Prim (Prim2SF two) = two). +Check (eq_refl half <: SF2Prim (Prim2SF half) = half). + +Check (eq_refl zero <<: SF2Prim (Prim2SF zero) = zero). +Check (eq_refl neg_zero <<: SF2Prim (Prim2SF neg_zero) = neg_zero). +Check (eq_refl one <<: SF2Prim (Prim2SF one) = one). +Check (eq_refl (-one)%float <<: SF2Prim (Prim2SF (-one)) = (-one)%float). +Check (eq_refl infinity <<: SF2Prim (Prim2SF infinity) = infinity). +Check (eq_refl neg_infinity <<: SF2Prim (Prim2SF neg_infinity) = neg_infinity). +Check (eq_refl huge <<: SF2Prim (Prim2SF huge) = huge). +Check (eq_refl tiny <<: SF2Prim (Prim2SF tiny) = tiny). +Check (eq_refl denorm <<: SF2Prim (Prim2SF denorm) = denorm). +Check (eq_refl nan <<: SF2Prim (Prim2SF nan) = nan). +Check (eq_refl two <<: SF2Prim (Prim2SF two) = two). +Check (eq_refl half <<: SF2Prim (Prim2SF half) = half). diff --git a/test-suite/primitive/float/sqrt.v b/test-suite/primitive/float/sqrt.v new file mode 100644 index 0000000000..04c8ab035d --- /dev/null +++ b/test-suite/primitive/float/sqrt.v @@ -0,0 +1,49 @@ +Require Import ZArith Int63 Floats. + +Open Scope float_scope. + +Definition three := Eval compute in of_int63 3%int63. +Definition nine := Eval compute in of_int63 9%int63. + +Check (eq_refl : sqrt nine = three). +Check (eq_refl three <: sqrt nine = three). +Definition compute1 := Eval compute in sqrt nine. +Check (eq_refl : three = three). + +Definition huge := Eval compute in ldexp one (1023)%Z. +Definition tiny := Eval compute in ldexp one (-1023)%Z. +Definition denorm := Eval compute in ldexp one (-1074)%Z. + +Goal (Prim2SF (sqrt huge) = SF64sqrt (Prim2SF huge)). + now compute. Undo. now vm_compute. +Qed. + +Goal (Prim2SF (sqrt tiny) = SF64sqrt (Prim2SF tiny)). + now compute. Undo. now vm_compute. +Qed. + +Goal (Prim2SF (sqrt denorm) = SF64sqrt (Prim2SF denorm)). + now compute. Undo. now vm_compute. +Qed. + +Check (eq_refl : sqrt neg_zero = neg_zero). +Check (eq_refl neg_zero <: sqrt neg_zero = neg_zero). +Check (eq_refl neg_zero <<: sqrt neg_zero = neg_zero). +Check (eq_refl : sqrt zero = zero). +Check (eq_refl zero <: sqrt zero = zero). +Check (eq_refl zero <<: sqrt zero = zero). +Check (eq_refl : sqrt one = one). +Check (eq_refl one <: sqrt one = one). +Check (eq_refl one <<: sqrt one = one). +Check (eq_refl : sqrt (-one) = nan). +Check (eq_refl nan <: sqrt (-one) = nan). +Check (eq_refl nan <<: sqrt (-one) = nan). +Check (eq_refl : sqrt infinity = infinity). +Check (eq_refl infinity <: sqrt infinity = infinity). +Check (eq_refl infinity <<: sqrt infinity = infinity). +Check (eq_refl : sqrt neg_infinity = nan). +Check (eq_refl nan <: sqrt neg_infinity = nan). +Check (eq_refl nan <<: sqrt neg_infinity = nan). +Check (eq_refl : sqrt infinity = infinity). +Check (eq_refl infinity <: sqrt infinity = infinity). +Check (eq_refl infinity <<: sqrt infinity = infinity). diff --git a/test-suite/primitive/float/sub.v b/test-suite/primitive/float/sub.v new file mode 100644 index 0000000000..fc068cb585 --- /dev/null +++ b/test-suite/primitive/float/sub.v @@ -0,0 +1,62 @@ +Require Import ZArith Int63 Floats. + +Open Scope float_scope. + +Definition two := Eval compute in of_int63 2%int63. +Definition three := Eval compute in of_int63 3%int63. + +Check (eq_refl : three - two = one). +Check (eq_refl one <: three - two = one). +Check (eq_refl one <<: three - two = one). +Definition compute1 := Eval compute in three - two. +Check (eq_refl compute1 : one = one). + +Definition huge := Eval compute in ldexp one 1023%Z. +Definition tiny := Eval compute in ldexp one (-1023)%Z. + +Check (eq_refl : huge - tiny = huge). +Check (eq_refl huge <: huge - tiny = huge). +Check (eq_refl huge <<: huge - tiny = huge). +Definition compute2 := Eval compute in huge - tiny. +Check (eq_refl compute2 : huge = huge). + +Check (eq_refl : huge - huge = zero). +Check (eq_refl zero <: huge - huge = zero). +Check (eq_refl zero <<: huge - huge = zero). +Definition compute3 := Eval compute in huge - huge. +Check (eq_refl compute3 : zero = zero). + +Check (eq_refl : one - nan = nan). +Check (eq_refl nan <: one - nan = nan). +Check (eq_refl nan <<: one - nan = nan). +Definition compute4 := Eval compute in one - nan. +Check (eq_refl compute4 : nan = nan). + +Check (eq_refl : infinity - infinity = nan). +Check (eq_refl nan <: infinity - infinity = nan). +Check (eq_refl nan <<: infinity - infinity = nan). +Definition compute5 := Eval compute in infinity - infinity. +Check (eq_refl compute5 : nan = nan). + +Check (eq_refl : infinity - neg_infinity = infinity). +Check (eq_refl infinity <: infinity - neg_infinity = infinity). +Check (eq_refl infinity <<: infinity - neg_infinity = infinity). +Definition compute6 := Eval compute in infinity - neg_infinity. +Check (eq_refl compute6 : infinity = infinity). + +Check (eq_refl : zero - zero = zero). +Check (eq_refl zero <: zero - zero = zero). +Check (eq_refl zero <<: zero - zero = zero). +Check (eq_refl : neg_zero - zero = neg_zero). +Check (eq_refl neg_zero <: neg_zero - zero = neg_zero). +Check (eq_refl neg_zero <<: neg_zero - zero = neg_zero). +Check (eq_refl : neg_zero - neg_zero = zero). +Check (eq_refl zero <: neg_zero - neg_zero = zero). +Check (eq_refl zero <<: neg_zero - neg_zero = zero). +Check (eq_refl : zero - neg_zero = zero). +Check (eq_refl zero <: zero - neg_zero = zero). +Check (eq_refl zero <<: zero - neg_zero = zero). + +Check (eq_refl : huge - neg_infinity = infinity). +Check (eq_refl infinity <: huge - neg_infinity = infinity). +Check (eq_refl infinity <<: huge - neg_infinity = infinity). diff --git a/test-suite/primitive/float/syntax.v b/test-suite/primitive/float/syntax.v new file mode 100644 index 0000000000..cc0bbcf628 --- /dev/null +++ b/test-suite/primitive/float/syntax.v @@ -0,0 +1,13 @@ +Require Import Floats. + +Open Scope float_scope. + +Definition two := Eval compute in one + one. +Definition half := Eval compute in one / two. + +Check (eq_refl : 1.5 = one + half). +Check (eq_refl : 15e-1 = one + half). +Check (eq_refl : 150e-2 = one + half). +Check (eq_refl : 0.15e+1 = one + half). +Check (eq_refl : 0.15e1 = one + half). +Check (eq_refl : 0.0015e3 = one + half). diff --git a/test-suite/primitive/float/valid_binary_conv.v b/test-suite/primitive/float/valid_binary_conv.v new file mode 100644 index 0000000000..82e00b8532 --- /dev/null +++ b/test-suite/primitive/float/valid_binary_conv.v @@ -0,0 +1,46 @@ +Require Import ZArith Floats. + +Definition two := Eval compute in (one + one)%float. +Definition half := Eval compute in (one / two)%float. +Definition huge := Eval compute in ldexp one (1023)%Z. +Definition tiny := Eval compute in ldexp one (-1022)%Z. +Definition denorm := Eval compute in ldexp one (-1074)%Z. + +Check (eq_refl : valid_binary (Prim2SF zero) = true). +Check (eq_refl : valid_binary (Prim2SF neg_zero) = true). +Check (eq_refl : valid_binary (Prim2SF one) = true). +Check (eq_refl : valid_binary (Prim2SF (-one)) = true). +Check (eq_refl : valid_binary (Prim2SF infinity) = true). +Check (eq_refl : valid_binary (Prim2SF neg_infinity) = true). +Check (eq_refl : valid_binary (Prim2SF huge) = true). +Check (eq_refl : valid_binary (Prim2SF tiny) = true). +Check (eq_refl : valid_binary (Prim2SF denorm) = true). +Check (eq_refl : valid_binary (Prim2SF nan) = true). +Check (eq_refl : valid_binary (Prim2SF two) = true). +Check (eq_refl : valid_binary (Prim2SF half) = true). + +Check (eq_refl true <: valid_binary (Prim2SF zero) = true). +Check (eq_refl true <: valid_binary (Prim2SF neg_zero) = true). +Check (eq_refl true <: valid_binary (Prim2SF one) = true). +Check (eq_refl true <: valid_binary (Prim2SF (-one)) = true). +Check (eq_refl true <: valid_binary (Prim2SF infinity) = true). +Check (eq_refl true <: valid_binary (Prim2SF neg_infinity) = true). +Check (eq_refl true <: valid_binary (Prim2SF huge) = true). +Check (eq_refl true <: valid_binary (Prim2SF tiny) = true). +Check (eq_refl true <: valid_binary (Prim2SF denorm) = true). +Check (eq_refl true <: valid_binary (Prim2SF nan) = true). +Check (eq_refl true <: valid_binary (Prim2SF two) = true). +Check (eq_refl true <: valid_binary (Prim2SF half) = true). + +Check (eq_refl true <<: valid_binary (Prim2SF zero) = true). +Check (eq_refl true <<: valid_binary (Prim2SF neg_zero) = true). +Check (eq_refl true <<: valid_binary (Prim2SF one) = true). +Check (eq_refl true <<: valid_binary (Prim2SF (-one)) = true). +Check (eq_refl true <<: valid_binary (Prim2SF infinity) = true). +Check (eq_refl true <<: valid_binary (Prim2SF neg_infinity) = true). +Check (eq_refl true <<: valid_binary (Prim2SF huge) = true). +Check (eq_refl true <<: valid_binary (Prim2SF tiny) = true). +Check (eq_refl true <<: valid_binary (Prim2SF denorm) = true). +Check (eq_refl true <<: valid_binary (Prim2SF nan) = true). +Check (eq_refl true <<: valid_binary (Prim2SF two) = true). +Check (eq_refl true <<: valid_binary (Prim2SF half) = true). diff --git a/test-suite/primitive/float/zero.v b/test-suite/primitive/float/zero.v new file mode 100644 index 0000000000..75348d4657 --- /dev/null +++ b/test-suite/primitive/float/zero.v @@ -0,0 +1,7 @@ +Require Import ZArith Int63 Floats. + +Open Scope float_scope. + +Fail Check (eq_refl : zero = neg_zero). +Fail Check (eq_refl <: zero = neg_zero). +Fail Check (eq_refl <<: zero = neg_zero). diff --git a/test-suite/arithmetic/add.v b/test-suite/primitive/uint63/add.v index fb7eb1d53c..fb7eb1d53c 100644 --- a/test-suite/arithmetic/add.v +++ b/test-suite/primitive/uint63/add.v diff --git a/test-suite/arithmetic/addc.v b/test-suite/primitive/uint63/addc.v index 432aec0291..432aec0291 100644 --- a/test-suite/arithmetic/addc.v +++ b/test-suite/primitive/uint63/addc.v diff --git a/test-suite/arithmetic/addcarryc.v b/test-suite/primitive/uint63/addcarryc.v index a4430769ca..a4430769ca 100644 --- a/test-suite/arithmetic/addcarryc.v +++ b/test-suite/primitive/uint63/addcarryc.v diff --git a/test-suite/arithmetic/addmuldiv.v b/test-suite/primitive/uint63/addmuldiv.v index 72b0164b49..72b0164b49 100644 --- a/test-suite/arithmetic/addmuldiv.v +++ b/test-suite/primitive/uint63/addmuldiv.v diff --git a/test-suite/arithmetic/compare.v b/test-suite/primitive/uint63/compare.v index a8d1ea1226..a8d1ea1226 100644 --- a/test-suite/arithmetic/compare.v +++ b/test-suite/primitive/uint63/compare.v diff --git a/test-suite/arithmetic/div.v b/test-suite/primitive/uint63/div.v index 0ee0b91580..0ee0b91580 100644 --- a/test-suite/arithmetic/div.v +++ b/test-suite/primitive/uint63/div.v diff --git a/test-suite/arithmetic/diveucl.v b/test-suite/primitive/uint63/diveucl.v index 8f88a0f356..8f88a0f356 100644 --- a/test-suite/arithmetic/diveucl.v +++ b/test-suite/primitive/uint63/diveucl.v diff --git a/test-suite/arithmetic/diveucl_21.v b/test-suite/primitive/uint63/diveucl_21.v index b12dba429c..b12dba429c 100644 --- a/test-suite/arithmetic/diveucl_21.v +++ b/test-suite/primitive/uint63/diveucl_21.v diff --git a/test-suite/arithmetic/eqb.v b/test-suite/primitive/uint63/eqb.v index dcc0b71f6d..dcc0b71f6d 100644 --- a/test-suite/arithmetic/eqb.v +++ b/test-suite/primitive/uint63/eqb.v diff --git a/test-suite/arithmetic/head0.v b/test-suite/primitive/uint63/head0.v index f4234d2605..f4234d2605 100644 --- a/test-suite/arithmetic/head0.v +++ b/test-suite/primitive/uint63/head0.v diff --git a/test-suite/arithmetic/isint.v b/test-suite/primitive/uint63/isint.v index c215caa878..c215caa878 100644 --- a/test-suite/arithmetic/isint.v +++ b/test-suite/primitive/uint63/isint.v diff --git a/test-suite/arithmetic/land.v b/test-suite/primitive/uint63/land.v index 0ea6fd90b6..0ea6fd90b6 100644 --- a/test-suite/arithmetic/land.v +++ b/test-suite/primitive/uint63/land.v diff --git a/test-suite/arithmetic/leb.v b/test-suite/primitive/uint63/leb.v index 5354919978..5354919978 100644 --- a/test-suite/arithmetic/leb.v +++ b/test-suite/primitive/uint63/leb.v diff --git a/test-suite/arithmetic/lor.v b/test-suite/primitive/uint63/lor.v index 9c3b85c054..9c3b85c054 100644 --- a/test-suite/arithmetic/lor.v +++ b/test-suite/primitive/uint63/lor.v diff --git a/test-suite/arithmetic/lsl.v b/test-suite/primitive/uint63/lsl.v index 70f3b90140..70f3b90140 100644 --- a/test-suite/arithmetic/lsl.v +++ b/test-suite/primitive/uint63/lsl.v diff --git a/test-suite/arithmetic/lsr.v b/test-suite/primitive/uint63/lsr.v index c36c24e237..c36c24e237 100644 --- a/test-suite/arithmetic/lsr.v +++ b/test-suite/primitive/uint63/lsr.v diff --git a/test-suite/arithmetic/ltb.v b/test-suite/primitive/uint63/ltb.v index 7ae5ac6493..7ae5ac6493 100644 --- a/test-suite/arithmetic/ltb.v +++ b/test-suite/primitive/uint63/ltb.v diff --git a/test-suite/arithmetic/lxor.v b/test-suite/primitive/uint63/lxor.v index b453fc7697..b453fc7697 100644 --- a/test-suite/arithmetic/lxor.v +++ b/test-suite/primitive/uint63/lxor.v diff --git a/test-suite/arithmetic/mod.v b/test-suite/primitive/uint63/mod.v index 5307eed493..5307eed493 100644 --- a/test-suite/arithmetic/mod.v +++ b/test-suite/primitive/uint63/mod.v diff --git a/test-suite/arithmetic/mul.v b/test-suite/primitive/uint63/mul.v index 9480e8cd46..9480e8cd46 100644 --- a/test-suite/arithmetic/mul.v +++ b/test-suite/primitive/uint63/mul.v diff --git a/test-suite/arithmetic/mulc.v b/test-suite/primitive/uint63/mulc.v index e10855bafa..e10855bafa 100644 --- a/test-suite/arithmetic/mulc.v +++ b/test-suite/primitive/uint63/mulc.v diff --git a/test-suite/arithmetic/reduction.v b/test-suite/primitive/uint63/reduction.v index 00e067ac5a..00e067ac5a 100644 --- a/test-suite/arithmetic/reduction.v +++ b/test-suite/primitive/uint63/reduction.v diff --git a/test-suite/arithmetic/sub.v b/test-suite/primitive/uint63/sub.v index 1606fd2aa1..1606fd2aa1 100644 --- a/test-suite/arithmetic/sub.v +++ b/test-suite/primitive/uint63/sub.v diff --git a/test-suite/arithmetic/subc.v b/test-suite/primitive/uint63/subc.v index fc4067e48b..fc4067e48b 100644 --- a/test-suite/arithmetic/subc.v +++ b/test-suite/primitive/uint63/subc.v diff --git a/test-suite/arithmetic/subcarryc.v b/test-suite/primitive/uint63/subcarryc.v index e81b6536b2..e81b6536b2 100644 --- a/test-suite/arithmetic/subcarryc.v +++ b/test-suite/primitive/uint63/subcarryc.v diff --git a/test-suite/arithmetic/tail0.v b/test-suite/primitive/uint63/tail0.v index c9d426087a..c9d426087a 100644 --- a/test-suite/arithmetic/tail0.v +++ b/test-suite/primitive/uint63/tail0.v diff --git a/test-suite/arithmetic/unsigned.v b/test-suite/primitive/uint63/unsigned.v index 82920bd201..82920bd201 100644 --- a/test-suite/arithmetic/unsigned.v +++ b/test-suite/primitive/uint63/unsigned.v diff --git a/test-suite/ssr/over.v b/test-suite/ssr/over.v index 8232741b0d..267d981d05 100644 --- a/test-suite/ssr/over.v +++ b/test-suite/ssr/over.v @@ -12,7 +12,7 @@ assert (H : forall i : nat, i + 2 * i - i = x2 i). unfold x2 in *; clear x2; unfold R in *; clear R; unfold I in *; clear I. - apply Under_eq_from_eq. + apply Under_rel_from_rel. Fail done. over. @@ -27,7 +27,7 @@ assert (H : forall i : nat, i + 2 * i - i = x2 i). unfold x2 in *; clear x2; unfold R in *; clear R; unfold I in *; clear I. - apply Under_eq_from_eq. + apply Under_rel_from_rel. Fail done. by rewrite over. @@ -45,7 +45,7 @@ assert (H : forall i j, i + 2 * j - i = x2 i j). unfold R in *; clear R; unfold J in *; clear J; unfold I in *; clear I. - apply Under_eq_from_eq. + apply Under_rel_from_rel. Fail done. over. @@ -61,7 +61,7 @@ assert (H : forall i j : nat, i + 2 * j - i = x2 i j). unfold R in *; clear R; unfold J in *; clear J; unfold I in *; clear I. - apply Under_eq_from_eq. + apply Under_rel_from_rel. Fail done. rewrite over. diff --git a/test-suite/ssr/under.v b/test-suite/ssr/under.v index f285ad138b..c12491138a 100644 --- a/test-suite/ssr/under.v +++ b/test-suite/ssr/under.v @@ -160,7 +160,15 @@ Lemma test_big_occs (F G : nat -> nat) (n : nat) : \sum_(0 <= i < n) (i * 0) = \sum_(0 <= i < n) (i * 0) + \sum_(0 <= i < n) (i * 0). Proof. under {2}[in RHS]eq_bigr => i Hi do rewrite muln0. -by rewrite big_const_nat iter_addn_0. +by rewrite big_const_nat iter_addn_0 mul0n addn0. +Qed. + +Lemma test_big_occs_inH (F G : nat -> nat) (n : nat) : + \sum_(0 <= i < n) (i * 0) = \sum_(0 <= i < n) (i * 0) + \sum_(0 <= i < n) (i * 0) -> True. +Proof. +move=> H. +do [under {2}[in RHS]eq_bigr => i Hi do rewrite muln0] in H. +by rewrite big_const_nat iter_addn_0 mul0n addn0 in H. Qed. (* Solely used, one such renaming is useless in practice, but it works anyway *) @@ -218,7 +226,6 @@ under Lub_Rbar_eqset => r. by rewrite over. Abort. - Lemma ex_iff R (P1 P2 : R -> Prop) : (forall x : R, P1 x <-> P2 x) -> ((exists x, P1 x) <-> (exists x, P2 x)). Proof. @@ -227,8 +234,149 @@ Qed. Arguments ex_iff [R P1] P2 iffP12. -Require Import Setoid. +(** Load the [setoid_rewrite] machinery *) +Require Setoid. + +(** Replay the tactics from [test_Lub_Rbar] in this new environment *) +Lemma test_Lub_Rbar_again (E : R -> Prop) : + Rbar_le Rbar0 (Lub_Rbar (fun x => x = R0 \/ E x)). +Proof. +under Lub_Rbar_eqset => r. +by rewrite over. +Abort. + Lemma test_ex_iff (P : nat -> Prop) : (exists x, P x) -> True. -under ex_iff => n. +under ex_iff => n. (* this requires [Setoid] *) by rewrite over. +by move=> _. +Qed. + +Section TestGeneric. +Context {A B : Type} {R : nat -> B -> B -> Prop} + `{!forall n : nat, RelationClasses.Equivalence (R n)}. +Variables (F : (A -> A -> B) -> B). +Hypothesis ex_gen : forall (n : nat) (P1 P2 : A -> A -> B), + (forall x y : A, R n (P1 x y) (P2 x y)) -> (R n (F P1) (F P2)). +Arguments ex_gen [n P1] P2 relP12. +Lemma test_ex_gen (P1 P2 : A -> A -> B) (n : nat) : + (forall x y : A, P2 x y = P2 y x) -> + R n (F P1) (F P2) /\ True -> True. +Proof. +move=> P2C. +under [X in R _ _ X]ex_gen => a b. + by rewrite P2C over. +by move => _. +Qed. +End TestGeneric. + +Import Setoid. +(* to expose [Coq.Relations.Relation_Definitions.reflexive], + [Coq.Classes.RelationClasses.RewriteRelation], and so on. *) + +Section TestGeneric2. +(* Some toy abstract example with a parameterized setoid type *) +Record Setoid (m n : nat) : Type := + { car : Type + ; Rel : car -> car -> Prop + ; refl : reflexive _ Rel + ; sym : symmetric _ Rel + ; trans : transitive _ Rel + }. + +Context {m n : nat}. +Add Parametric Relation (s : Setoid m n) : (car s) (@Rel _ _ s) + reflexivity proved by (@refl _ _ s) + symmetry proved by (@sym _ _ s) + transitivity proved by (@trans _ _ s) + as eq_rel. + +Context {A : Type} {s1 s2 : Setoid m n}. + +Let B := @car m n s1. +Let C := @car m n s2. +Variable (F : C -> (A -> A -> B) -> C). +Hypothesis rel2_gen : + forall (c1 c2 : C) (P1 P2 : A -> A -> B), + Rel c1 c2 -> + (forall a b : A, Rel (P1 a b) (P2 a b)) -> + Rel (F c1 P1) (F c2 P2). +Arguments rel2_gen [c1] c2 [P1] P2 relc12 relP12. +Lemma test_rel2_gen (c : C) (P : A -> A -> B) + (toy_hyp : forall a b, P a b = P b a) : + Rel (F c P) (F c (fun a b => P b a)). +Proof. +under [here in Rel _ here]rel2_gen. +- over. +- by move=> a b; rewrite toy_hyp over. +- reflexivity. +Qed. +End TestGeneric2. + +Section TestPreOrder. +(* inspired by https://github.com/coq/coq/pull/10022#issuecomment-530101950 + but without needing to do [rewrite UnderE] manually. *) + +Require Import Morphisms. + +(** Tip to tell rewrite that the LHS of [leq' x y (:= leq x y = true)] + is x, not [leq x y] *) +Definition rel_true {T} (R : rel T) x y := is_true (R x y). +Definition leq' : nat -> nat -> Prop := rel_true leq. + +Parameter leq_add : + forall m1 m2 n1 n2 : nat, m1 <= n1 -> m2 <= n2 -> m1 + m2 <= n1 + n2. +Parameter leq_mul : + forall m1 m2 n1 n2 : nat, m1 <= n1 -> m2 <= n2 -> m1 * m2 <= n1 * n2. + +Local Notation "+%N" := addn (at level 0, only parsing). + +(** Context lemma (could *) +Lemma leq'_big : forall I (F G : I -> nat) (r : seq I), + (forall i : I, leq' (F i) (G i)) -> + (leq' (\big[+%N/0%N]_(i <- r) F i) (\big[+%N/0%N]_(i <- r) G i)). +Proof. +red=> F G m n HFG. +apply: (big_ind2 leq _ _ (P := xpredT) (op1 := addn) (op2 := addn)) =>//. +move=> *; exact: leq_add. +move=> *; exact: HFG. +Qed. + +(** Instances for [setoid_rewrite] *) +Instance leq'_rr : RewriteRelation leq' := {}. + +Instance leq'_proper_addn : Proper (leq' ==> leq' ==> leq') addn. +Proof. move=> a1 b1 le1 a2 b2 le2; exact/leq_add. Qed. + +Instance leq'_proper_muln : Proper (leq' ==> leq' ==> leq') muln. +Proof. move=> a1 b1 le1 a2 b2 le2; exact/leq_mul. Qed. + + +Instance leq'_preorder : PreOrder leq'. +(** encompasses [Reflexive] *) +Proof. rewrite /leq' /rel_true; split =>// ??? A B; exact: leq_trans A B. Qed. + +Instance leq'_reflexive : Reflexive leq'. +Proof. by rewrite /leq' /rel_true. Qed. + +Parameter leq_add2l : + forall p m n : nat, (p + m <= p + n) = (m <= n). + +Lemma test : forall n : nat, + (1 + 2 * (\big[+%N/0]_(i < n) (3 + i)) * 4 + 5 <= 6 + 24 * n + 8 * n * n)%N. +Proof. +move=> n; rewrite -[is_true _]/(rel_true _ _ _) -/leq'. +have lem : forall (i : nat), i < n -> leq' (3 + i) (3 + n). +{ by move=> i Hi; rewrite /leq' /rel_true leq_add2l; apply/ltnW. } + +under leq'_big => i. +{ + (* The "magic" is here: instantiate the evar with the bound "3 + n" *) + rewrite lem ?ltn_ord //. over. +} +cbv beta. + +now_show (leq' (1 + 2 * \big[+%N/0]_(i < n) (3 + n) * 4 + 5) (6 + 24 * n + 8 * n * n)). +(* uninteresting end of proof, omitted *) Abort. + +End TestPreOrder. diff --git a/test-suite/vos/A.v b/test-suite/vos/A.v new file mode 100644 index 0000000000..11245ba015 --- /dev/null +++ b/test-suite/vos/A.v @@ -0,0 +1,4 @@ +Definition x := 3. + +Lemma xeq : x = x. +Proof. auto. Qed. diff --git a/test-suite/vos/B.v b/test-suite/vos/B.v new file mode 100644 index 0000000000..735fefd745 --- /dev/null +++ b/test-suite/vos/B.v @@ -0,0 +1,34 @@ +Require Import A. + +Definition y := x. + +Lemma yeq : y = y. +Proof. pose xeq. auto. Qed. + + +Section Foo. + +Variable (HFalse : False). + +Lemma yeq' : y = y. +Proof using HFalse. elimtype False. apply HFalse. Qed. + +End Foo. + +Module Type E. End E. + +Module M. + Lemma x : True. + Proof. trivial. Qed. +End M. + + +Module Type T. + Lemma x : True. + Proof. trivial. Qed. +End T. + +Module F(X:E). + Lemma x : True. + Proof. trivial. Qed. +End F. diff --git a/test-suite/vos/C.v b/test-suite/vos/C.v new file mode 100644 index 0000000000..5260b7cdaf --- /dev/null +++ b/test-suite/vos/C.v @@ -0,0 +1,13 @@ +Require Import A B. + +Definition z := x + y. + +Lemma zeq : z = z. +Proof. pose xeq. pose yeq. auto. Qed. + +Lemma yeq'' : y = y. +Proof. apply yeq'. Admitted. + +Module M. Include B.M. End M. +Module T. Include B.T. End T. +Module F. Include B.F. End F. diff --git a/test-suite/vos/run.sh b/test-suite/vos/run.sh new file mode 100755 index 0000000000..2496fc8602 --- /dev/null +++ b/test-suite/vos/run.sh @@ -0,0 +1,23 @@ +#!/bin/bash +set -e +set -o pipefail +export PATH="$COQBIN:$PATH" + +# Clean +rm -f *.vo *.vos *.vok *.glob *.aux Makefile + +# Test building all vos, then all vok +coq_makefile -R . TEST -o Makefile *.v +make vos +make vok + +# Cleanup +make clean + +# Test using compilation in custom order +set -x #echo on +coqc A.v +coqc -vos B.v +coqc -vos C.v +coqc -vok B.v +coqc -vok C.v diff --git a/theories/Floats/FloatAxioms.v b/theories/Floats/FloatAxioms.v new file mode 100644 index 0000000000..8ca64aac42 --- /dev/null +++ b/theories/Floats/FloatAxioms.v @@ -0,0 +1,58 @@ +Require Import ZArith Int63 SpecFloat PrimFloat FloatOps. + +(** * Properties of the primitive operators for the Binary64 format *) + +Notation valid_binary := (valid_binary prec emax). + +Definition SF64classify := SFclassify prec. +Definition SF64mul := SFmul prec emax. +Definition SF64add := SFadd prec emax. +Definition SF64sub := SFsub prec emax. +Definition SF64div := SFdiv prec emax. +Definition SF64sqrt := SFsqrt prec emax. +Definition SF64succ := SFsucc prec emax. +Definition SF64pred := SFpred prec emax. + +Axiom Prim2SF_valid : forall x, valid_binary (Prim2SF x) = true. +Axiom SF2Prim_Prim2SF : forall x, SF2Prim (Prim2SF x) = x. +Axiom Prim2SF_SF2Prim : forall x, valid_binary x = true -> Prim2SF (SF2Prim x) = x. + +Theorem Prim2SF_inj : forall x y, Prim2SF x = Prim2SF y -> x = y. + intros. rewrite <- SF2Prim_Prim2SF. symmetry. rewrite <- SF2Prim_Prim2SF. now rewrite H. +Qed. + +Theorem SF2Prim_inj : forall x y, SF2Prim x = SF2Prim y -> valid_binary x = true -> valid_binary y = true -> x = y. + intros. rewrite <- Prim2SF_SF2Prim by assumption. symmetry. rewrite <- Prim2SF_SF2Prim by assumption. rewrite H. reflexivity. +Qed. + +Axiom opp_spec : forall x, Prim2SF (-x)%float = SFopp (Prim2SF x). +Axiom abs_spec : forall x, Prim2SF (abs x) = SFabs (Prim2SF x). + +Axiom eqb_spec : forall x y, (x == y)%float = SFeqb (Prim2SF x) (Prim2SF y). +Axiom ltb_spec : forall x y, (x < y)%float = SFltb (Prim2SF x) (Prim2SF y). +Axiom leb_spec : forall x y, (x <= y)%float = SFleb (Prim2SF x) (Prim2SF y). + +Definition flatten_cmp_opt c := + match c with + | None => FNotComparable + | Some Eq => FEq + | Some Lt => FLt + | Some Gt => FGt + end. +Axiom compare_spec : forall x y, (x ?= y)%float = flatten_cmp_opt (SFcompare (Prim2SF x) (Prim2SF y)). + +Axiom classify_spec : forall x, classify x = SF64classify (Prim2SF x). +Axiom mul_spec : forall x y, Prim2SF (x * y)%float = SF64mul (Prim2SF x) (Prim2SF y). +Axiom add_spec : forall x y, Prim2SF (x + y)%float = SF64add (Prim2SF x) (Prim2SF y). +Axiom sub_spec : forall x y, Prim2SF (x - y)%float = SF64sub (Prim2SF x) (Prim2SF y). +Axiom div_spec : forall x y, Prim2SF (x / y)%float = SF64div (Prim2SF x) (Prim2SF y). +Axiom sqrt_spec : forall x, Prim2SF (sqrt x) = SF64sqrt (Prim2SF x). + +Axiom of_int63_spec : forall n, Prim2SF (of_int63 n) = binary_normalize prec emax (to_Z n) 0%Z false. +Axiom normfr_mantissa_spec : forall f, to_Z (normfr_mantissa f) = Z.of_N (SFnormfr_mantissa prec (Prim2SF f)). + +Axiom frshiftexp_spec : forall f, let (m,e) := frshiftexp f in (Prim2SF m, ((to_Z e) - shift)%Z) = SFfrexp prec emax (Prim2SF f). +Axiom ldshiftexp_spec : forall f e, Prim2SF (ldshiftexp f e) = SFldexp prec emax (Prim2SF f) ((to_Z e) - shift). + +Axiom next_up_spec : forall x, Prim2SF (next_up x) = SF64succ (Prim2SF x). +Axiom next_down_spec : forall x, Prim2SF (next_down x) = SF64pred (Prim2SF x). diff --git a/theories/Floats/FloatClass.v b/theories/Floats/FloatClass.v new file mode 100644 index 0000000000..627cb648f9 --- /dev/null +++ b/theories/Floats/FloatClass.v @@ -0,0 +1,2 @@ +Variant float_class : Set := + | PNormal | NNormal | PSubn | NSubn | PZero | NZero | PInf | NInf | NaN. diff --git a/theories/Floats/FloatLemmas.v b/theories/Floats/FloatLemmas.v new file mode 100644 index 0000000000..81cb7120e0 --- /dev/null +++ b/theories/Floats/FloatLemmas.v @@ -0,0 +1,319 @@ +Require Import ZArith Int63 SpecFloat PrimFloat FloatOps FloatAxioms. +Require Import Psatz. + +(** * Support results involving frexp and ldexp *) + +Lemma shift_value : shift = (2*emax + prec)%Z. + reflexivity. +Qed. + +Theorem frexp_spec : forall f, let (m,e) := frexp f in (Prim2SF m, e) = SFfrexp prec emax (Prim2SF f). + intro. + unfold frexp. + case_eq (frshiftexp f). + intros. + assert (H' := frshiftexp_spec f). + now rewrite H in H'. +Qed. + +Theorem ldexp_spec : forall f e, Prim2SF (ldexp f e) = SFldexp prec emax (Prim2SF f) e. + intros. + unfold ldexp. + rewrite (ldshiftexp_spec f _). + assert (Hv := Prim2SF_valid f). + destruct (Prim2SF f); auto. + unfold SFldexp. + unfold binary_round. + assert (Hmod_elim : forall e, ([| of_Z (Z.max (Z.min e (emax - emin)) (emin - emax - 1) + shift)|]%int63 - shift = Z.max (Z.min e (emax - emin)) (emin - emax - 1))%Z). + { + intro e1. + rewrite of_Z_spec, shift_value. + unfold wB, size; simpl. + unfold Z.pow_pos; simpl. + set (n := Z.max (Z.min _ _) _). + set (wB := 9223372036854775808%Z). (* Z.pow_pos 2 63 *) + assert (-2099 <= n <= 2098)%Z by (unfold n; lia). + rewrite Z.mod_small by (unfold wB; lia). + now rewrite Z.add_simpl_r. + } + rewrite Hmod_elim. + clear Hmod_elim. + revert Hv. + unfold valid_binary, bounded, canonical_mantissa. + unfold fexp. + rewrite Bool.andb_true_iff. + intro H'. + destruct H' as (H1,H2). + apply Zeq_bool_eq in H1. + apply Z.max_case_strong. + apply Z.min_case_strong. + - reflexivity. + - intros He _. + destruct (Z.max_spec (Z.pos (digits2_pos m) + e0 - prec) emin) as [ (H, Hm) | (H, Hm) ]. + + rewrite Hm in H1. + rewrite <- H1. + rewrite !Z.max_l by (revert He; unfold emax, emin, prec; lia). + replace (emin + _)%Z with emax by ring. + unfold shl_align. + rewrite <- H1 in H. + replace (Z.pos _ + _ - _ - _)%Z with (Z.pos (digits2_pos m) - prec)%Z by ring. + remember (Zpos _ - _)%Z as z'. + destruct z' ; [ lia | lia | ]. + unfold binary_round_aux. + unfold shr_fexp. + unfold fexp. + unfold Zdigits2. + unfold shr_record_of_loc, shr. + rewrite !Z.max_l by (revert H He; unfold emax, emin, prec; lia). + replace (_ - _)%Z with (Z.pos (digits2_pos (shift_pos p m)) - prec)%Z by ring. + assert (Hs : (Z.pos (digits2_pos (shift_pos p m)) <= prec)%Z). + { + assert (H' : forall p p', digits2_pos (shift_pos p p') = (digits2_pos p' + p)%positive). + { + induction p0. + intro p'. + simpl. + rewrite IHp0. + rewrite IHp0. + lia. + intro p'. + simpl. + rewrite IHp0. + rewrite IHp0. + lia. + intro p'. + simpl. + lia. + } + rewrite H'. + lia. + } + replace (Z.pos (digits2_pos m) + (emin + e) - prec - (emin + e))%Z with (Z.neg p) by lia. + unfold shr_m, loc_of_shr_record. + unfold round_nearest_even. + remember (Z.pos (digits2_pos (shift_pos p m)) - prec)%Z as ds. + destruct ds. + * rewrite Z.max_l by (revert He; unfold emax, emin, prec; lia). + replace (_ - _)%Z with Z0 by lia. + replace (_ <=? _)%Z with false by (symmetry; rewrite Z.leb_gt; lia). + rewrite Z.max_l by (revert He; unfold emax, emin, prec; lia). + replace (_ - _)%Z with Z0 by lia. + rewrite Z.max_l by (revert He; unfold emax, emin, prec; lia). + replace (_ - _)%Z with Z0 by lia. + replace (_ <=? _)%Z with false by (symmetry; rewrite Z.leb_gt; lia). + reflexivity. + * exfalso; lia. + * rewrite Z.max_l by (revert He; unfold emax, emin, prec; lia). + replace (_ - _)%Z with (Zneg p0) by lia. + replace (_ <=? _)%Z with false by (symmetry; rewrite Z.leb_gt; lia). + rewrite Z.max_l by (revert He; unfold emax, emin, prec; lia). + replace (_ - _)%Z with (Zneg p0) by lia. + rewrite Z.max_l by (revert He; unfold emax, emin, prec; lia). + replace (_ - _)%Z with (Zneg p0) by lia. + replace (_ <=? _)%Z with false by (symmetry; rewrite Z.leb_gt; lia). + reflexivity. + + rewrite !Z.max_l by (revert H He; unfold emax, emin, prec; lia). + rewrite Hm in H1. + clear Hm. + replace (Zpos _ + _ - _)%Z with (e0 + (emax - emin))%Z by (rewrite <- H1 at 1; ring). + replace (Zpos _ + _ - _)%Z with (e0 + e)%Z by (rewrite <- H1 at 1; ring). + unfold shl_align. + replace (_ - _)%Z with Z0 by ring. + replace (e0 + e - _)%Z with Z0 by ring. + unfold binary_round_aux. + unfold shr_fexp. + unfold fexp. + unfold Zdigits2. + rewrite !Z.max_l by (revert H He; unfold emax, emin, prec; lia). + unfold shr_record_of_loc. + unfold shr. + unfold Zdigits2. + replace (Zpos _ + _ - _ - _)%Z with Z0 by lia. + unfold shr_m. + unfold loc_of_shr_record. + unfold round_nearest_even. + rewrite Z.max_l by (revert H He; unfold emax, emin, prec; lia). + replace (Zpos _ + _ - _ - _)%Z with Z0 by lia. + replace (_ <=? _)%Z with false by (symmetry; rewrite Z.leb_gt; lia). + replace (Zpos _ + _ - _ - _)%Z with Z0 by lia. + rewrite Z.max_l by (revert H He; unfold emax, emin, prec; lia). + replace (Zpos _ + _ - _ - _)%Z with Z0 by lia. + replace (_ <=? _)%Z with false by (symmetry; rewrite Z.leb_gt; lia). + reflexivity. + - rewrite Z.min_le_iff. + intro H. + destruct H as [ He | Habs ]; [ | revert Habs; now unfold emin, emax ]. + unfold shl_align. + assert (Hprec : (Z.pos (digits2_pos m) <= prec)%Z). + { + destruct (Z.max_spec (Z.pos (digits2_pos m) + e0 - prec) emin) as [ (Hpi, Hpe) | (Hpi, Hpe) ]; rewrite Hpe in H1; lia. + } + + assert (Hshr : forall p s, Zdigits2 (shr_m (iter_pos shr_1 p s)) = Z.max Z0 (Zdigits2 (shr_m s) - Z.pos p)%Z). + { + assert (Hshr1 : forall s, Zdigits2 (shr_m (shr_1 s)) = Z.max 0 (Zdigits2 (shr_m s) - 1)%Z). + { + intro s0. + destruct s0. + unfold shr_1. + destruct shr_m; try (simpl; lia). + - destruct p; unfold Zdigits2, shr_m, digits2_pos; lia. + - destruct p; unfold Zdigits2, shr_m, digits2_pos; lia. + } + induction p. + simpl. + intro s0. + do 2 rewrite IHp. + rewrite Hshr1. + lia. + intros. + simpl. + do 2 rewrite IHp. + lia. + apply Hshr1. + } + + assert (Hd0 : forall z, Zdigits2 z = 0%Z -> z = 0%Z). + { + intro z. + unfold Zdigits2. + now destruct z. + } + + assert (Hshr_p0 : forall p0, (prec < Z.pos p0)%Z -> shr_m (iter_pos shr_1 p0 {| shr_m := Z.pos m; shr_r := false; shr_s := false |}) = Z0). + { + intros p0 Hp0. + apply Hd0. + rewrite Hshr. + rewrite Z.max_l; [ reflexivity | ]. + unfold shr_m. + unfold Zdigits2. + lia. + } + + assert (Hshr_p0_r : forall p0, (prec < Z.pos p0)%Z -> shr_r (iter_pos shr_1 p0 {| shr_m := Z.pos m; shr_r := false; shr_s := false |}) = false). + { + intros p0 Hp0. + + assert (Hshr_p0m1 : shr_m (iter_pos shr_1 (p0-1) {| shr_m := Z.pos m; shr_r := false; shr_s := false |}) = Z0). + { + apply Hd0. + rewrite Hshr. + rewrite Z.max_l; [ reflexivity | ]. + unfold shr_m. + unfold Zdigits2. + lia. + } + + assert (Hiter_pos : forall A (f : A -> A) p e, iter_pos f (p + 1) e = f (iter_pos f p e)). + { + assert (Hiter_pos' : forall A (f : A -> A) p e, iter_pos f p (f e) = f (iter_pos f p e)). + { + intros A f'. + induction p. + intro e'. + simpl. + now do 2 rewrite IHp. + intro e'. + simpl. + now do 2 rewrite IHp. + intro e'. + now simpl. + } + intros A f'. + induction p. + intros. + simpl. + rewrite <- Pos.add_1_r. + do 2 rewrite IHp. + now do 3 rewrite Hiter_pos'. + intros. + simpl. + now do 2 rewrite Hiter_pos'. + intros. + now simpl. + } + replace p0 with (p0 - 1 + 1)%positive. + rewrite Hiter_pos. + unfold shr_1 at 1. + remember (iter_pos _ _ _) as shr_p0m1. + destruct shr_p0m1. + unfold SpecFloat.shr_m in Hshr_p0m1. + now rewrite Hshr_p0m1. + rewrite Pos.add_1_r. + rewrite Pos.sub_1_r. + apply Pos.succ_pred. + lia. + } + + rewrite Z.leb_le in H2. + + destruct (Z.max_spec (Z.pos (digits2_pos m) + (e0 + (emin - emax - 1)) - prec) emin) as [ (H, Hm) | (H, Hm) ]. + + rewrite Hm. + replace (_ - _)%Z with (emax - e0 + 1)%Z by ring. + remember (emax - e0 + 1)%Z as z'. + destruct z'; [ exfalso; lia | | exfalso; lia ]. + unfold binary_round_aux. + unfold shr_fexp, fexp. + unfold shr, shr_record_of_loc. + unfold Zdigits2. + rewrite Hm. + replace (_ - _)%Z with (Z.pos p) by (rewrite Heqz'; ring). + set (rne := round_nearest_even _ _). + assert (rne = 0%Z). + { + unfold rne. + unfold round_nearest_even. + + assert (Hp0 : (prec < Z.pos p)%Z) by lia. + + unfold loc_of_shr_record. + specialize (Hshr_p0_r _ Hp0). + specialize (Hshr_p0 _ Hp0). + revert Hshr_p0_r Hshr_p0. + set (shr_p0 := iter_pos shr_1 _ _). + destruct shr_p0. + unfold SpecFloat.shr_r, SpecFloat.shr_m. + intros Hshr_r Hshr_m. + rewrite Hshr_r, Hshr_m. + now destruct shr_s. + } + + rewrite H0. + rewrite Z.max_r by (rewrite Heqz'; unfold prec; lia). + replace (_ - _)%Z with 0%Z by lia. + unfold shr_m. + + rewrite Z.max_r by lia. + remember (emin - (e0 + e))%Z as eminmze. + destruct eminmze; [ exfalso; lia | | exfalso; lia ]. + + rewrite Z.max_r by lia. + rewrite <- Heqeminmze. + + set (rne' := round_nearest_even _ _). + assert (Hrne'0 : rne' = 0%Z). + { + unfold rne'. + unfold round_nearest_even. + + assert (Hp1 : (prec < Z.pos p0)%Z) by lia. + + unfold loc_of_shr_record. + specialize (Hshr_p0_r _ Hp1). + specialize (Hshr_p0 _ Hp1). + revert Hshr_p0_r Hshr_p0. + set (shr_p1 := iter_pos shr_1 _ _). + destruct shr_p1. + unfold SpecFloat.shr_r, SpecFloat.shr_m. + intros Hshr_r Hshr_m. + rewrite Hshr_r, Hshr_m. + now destruct shr_s. + } + + rewrite Hrne'0. + rewrite Z.max_r by (rewrite Heqeminmze; unfold prec; lia). + replace (_ - _)%Z with 0%Z by lia. + reflexivity. + + exfalso; lia. +Qed. diff --git a/theories/Floats/FloatOps.v b/theories/Floats/FloatOps.v new file mode 100644 index 0000000000..f0d3bcced9 --- /dev/null +++ b/theories/Floats/FloatOps.v @@ -0,0 +1,48 @@ +Require Import ZArith Int63 SpecFloat PrimFloat. + +(** * Derived operations and mapping between primitive [float]s and [spec_float]s *) + +Definition prec := 53%Z. +Definition emax := 1024%Z. +Notation emin := (emin prec emax). + +Definition shift := 2101%Z. (** [= 2*emax + prec] *) + +Definition frexp f := + let (m, se) := frshiftexp f in + (m, ([| se |] - shift)%Z%int63). + +Definition ldexp f e := + let e' := Z.max (Z.min e (emax - emin)) (emin - emax - 1) in + ldshiftexp f (of_Z (e' + shift)). + +Definition ulp f := ldexp one (fexp prec emax (snd (frexp f))). + +(** [Prim2SF] is an injective function that will be useful to express +the properties of the implemented Binary64 format (see [FloatAxioms]). +*) +Definition Prim2SF f := + if is_nan f then S754_nan + else if is_zero f then S754_zero (get_sign f) + else if is_infinity f then S754_infinity (get_sign f) + else + let (r, exp) := frexp f in + let e := (exp - prec)%Z in + let (shr, e') := shr_fexp prec emax [| normfr_mantissa r |]%int63 e loc_Exact in + match shr_m shr with + | Zpos p => S754_finite (get_sign f) p e' + | Zneg _ | Z0 => S754_zero false (* must never occur *) + end. + +Definition SF2Prim ef := + match ef with + | S754_nan => nan + | S754_zero false => zero + | S754_zero true => neg_zero + | S754_infinity false => infinity + | S754_infinity true => neg_infinity + | S754_finite s m e => + let pm := of_int63 (of_Z (Zpos m)) in + let f := ldexp pm e in + if s then (-f)%float else f + end. diff --git a/theories/Floats/Floats.v b/theories/Floats/Floats.v new file mode 100644 index 0000000000..700c69b99d --- /dev/null +++ b/theories/Floats/Floats.v @@ -0,0 +1,17 @@ +(** The Floats library is split in 6 theories: +- FloatClass: define the [float_class] inductive +- PrimFloat: define the floating-point values and operators as kernel primitives +- SpecFloat: specify the floating-point operators with binary integers +- FloatOps: define conversion functions between [spec_float] and [float] +- FloatAxioms: state properties of the primitive operators w.r.t. [spec_float] +- FloatLemmas: prove a few results involving frexp and ldexp + +For a brief overview of the Floats library, +see {{https://coq.inria.fr/distrib/current/refman/language/coq-library.html#floats-library}} *) + +Require Export FloatClass. +Require Export PrimFloat. +Require Export SpecFloat. +Require Export FloatOps. +Require Export FloatAxioms. +Require Export FloatLemmas. diff --git a/theories/Floats/PrimFloat.v b/theories/Floats/PrimFloat.v new file mode 100644 index 0000000000..bc1727469d --- /dev/null +++ b/theories/Floats/PrimFloat.v @@ -0,0 +1,118 @@ +Require Import Int63 FloatClass. + +(** * Definition of the interface for primitive floating-point arithmetic + +This interface provides processor operators for the Binary64 format of the +IEEE 754-2008 standard. *) + +(** ** Type definition for the co-domain of [compare] *) +Variant float_comparison : Set := FEq | FLt | FGt | FNotComparable. + +Register float_comparison as kernel.ind_f_cmp. + +Register float_class as kernel.ind_f_class. + +(** ** The main type *) +(** [float]: primitive type for Binary64 floating-point numbers. *) +Primitive float := #float64_type. + +(** ** Syntax support *) +Declare Scope float_scope. +Delimit Scope float_scope with float. +Bind Scope float_scope with float. + +Declare ML Module "float_syntax_plugin". + +(** ** Floating-point operators *) +Primitive classify := #float64_classify. + +Primitive abs := #float64_abs. + +Primitive sqrt := #float64_sqrt. + +Primitive opp := #float64_opp. +Notation "- x" := (opp x) : float_scope. + +Primitive eqb := #float64_eq. +Notation "x == y" := (eqb x y) (at level 70, no associativity) : float_scope. + +Primitive ltb := #float64_lt. +Notation "x < y" := (ltb x y) (at level 70, no associativity) : float_scope. + +Primitive leb := #float64_le. +Notation "x <= y" := (leb x y) (at level 70, no associativity) : float_scope. + +Primitive compare := #float64_compare. +Notation "x ?= y" := (compare x y) (at level 70, no associativity) : float_scope. + +Primitive mul := #float64_mul. +Notation "x * y" := (mul x y) : float_scope. + +Primitive add := #float64_add. +Notation "x + y" := (add x y) : float_scope. + +Primitive sub := #float64_sub. +Notation "x - y" := (sub x y) : float_scope. + +Primitive div := #float64_div. +Notation "x / y" := (div x y) : float_scope. + +(** ** Conversions *) + +(** [of_int63]: convert a primitive integer into a float value. + The value is rounded if need be. *) +Primitive of_int63 := #float64_of_int63. + +(** Specification of [normfr_mantissa]: +- If the input is a float value with an absolute value inside $[0.5, 1.)$#[0.5, 1.)#; +- Then return its mantissa as a primitive integer. + The mantissa will be a 53-bit integer with its most significant bit set to 1; +- Else return zero. + +The sign bit is always ignored. *) +Primitive normfr_mantissa := #float64_normfr_mantissa. + +(** ** Exponent manipulation functions *) +(** [frshiftexp]: convert a float to fractional part in $[0.5, 1.)$#[0.5, 1.)# +and integer part. *) +Primitive frshiftexp := #float64_frshiftexp. + +(** [ldshiftexp]: multiply a float by an integral power of 2. *) +Primitive ldshiftexp := #float64_ldshiftexp. + +(** ** Predecesor/Successor functions *) + +(** [next_up]: return the next float towards positive infinity. *) +Primitive next_up := #float64_next_up. + +(** [next_down]: return the next float towards negative infinity. *) +Primitive next_down := #float64_next_down. + +(** ** Special values (needed for pretty-printing) *) +Definition infinity := Eval compute in div (of_int63 1) (of_int63 0). +Definition neg_infinity := Eval compute in opp infinity. +Definition nan := Eval compute in div (of_int63 0) (of_int63 0). + +Register infinity as num.float.infinity. +Register neg_infinity as num.float.neg_infinity. +Register nan as num.float.nan. + +(** ** Other special values *) +Definition one := Eval compute in (of_int63 1). +Definition zero := Eval compute in (of_int63 0). +Definition neg_zero := Eval compute in (-zero)%float. +Definition two := Eval compute in (of_int63 2). + +(** ** Predicates and helper functions *) +Definition is_nan f := negb (f == f)%float. + +Definition is_zero f := (f == zero)%float. (* note: 0 == -0 with floats *) + +Definition is_infinity f := (abs f == infinity)%float. + +Definition is_finite (x : float) := negb (is_nan x || is_infinity x). + +(** [get_sign]: return [true] for [-] sign, [false] for [+] sign. *) +Definition get_sign f := + let f := if is_zero f then (one / f)%float else f in + (f < zero)%float. diff --git a/theories/Floats/SpecFloat.v b/theories/Floats/SpecFloat.v new file mode 100644 index 0000000000..fd0aa5e075 --- /dev/null +++ b/theories/Floats/SpecFloat.v @@ -0,0 +1,416 @@ +Require Import ZArith FloatClass. + +(** * Specification of floating-point arithmetic + +This specification is mostly borrowed from the [IEEE754.Binary] module +of the Flocq library (see {{http://flocq.gforge.inria.fr/}}) *) + +(** ** Inductive specification of floating-point numbers + +Similar to [Flocq.IEEE754.Binary.full_float], but with no NaN payload. *) +Variant spec_float := + | S754_zero (s : bool) + | S754_infinity (s : bool) + | S754_nan + | S754_finite (s : bool) (m : positive) (e : Z). + +(** ** Parameterized definitions + +[prec] is the number of bits of the mantissa including the implicit one; +[emax] is the exponent of the infinities. + +For instance, Binary64 is defined by [prec = 53] and [emax = 1024]. *) +Section FloatOps. + Variable prec emax : Z. + + Definition emin := (3-emax-prec)%Z. + Definition fexp e := Z.max (e - prec) emin. + + Section Zdigits2. + Fixpoint digits2_pos (n : positive) : positive := + match n with + | xH => xH + | xO p => Pos.succ (digits2_pos p) + | xI p => Pos.succ (digits2_pos p) + end. + + Definition Zdigits2 n := + match n with + | Z0 => n + | Zpos p => Zpos (digits2_pos p) + | Zneg p => Zpos (digits2_pos p) + end. + End Zdigits2. + + Section ValidBinary. + Definition canonical_mantissa m e := + Zeq_bool (fexp (Zpos (digits2_pos m) + e)) e. + + Definition bounded m e := + andb (canonical_mantissa m e) (Zle_bool e (emax - prec)). + + Definition valid_binary x := + match x with + | S754_finite _ m e => bounded m e + | _ => true + end. + End ValidBinary. + + Section Iter. + Context {A : Type}. + Variable (f : A -> A). + + Fixpoint iter_pos (n : positive) (x : A) {struct n} : A := + match n with + | xI n' => iter_pos n' (iter_pos n' (f x)) + | xO n' => iter_pos n' (iter_pos n' x) + | xH => f x + end. + End Iter. + + Section Rounding. + Inductive location := loc_Exact | loc_Inexact : comparison -> location. + + Record shr_record := { shr_m : Z ; shr_r : bool ; shr_s : bool }. + + Definition shr_1 mrs := + let '(Build_shr_record m r s) := mrs in + let s := orb r s in + match m with + | Z0 => Build_shr_record Z0 false s + | Zpos xH => Build_shr_record Z0 true s + | Zpos (xO p) => Build_shr_record (Zpos p) false s + | Zpos (xI p) => Build_shr_record (Zpos p) true s + | Zneg xH => Build_shr_record Z0 true s + | Zneg (xO p) => Build_shr_record (Zneg p) false s + | Zneg (xI p) => Build_shr_record (Zneg p) true s + end. + + Definition loc_of_shr_record mrs := + match mrs with + | Build_shr_record _ false false => loc_Exact + | Build_shr_record _ false true => loc_Inexact Lt + | Build_shr_record _ true false => loc_Inexact Eq + | Build_shr_record _ true true => loc_Inexact Gt + end. + + Definition shr_record_of_loc m l := + match l with + | loc_Exact => Build_shr_record m false false + | loc_Inexact Lt => Build_shr_record m false true + | loc_Inexact Eq => Build_shr_record m true false + | loc_Inexact Gt => Build_shr_record m true true + end. + + Definition shr mrs e n := + match n with + | Zpos p => (iter_pos shr_1 p mrs, (e + n)%Z) + | _ => (mrs, e) + end. + + Definition shr_fexp m e l := + shr (shr_record_of_loc m l) e (fexp (Zdigits2 m + e) - e). + + Definition round_nearest_even mx lx := + match lx with + | loc_Exact => mx + | loc_Inexact Lt => mx + | loc_Inexact Eq => if Z.even mx then mx else (mx + 1)%Z + | loc_Inexact Gt => (mx + 1)%Z + end. + + Definition binary_round_aux sx mx ex lx := + let '(mrs', e') := shr_fexp mx ex lx in + let '(mrs'', e'') := shr_fexp (round_nearest_even (shr_m mrs') (loc_of_shr_record mrs')) e' loc_Exact in + match shr_m mrs'' with + | Z0 => S754_zero sx + | Zpos m => if Zle_bool e'' (emax - prec) then S754_finite sx m e'' else S754_infinity sx + | _ => S754_nan + end. + + Definition shl_align mx ex ex' := + match (ex' - ex)%Z with + | Zneg d => (shift_pos d mx, ex') + | _ => (mx, ex) + end. + + Definition binary_round sx mx ex := + let '(mz, ez) := shl_align mx ex (fexp (Zpos (digits2_pos mx) + ex))in + binary_round_aux sx (Zpos mz) ez loc_Exact. + + Definition binary_normalize m e szero := + match m with + | Z0 => S754_zero szero + | Zpos m => binary_round false m e + | Zneg m => binary_round true m e + end. + End Rounding. + + (** ** Define operations *) + + Definition SFopp x := + match x with + | S754_nan => S754_nan + | S754_infinity sx => S754_infinity (negb sx) + | S754_finite sx mx ex => S754_finite (negb sx) mx ex + | S754_zero sx => S754_zero (negb sx) + end. + + Definition SFabs x := + match x with + | S754_nan => S754_nan + | S754_infinity sx => S754_infinity false + | S754_finite sx mx ex => S754_finite false mx ex + | S754_zero sx => S754_zero false + end. + + Definition SFcompare f1 f2 := + match f1, f2 with + | S754_nan , _ | _, S754_nan => None + | S754_infinity s1, S754_infinity s2 => + Some match s1, s2 with + | true, true => Eq + | false, false => Eq + | true, false => Lt + | false, true => Gt + end + | S754_infinity s, _ => Some (if s then Lt else Gt) + | _, S754_infinity s => Some (if s then Gt else Lt) + | S754_finite s _ _, S754_zero _ => Some (if s then Lt else Gt) + | S754_zero _, S754_finite s _ _ => Some (if s then Gt else Lt) + | S754_zero _, S754_zero _ => Some Eq + | S754_finite s1 m1 e1, S754_finite s2 m2 e2 => + Some match s1, s2 with + | true, false => Lt + | false, true => Gt + | false, false => + match Z.compare e1 e2 with + | Lt => Lt + | Gt => Gt + | Eq => Pcompare m1 m2 Eq + end + | true, true => + match Z.compare e1 e2 with + | Lt => Gt + | Gt => Lt + | Eq => CompOpp (Pcompare m1 m2 Eq) + end + end + end. + + Definition SFeqb f1 f2 := + match SFcompare f1 f2 with + | Some Eq => true + | _ => false + end. + + Definition SFltb f1 f2 := + match SFcompare f1 f2 with + | Some Lt => true + | _ => false + end. + + Definition SFleb f1 f2 := + match SFcompare f1 f2 with + | Some Le => true + | _ => false + end. + + Definition SFclassify f := + match f with + | S754_nan => NaN + | S754_infinity false => PInf + | S754_infinity true => NInf + | S754_zero false => NZero + | S754_zero true => PZero + | S754_finite false m _ => + if (digits2_pos m =? Z.to_pos prec)%positive then PNormal + else PSubn + | S754_finite true m _ => + if (digits2_pos m =? Z.to_pos prec)%positive then NNormal + else NSubn + end. + + Definition SFmul x y := + match x, y with + | S754_nan, _ | _, S754_nan => S754_nan + | S754_infinity sx, S754_infinity sy => S754_infinity (xorb sx sy) + | S754_infinity sx, S754_finite sy _ _ => S754_infinity (xorb sx sy) + | S754_finite sx _ _, S754_infinity sy => S754_infinity (xorb sx sy) + | S754_infinity _, S754_zero _ => S754_nan + | S754_zero _, S754_infinity _ => S754_nan + | S754_finite sx _ _, S754_zero sy => S754_zero (xorb sx sy) + | S754_zero sx, S754_finite sy _ _ => S754_zero (xorb sx sy) + | S754_zero sx, S754_zero sy => S754_zero (xorb sx sy) + | S754_finite sx mx ex, S754_finite sy my ey => + binary_round_aux (xorb sx sy) (Zpos (mx * my)) (ex + ey) loc_Exact + end. + + Definition cond_Zopp (b : bool) m := if b then Z.opp m else m. + + Definition SFadd x y := + match x, y with + | S754_nan, _ | _, S754_nan => S754_nan + | S754_infinity sx, S754_infinity sy => + if Bool.eqb sx sy then x else S754_nan + | S754_infinity _, _ => x + | _, S754_infinity _ => y + | S754_zero sx, S754_zero sy => + if Bool.eqb sx sy then x else + S754_zero false + | S754_zero _, _ => y + | _, S754_zero _ => x + | S754_finite sx mx ex, S754_finite sy my ey => + let ez := Z.min ex ey in + binary_normalize (Zplus (cond_Zopp sx (Zpos (fst (shl_align mx ex ez)))) (cond_Zopp sy (Zpos (fst (shl_align my ey ez))))) + ez false + end. + + Definition SFsub x y := + match x, y with + | S754_nan, _ | _, S754_nan => S754_nan + | S754_infinity sx, S754_infinity sy => + if Bool.eqb sx (negb sy) then x else S754_nan + | S754_infinity _, _ => x + | _, S754_infinity sy => S754_infinity (negb sy) + | S754_zero sx, S754_zero sy => + if Bool.eqb sx (negb sy) then x else + S754_zero false + | S754_zero _, S754_finite sy my ey => S754_finite (negb sy) my ey + | _, S754_zero _ => x + | S754_finite sx mx ex, S754_finite sy my ey => + let ez := Z.min ex ey in + binary_normalize (Zminus (cond_Zopp sx (Zpos (fst (shl_align mx ex ez)))) (cond_Zopp sy (Zpos (fst (shl_align my ey ez))))) + ez false + end. + + Definition new_location_even nb_steps k := + if Zeq_bool k 0 then loc_Exact + else loc_Inexact (Z.compare (2 * k) nb_steps). + + Definition new_location_odd nb_steps k := + if Zeq_bool k 0 then loc_Exact + else + loc_Inexact + match Z.compare (2 * k + 1) nb_steps with + | Lt => Lt + | Eq => Lt + | Gt => Gt + end. + + Definition new_location nb_steps := + if Z.even nb_steps then new_location_even nb_steps else new_location_odd nb_steps. + + Definition SFdiv_core_binary m1 e1 m2 e2 := + let d1 := Zdigits2 m1 in + let d2 := Zdigits2 m2 in + let e' := Z.min (fexp (d1 + e1 - (d2 + e2))) (e1 - e2) in + let s := (e1 - e2 - e')%Z in + let m' := + match s with + | Zpos _ => Z.shiftl m1 s + | Z0 => m1 + | Zneg _ => Z0 + end in + let '(q, r) := Z.div_eucl m' m2 in + (q, e', new_location m2 r). + + Definition SFdiv x y := + match x, y with + | S754_nan, _ | _, S754_nan => S754_nan + | S754_infinity sx, S754_infinity sy => S754_nan + | S754_infinity sx, S754_finite sy _ _ => S754_infinity (xorb sx sy) + | S754_finite sx _ _, S754_infinity sy => S754_zero (xorb sx sy) + | S754_infinity sx, S754_zero sy => S754_infinity (xorb sx sy) + | S754_zero sx, S754_infinity sy => S754_zero (xorb sx sy) + | S754_finite sx _ _, S754_zero sy => S754_infinity (xorb sx sy) + | S754_zero sx, S754_finite sy _ _ => S754_zero (xorb sx sy) + | S754_zero sx, S754_zero sy => S754_nan + | S754_finite sx mx ex, S754_finite sy my ey => + let '(mz, ez, lz) := SFdiv_core_binary (Zpos mx) ex (Zpos my) ey in + binary_round_aux (xorb sx sy) mz ez lz + end. + + Definition SFsqrt_core_binary m e := + let d := Zdigits2 m in + let e' := Z.min (fexp (Z.div2 (d + e + 1))) (Z.div2 e) in + let s := (e - 2 * e')%Z in + let m' := + match s with + | Zpos p => Z.shiftl m s + | Z0 => m + | Zneg _ => Z0 + end in + let (q, r) := Z.sqrtrem m' in + let l := + if Zeq_bool r 0 then loc_Exact + else loc_Inexact (if Zle_bool r q then Lt else Gt) in + (q, e', l). + + Definition SFsqrt x := + match x with + | S754_nan => S754_nan + | S754_infinity false => x + | S754_infinity true => S754_nan + | S754_finite true _ _ => S754_nan + | S754_zero _ => x + | S754_finite sx mx ex => + let '(mz, ez, lz) := SFsqrt_core_binary (Zpos mx) ex in + binary_round_aux false mz ez lz + end. + + Definition SFnormfr_mantissa f := + match f with + | S754_finite _ mx ex => + if Z.eqb ex (-prec) then Npos mx else 0%N + | _ => 0%N + end. + + Definition SFldexp f e := + match f with + | S754_finite sx mx ex => binary_round sx mx (ex+e) + | _ => f + end. + + Definition SFfrexp f := + match f with + | S754_finite sx mx ex => + if (Z.to_pos prec <=? digits2_pos mx)%positive then + (S754_finite sx mx (-prec), (ex+prec)%Z) + else + let d := (prec - Z.pos (digits2_pos mx))%Z in + (S754_finite sx (shift_pos (Z.to_pos d) mx) (-prec), (ex+prec-d)%Z) + | _ => (f, (-2*emax-prec)%Z) + end. + + Definition SFone := binary_round false 1 0. + + Definition SFulp x := SFldexp SFone (fexp (snd (SFfrexp x))). + + Definition SFpred_pos x := + match x with + | S754_finite _ mx _ => + let d := + if (mx~0 =? shift_pos (Z.to_pos prec) 1)%positive then + SFldexp SFone (fexp (snd (SFfrexp x) - 1)) + else + SFulp x in + SFsub x d + | _ => x + end. + + Definition SFmax_float := + S754_finite false (shift_pos (Z.to_pos prec) 1 - 1) (emax - prec). + + Definition SFsucc x := + match x with + | S754_zero _ => SFldexp SFone emin + | S754_infinity false => x + | S754_infinity true => SFopp SFmax_float + | S754_nan => x + | S754_finite false _ _ => SFadd x (SFulp x) + | S754_finite true _ _ => SFopp (SFpred_pos (SFopp x)) + end. + + Definition SFpred f := SFopp (SFsucc (SFopp f)). +End FloatOps. diff --git a/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v b/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v index daca0ee5dc..44784675b0 100644 --- a/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v +++ b/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v @@ -18,6 +18,7 @@ Set Implicit Arguments. Require Import ZArith. +Require Import Lia. Require Import Znumtheory. Require Import Zpow_facts. Require Import DoubleType. @@ -298,8 +299,7 @@ Module ZnZ. replace (base digits) with (1 * base digits + 0) by ring. rewrite Hp1. apply Z.add_le_mono. - apply Z.mul_le_mono_nonneg; auto with zarith. - case p1; simpl; intros; red; simpl; intros; discriminate. + apply Z.mul_le_mono_nonneg. 1-2, 4: lia. unfold base; auto with zarith. case (spec_to_Z w1); auto with zarith. Qed. @@ -314,7 +314,7 @@ Module ZnZ. forall p, 0 <= p < base digits -> [|of_Z p|] = p. Proof. intros p; case p; simpl; try rewrite spec_0; auto. - intros; rewrite of_pos_correct; auto with zarith. + intros; rewrite of_pos_correct; lia. intros p1 (H1, _); contradict H1; apply Z.lt_nge; red; simpl; auto. Qed. @@ -423,7 +423,7 @@ Lemma eqb_eq : forall x y, eqb x y = true <-> x == y. Proof. intros. unfold eqb, eq. rewrite ZnZ.spec_compare. - case Z.compare_spec; intuition; try discriminate. + case Z.compare_spec; split; (easy || lia). Qed. Lemma eqb_correct : forall x y, eqb x y = true -> x==y. diff --git a/theories/Numbers/Cyclic/Abstract/NZCyclic.v b/theories/Numbers/Cyclic/Abstract/NZCyclic.v index 53a71ce0c9..4fd2cc0564 100644 --- a/theories/Numbers/Cyclic/Abstract/NZCyclic.v +++ b/theories/Numbers/Cyclic/Abstract/NZCyclic.v @@ -15,6 +15,7 @@ Require Import ZArith. Require Import Zpow_facts. Require Import DoubleType. Require Import CyclicAxioms. +Require Import Lia. (** * From [CyclicType] to [NZAxiomsSig] *) @@ -59,7 +60,8 @@ Ltac zcongruence := repeat red; intros; zify; congruence. Instance eq_equiv : Equivalence eq. Proof. -unfold eq. firstorder. + split. 1-2: firstorder. + intros x y z; apply eq_trans. Qed. Local Obligation Tactic := zcongruence. @@ -77,7 +79,7 @@ Qed. Theorem gt_wB_0 : 0 < wB. Proof. -pose proof gt_wB_1; auto with zarith. +pose proof gt_wB_1; lia. Qed. Lemma one_mod_wB : 1 mod wB = 1. @@ -138,8 +140,8 @@ intros n H1 H2 H3. unfold B in *. apply AS in H3. setoid_replace (ZnZ.of_Z (n + 1)) with (S (ZnZ.of_Z n)). assumption. zify. -rewrite 2 ZnZ.of_Z_correct; auto with zarith. -symmetry; apply Zmod_small; auto with zarith. +rewrite 2 ZnZ.of_Z_correct. 2-3: lia. +symmetry; apply Zmod_small; lia. Qed. Theorem Zbounded_induction : @@ -155,8 +157,8 @@ apply natlike_rec2; unfold Q'. destruct (Z.le_gt_cases b 0) as [H | H]. now right. left; now split. intros n H IH. destruct IH as [[IH1 IH2] | IH]. destruct (Z.le_gt_cases (b - 1) n) as [H1 | H1]. -right; auto with zarith. -left. split; [auto with zarith | now apply (QS n)]. +right; lia. +left. split; [ lia | now apply (QS n)]. right; auto with zarith. unfold Q' in *; intros n H1 H2. destruct (H n H1) as [[H3 H4] | H3]. assumption. now apply Z.le_ngt in H3. diff --git a/theories/Numbers/Cyclic/Int31/Cyclic31.v b/theories/Numbers/Cyclic/Int31/Cyclic31.v index e878fa289e..a1e7b2ff85 100644 --- a/theories/Numbers/Cyclic/Int31/Cyclic31.v +++ b/theories/Numbers/Cyclic/Int31/Cyclic31.v @@ -110,7 +110,7 @@ Section Basics. nshiftr x k = 0. Proof. intros. - replace k with ((k-size)+size)%nat by omega. + replace k with ((k-size)+size)%nat by lia. induction (k-size)%nat; auto. rewrite nshiftr_size; auto. simpl; rewrite IHn; auto. @@ -147,7 +147,7 @@ Section Basics. nshiftl x k = 0. Proof. intros. - replace k with ((k-size)+size)%nat by omega. + replace k with ((k-size)+size)%nat by lia. induction (k-size)%nat; auto. rewrite nshiftl_size; auto. simpl; rewrite IHn; auto. @@ -177,7 +177,7 @@ Section Basics. nshiftr x n = 0 -> nshiftr x p = 0. Proof. intros. - replace p with ((p-n)+n)%nat by omega. + replace p with ((p-n)+n)%nat by lia. induction (p-n)%nat. simpl; auto. simpl; rewrite IHn0; auto. @@ -188,7 +188,7 @@ Section Basics. Proof. intros. apply nshiftr_predsize_0_firstl. - apply nshiftr_0_propagates with n; auto; omega. + apply nshiftr_0_propagates with n; auto; lia. Qed. (** * Some induction principles over [int31] *) @@ -207,8 +207,8 @@ Section Basics. rewrite sneakl_shiftr. apply H0. change (P (nshiftr x (S (size - S n)))). - replace (S (size - S n))%nat with (size - n)%nat by omega. - apply IHn; omega. + replace (S (size - S n))%nat with (size - n)%nat by lia. + apply IHn; lia. change x with (nshiftr x (size-size)); auto. Qed. @@ -253,7 +253,7 @@ Section Basics. destruct (iszero (nshiftr x (size - S n))); auto. f_equal. change (shiftr (nshiftr x (size - S n))) with (nshiftr x (S (size - S n))). - replace (S (size - S n))%nat with (size - n)%nat by omega. + replace (S (size - S n))%nat with (size - n)%nat by lia. apply IHn; auto with arith. Qed. @@ -434,8 +434,8 @@ Section Basics. unfold phibis_aux, recrbis_aux; fold recrbis_aux; fold (phibis_aux n (shiftr x)). destruct (firstr x). - specialize IHn with (shiftr x); rewrite Z.double_spec; omega. - specialize IHn with (shiftr x); rewrite Z.succ_double_spec; omega. + specialize IHn with (shiftr x); rewrite Z.double_spec; lia. + specialize IHn with (shiftr x); rewrite Z.succ_double_spec; lia. Qed. Lemma phibis_aux_bounded : @@ -448,16 +448,16 @@ Section Basics. unfold phibis_aux, recrbis_aux; fold recrbis_aux; fold (phibis_aux n (shiftr (nshiftr x (size - S n)))). assert (shiftr (nshiftr x (size - S n)) = nshiftr x (size-n)). - replace (size - n)%nat with (S (size - (S n))) by omega. + replace (size - n)%nat with (S (size - (S n))) by lia. simpl; auto. rewrite H0. - assert (H1 : n <= size) by omega. + assert (H1 : n <= size) by lia. specialize (IHn x H1). set (y:=phibis_aux n (nshiftr x (size - n))) in *. rewrite Nat2Z.inj_succ, Z.pow_succ_r; auto with zarith. case_eq (firstr (nshiftr x (size - S n))); intros. - rewrite Z.double_spec; auto with zarith. - rewrite Z.succ_double_spec; auto with zarith. + rewrite Z.double_spec. lia. + rewrite Z.succ_double_spec; lia. Qed. Lemma phi_nonneg : forall x, (0 <= phi x)%Z. @@ -485,7 +485,7 @@ Section Basics. intros. unfold nshiftr in H; simpl in *. unfold phibis_aux, recrbis_aux. - rewrite H, Z.succ_double_spec; omega. + rewrite H, Z.succ_double_spec; lia. intros. remember (S n) as m. @@ -499,8 +499,8 @@ Section Basics. destruct (firstr x). change (Z.double (phibis_aux (S n) (shiftr x))) with (2*(phibis_aux (S n) (shiftr x)))%Z. - omega. - rewrite Z.succ_double_spec; omega. + lia. + rewrite Z.succ_double_spec; lia. Qed. Lemma phi_lowerbound : @@ -536,7 +536,7 @@ Section Basics. EqShiftL k x y -> EqShiftL k' x y. Proof. unfold EqShiftL; intros. - replace k' with ((k'-k)+k)%nat by omega. + replace k' with ((k'-k)+k)%nat by lia. remember (k'-k)%nat as n. clear Heqn H k'. induction n; simpl; auto. @@ -627,18 +627,18 @@ Section Basics. unfold shiftl; rewrite i2l_sneakl. simpl cstlist. rewrite <- app_comm_cons; f_equal. - rewrite IHn; [ | omega]. + rewrite IHn; [ | lia]. rewrite removelast_app. apply f_equal. - replace (size-n)%nat with (S (size - S n))%nat by omega. + replace (size-n)%nat with (S (size - S n))%nat by lia. rewrite removelast_firstn; auto. - rewrite i2l_length; omega. + rewrite i2l_length; lia. generalize (firstn_length (size-n) (i2l x)). rewrite i2l_length. intros H0 H1. rewrite H1 in H0. - rewrite min_l in H0 by omega. + rewrite min_l in H0 by lia. simpl length in H0. - omega. + lia. Qed. (** [i2l] can be used to define a relation equivalent to [EqShiftL] *) @@ -649,12 +649,12 @@ Section Basics. intros. destruct (le_lt_dec size k) as [Hle|Hlt]. split; intros. - replace (size-k)%nat with O by omega. + replace (size-k)%nat with O by lia. unfold firstn; auto. apply EqShiftL_size; auto. unfold EqShiftL. - assert (k <= size) by omega. + assert (k <= size) by lia. split; intros. assert (i2l (nshiftl x k) = i2l (nshiftl y k)) by (f_equal; auto). rewrite 2 i2l_nshiftl in H1; auto. @@ -679,7 +679,7 @@ Section Basics. rewrite 2 EqShiftL_i2l. unfold twice_plus_one. rewrite 2 i2l_sneakl. - replace (size-k)%nat with (S (size - S k))%nat by omega. + replace (size-k)%nat with (S (size - S k))%nat by lia. remember (size - S k)%nat as n. remember (i2l x) as lx. remember (i2l y) as ly. @@ -688,8 +688,8 @@ Section Basics. split; intros. injection H; auto. f_equal; auto. - subst ly n; rewrite i2l_length; omega. - subst lx n; rewrite i2l_length; omega. + subst ly n; rewrite i2l_length; lia. + subst lx n; rewrite i2l_length; lia. Qed. Lemma EqShiftL_shiftr : forall k x y, EqShiftL k x y -> @@ -704,13 +704,13 @@ Section Basics. rewrite <- sneakl_shiftr. rewrite (EqShiftL_firstr k x y); auto. rewrite <- sneakl_shiftr; auto. - omega. + lia. rewrite <- EqShiftL_twice_plus_one. unfold twice_plus_one; rewrite <- H0. rewrite <- sneakl_shiftr. rewrite (EqShiftL_firstr k x y); auto. rewrite <- sneakl_shiftr; auto. - omega. + lia. Qed. Lemma EqShiftL_incrbis : forall n k x y, n<=size -> @@ -725,13 +725,13 @@ Section Basics. unfold incrbis_aux; simpl; fold (incrbis_aux n (shiftr x)); fold (incrbis_aux n (shiftr y)). - rewrite (EqShiftL_firstr k x y); auto; try omega. + rewrite (EqShiftL_firstr k x y); auto; try lia. case_eq (firstr y); intros. rewrite EqShiftL_twice_plus_one. apply EqShiftL_shiftr; auto. rewrite EqShiftL_twice. - apply IHn; try omega. + apply IHn; try lia. apply EqShiftL_shiftr; auto. Qed. @@ -840,18 +840,18 @@ Section Basics. unfold phibis_aux, recrbis_aux; fold recrbis_aux; fold (phibis_aux n (shiftr (nshiftr x (size-S n)))). assert (shiftr (nshiftr x (size - S n)) = nshiftr x (size-n)). - replace (size - n)%nat with (S (size - (S n))); auto; omega. + replace (size - n)%nat with (S (size - (S n))); auto; lia. rewrite H0. case_eq (firstr (nshiftr x (size - S n))); intros. rewrite phi_inv_double. - rewrite IHn by omega. + rewrite IHn by lia. rewrite <- H0. remember (nshiftr x (size - S n)) as y. destruct y; simpl in H1; rewrite H1; auto. rewrite phi_inv_double_plus_one. - rewrite IHn by omega. + rewrite IHn by lia. rewrite <- H0. remember (nshiftr x (size - S n)) as y. destruct y; simpl in H1; rewrite H1; auto. @@ -928,7 +928,7 @@ Section Basics. (rewrite <- Z.pow_succ_r, <- Zpos_P_of_succ_nat; auto with zarith). rewrite (Z.mul_comm 2). - assert (n<=size)%nat by omega. + assert (n<=size)%nat by lia. destruct p; simpl; [ | | auto]; specialize (IHn p H0); generalize (p2ibis_bounded n p); @@ -937,13 +937,13 @@ Section Basics. change (Zpos p~1) with (2*Zpos p + 1)%Z. rewrite phi_twice_plus_one_firstl, Z.succ_double_spec. rewrite IHn; ring. - apply (nshiftr_0_firstl n); auto; try omega. + apply (nshiftr_0_firstl n); auto; try lia. change (Zpos p~0) with (2*Zpos p)%Z. rewrite phi_twice_firstl. change (Z.double (phi i)) with (2*(phi i))%Z. rewrite IHn; ring. - apply (nshiftr_0_firstl n); auto; try omega. + apply (nshiftr_0_firstl n); auto; try lia. Qed. (** We now prove that this [p2ibis] is related to [phi_inv_positive] *) @@ -959,8 +959,8 @@ Section Basics. specialize IHn with p; destruct (p2ibis n p); simpl @snd in *; simpl phi_inv_positive; rewrite ?EqShiftL_twice_plus_one, ?EqShiftL_twice; - replace (S (size - S n))%nat with (size - n)%nat by omega; - apply IHn; omega. + replace (S (size - S n))%nat with (size - n)%nat by lia; + apply IHn; lia. Qed. (** This gives the expected result about [phi o phi_inv], at least @@ -1008,12 +1008,12 @@ Section Basics. induction n; simpl; auto; intros. destruct p; auto; specialize IHn with p; generalize (p2ibis_bounded n p); - rewrite IHn; try omega; destruct (p2ibis n p); simpl; intros; + rewrite IHn; try lia; destruct (p2ibis n p); simpl; intros; f_equal; auto. apply double_twice_plus_one_firstl. - apply (nshiftr_0_firstl n); auto; omega. + apply (nshiftr_0_firstl n); auto; lia. apply double_twice_firstl. - apply (nshiftr_0_firstl n); auto; omega. + apply (nshiftr_0_firstl n); auto; lia. Qed. Lemma positive_to_int31_phi_inv_positive : forall p, @@ -1046,7 +1046,7 @@ Section Basics. pattern x at 1; rewrite <- (phi_inv_phi x). rewrite <- phi_inv_double. assert (0 <= Z.double (phi x)). - rewrite Z.double_spec; generalize (phi_bounded x); omega. + rewrite Z.double_spec; generalize (phi_bounded x); lia. destruct (Z.double (phi x)). simpl; auto. apply phi_phi_inv_positive. @@ -1060,7 +1060,7 @@ Section Basics. pattern x at 1; rewrite <- (phi_inv_phi x). rewrite <- phi_inv_double_plus_one. assert (0 <= Z.succ_double (phi x)). - rewrite Z.succ_double_spec; generalize (phi_bounded x); omega. + rewrite Z.succ_double_spec; generalize (phi_bounded x); lia. destruct (Z.succ_double (phi x)). simpl; auto. apply phi_phi_inv_positive. @@ -1075,7 +1075,7 @@ Section Basics. rewrite <- phi_inv_incr. assert (0 <= Z.succ (phi x)). change (Z.succ (phi x)) with ((phi x)+1)%Z; - generalize (phi_bounded x); omega. + generalize (phi_bounded x); lia. destruct (Z.succ (phi x)). simpl; auto. apply phi_phi_inv_positive. @@ -1095,7 +1095,7 @@ Section Basics. rewrite incr_twice, phi_twice_plus_one. remember (phi (complement_negative p)) as q. rewrite Z.succ_double_spec. - replace (2*q+1) with (2*(Z.succ q)-1) by omega. + replace (2*q+1) with (2*(Z.succ q)-1) by lia. rewrite <- Zminus_mod_idemp_l, <- Zmult_mod_idemp_r, IHp. rewrite Zmult_mod_idemp_r, Zminus_mod_idemp_l; auto with zarith. @@ -1203,9 +1203,7 @@ Section Int31_Specs. Qed. Lemma spec_more_than_1_digit: 1 < 31. - Proof. - auto with zarith. - Qed. + Proof. reflexivity. Qed. Lemma spec_0 : [| 0 |] = 0. Proof. @@ -1237,7 +1235,7 @@ Section Int31_Specs. assert ((X+Y) mod wB ?= X+Y <> Eq -> [+|C1 (phi_inv (X+Y))|] = X+Y). unfold interp_carry; rewrite phi_phi_inv, Z.compare_eq_iff; intros. destruct (Z_lt_le_dec (X+Y) wB). - contradict H1; auto using Zmod_small with zarith. + contradict H1; apply Zmod_small; lia. rewrite <- (Z_mod_plus_full (X+Y) (-1) wB). rewrite Zmod_small; lia. @@ -1261,7 +1259,7 @@ Section Int31_Specs. assert ((X+Y+1) mod wB ?= X+Y+1 <> Eq -> [+|C1 (phi_inv (X+Y+1))|] = X+Y+1). unfold interp_carry; rewrite phi_phi_inv, Z.compare_eq_iff; intros. destruct (Z_lt_le_dec (X+Y+1) wB). - contradict H1; auto using Zmod_small with zarith. + contradict H1; apply Zmod_small; lia. rewrite <- (Z_mod_plus_full (X+Y+1) (-1) wB). rewrite Zmod_small; lia. @@ -1399,8 +1397,7 @@ Section Int31_Specs. rewrite phi2_phi_inv2. apply Zmod_small. generalize (phi_bounded x)(phi_bounded y); intros. - change (wB^2) with (wB * wB). - auto using Z.mul_lt_mono_nonneg with zarith. + nia. Qed. Lemma spec_mul : forall x y, [|x*y|] = ([|x|] * [|y|]) mod wB. @@ -1424,7 +1421,7 @@ Section Int31_Specs. Proof. unfold div3121; intros. generalize (phi_bounded a1)(phi_bounded a2)(phi_bounded b); intros. - assert ([|b|]>0) by (auto with zarith). + assert ([|b|]>0) by lia. generalize (Z_div_mod (phi2 a1 a2) [|b|] H4) (Z_div_pos (phi2 a1 a2) [|b|] H4). unfold Z.div; destruct (Z.div_eucl (phi2 a1 a2) [|b|]). rewrite ?phi_phi_inv. @@ -1433,19 +1430,19 @@ Section Int31_Specs. change base with wB; change base with wB in H5. change (Z.pow_pos 2 31) with wB; change (Z.pow_pos 2 31) with wB in H. rewrite H5, Z.mul_comm. - replace (z0 mod wB) with z0 by (symmetry; apply Zmod_small; omega). + replace (z0 mod wB) with z0 by (symmetry; apply Zmod_small; lia). replace (z mod wB) with z; auto with zarith. symmetry; apply Zmod_small. split. - apply H7; change base with wB; auto with zarith. - apply Z.mul_lt_mono_pos_r with [|b|]; [omega| ]. + apply H7; change base with wB. nia. + apply Z.mul_lt_mono_pos_r with [|b|]; [lia| ]. rewrite Z.mul_comm. - apply Z.le_lt_trans with ([|b|]*z+z0); [omega| ]. + apply Z.le_lt_trans with ([|b|]*z+z0); [lia| ]. rewrite <- H5. - apply Z.le_lt_trans with ([|a1|]*wB+(wB-1)); [omega | ]. + apply Z.le_lt_trans with ([|a1|]*wB+(wB-1)); [lia | ]. replace ([|a1|]*wB+(wB-1)) with (wB*([|a1|]+1)-1) by ring. - assert (wB*([|a1|]+1) <= wB*[|b|]); try omega. - apply Z.mul_le_mono_nonneg; omega. + assert (wB*([|a1|]+1) <= wB*[|b|]); try lia. + apply Z.mul_le_mono_nonneg; lia. Qed. Lemma spec_div : forall a b, 0 < [|b|] -> @@ -1461,15 +1458,15 @@ Section Int31_Specs. destruct 1; intros. rewrite H1, Z.mul_comm. generalize (phi_bounded a)(phi_bounded b); intros. - replace (z0 mod wB) with z0 by (symmetry; apply Zmod_small; omega). + replace (z0 mod wB) with z0 by (symmetry; apply Zmod_small; lia). replace (z mod wB) with z; auto with zarith. symmetry; apply Zmod_small. - split; auto with zarith. - apply Z.le_lt_trans with [|a|]; auto with zarith. + split. lia. + apply Z.le_lt_trans with [|a|]. 2: lia. rewrite H1. - apply Z.le_trans with ([|b|]*z); try omega. + apply Z.le_trans with ([|b|]*z); try lia. rewrite <- (Z.mul_1_l z) at 1. - apply Z.mul_le_mono_nonneg; auto with zarith. + nia. Qed. Lemma spec_mod : forall a b, 0 < [|b|] -> @@ -1483,7 +1480,7 @@ Section Int31_Specs. rewrite ?phi_phi_inv. destruct 1; intros. generalize (phi_bounded b); intros. - apply Zmod_small; omega. + apply Zmod_small; lia. Qed. Lemma phi_gcd : forall i j, @@ -1498,7 +1495,7 @@ Section Int31_Specs. generalize (phi_bounded j)(phi_bounded i); intros. case_eq [|j|]; intros. simpl; intros. - generalize (Zabs_spec [|i|]); omega. + generalize (Zabs_spec [|i|]); lia. simpl. rewrite IHn, H1; f_equal. rewrite spec_mod, H1; auto. rewrite H1; compute; auto. @@ -1514,9 +1511,9 @@ Section Int31_Specs. unfold Zgcd_bound. generalize (phi_bounded b). destruct [|b|]. - unfold size; auto with zarith. + unfold size; lia. intros (_,H). - cut (Pos.size_nat p <= size)%nat; [ omega | rewrite <- Zpower2_Psize; auto]. + cut (Pos.size_nat p <= size)%nat; [ lia | rewrite <- Zpower2_Psize; auto]. intros (H,_); compute in H; elim H; auto. Qed. @@ -1544,9 +1541,7 @@ Section Int31_Specs. change (iter_nat (S (Z.abs_nat z) + (Z.abs_nat z))%nat A f a = iter_nat (Z.abs_nat (Z.succ_double z)) A f a); f_equal. rewrite Z.succ_double_spec, <- Z.add_diag. - rewrite Zabs2Nat.inj_add; auto with zarith. - rewrite Zabs2Nat.inj_add; auto with zarith. - change (Z.abs_nat 1) with 1%nat; omega. + lia. Qed. Fixpoint addmuldiv31_alt n i j := @@ -1594,7 +1589,7 @@ Section Int31_Specs. symmetry; apply Zdiv_small; apply phi_bounded. simpl addmuldiv31_alt; intros. - rewrite IHn; [ | omega ]. + rewrite IHn; [ | lia ]. case_eq (firstl y); intros. rewrite phi_twice, Z.double_spec. @@ -1606,8 +1601,9 @@ Section Int31_Specs. f_equal. ring. replace (31-Z.of_nat n) with (Z.succ(31-Z.succ(Z.of_nat n))) by ring. - rewrite Z.pow_succ_r, <- Zdiv_Zdiv; auto with zarith. + rewrite Z.pow_succ_r, <- Zdiv_Zdiv. rewrite Z.mul_comm, Z_div_mult; auto with zarith. + lia. auto with zarith. lia. rewrite phi_twice_plus_one, Z.succ_double_spec. rewrite phi_twice; auto. @@ -1622,49 +1618,49 @@ Section Int31_Specs. clear - H. symmetry. apply Zmod_unique with 1; [ | ring ]. generalize (phi_lowerbound _ H) (phi_bounded y). set (wB' := 2^Z.of_nat (pred size)). - replace wB with (2*wB'); [ omega | ]. + replace wB with (2*wB'); [ lia | ]. unfold wB'. rewrite <- Z.pow_succ_r, <- Nat2Z.inj_succ by (auto with zarith). f_equal. rewrite H1. replace wB with (2^(Z.of_nat n)*2^(31-Z.of_nat n)) by - (rewrite <- Zpower_exp; auto with zarith; f_equal; unfold size; ring). + (rewrite <- Zpower_exp by lia; f_equal; unfold size; ring). unfold Z.sub; rewrite <- Z.mul_opp_l. - rewrite Z_div_plus; auto with zarith. + rewrite Z_div_plus. ring_simplify. replace (31+-Z.of_nat n) with (Z.succ(31-Z.succ(Z.of_nat n))) by ring. - rewrite Z.pow_succ_r, <- Zdiv_Zdiv; auto with zarith. + rewrite Z.pow_succ_r, <- Zdiv_Zdiv. rewrite Z.mul_comm, Z_div_mult; auto with zarith. + lia. auto with zarith. lia. + apply Z.lt_gt; apply Z.pow_pos_nonneg; lia. Qed. Lemma shift_unshift_mod_2 : forall n p a, 0 <= p <= n -> ((a * 2 ^ (n - p)) mod (2^n) / 2 ^ (n - p)) mod (2^n) = a mod 2 ^ p. Proof. - intros. + intros n p a H. + assert (2 ^ n > 0 /\ 2 ^ p > 0 /\ 2 ^ (n - p) > 0) as [ X [ Y Z ] ] + by (split; [ | split ]; apply Z.lt_gt, Z.pow_pos_nonneg; lia). rewrite Zmod_small. - rewrite Zmod_eq by (auto with zarith). + rewrite Zmod_eq by assumption. unfold Z.sub at 1. - rewrite Z_div_plus_full_l - by (cut (0 < 2^(n-p)); auto with zarith). + rewrite Z_div_plus_full_l by lia. assert (2^n = 2^(n-p)*2^p). - rewrite <- Zpower_exp by (auto with zarith). - replace (n-p+p) with n; auto with zarith. + rewrite <- Zpower_exp by lia. + replace (n-p+p) with n; lia. rewrite H0. - rewrite <- Zdiv_Zdiv, Z_div_mult by (auto with zarith). + rewrite <- Zdiv_Zdiv, Z_div_mult; auto with zarith. rewrite (Z.mul_comm (2^(n-p))), Z.mul_assoc. rewrite <- Z.mul_opp_l. - rewrite Z_div_mult by (auto with zarith). + rewrite Z_div_mult by assumption. symmetry; apply Zmod_eq; auto with zarith. remember (a * 2 ^ (n - p)) as b. destruct (Z_mod_lt b (2^n)); auto with zarith. split. apply Z_div_pos; auto with zarith. - apply Zdiv_lt_upper_bound; auto with zarith. - apply Z.lt_le_trans with (2^n); auto with zarith. - rewrite <- (Z.mul_1_r (2^n)) at 1. - apply Z.mul_le_mono_nonneg; auto with zarith. - cut (0 < 2 ^ (n-p)); auto with zarith. + apply Zdiv_lt_upper_bound. lia. + nia. Qed. Lemma spec_pos_mod : forall w p, @@ -1676,28 +1672,28 @@ Section Int31_Specs. intros. generalize (phi_bounded w). symmetry; apply Zmod_small. - split; auto with zarith. - apply Z.lt_le_trans with wB; auto with zarith. + split. lia. + apply Z.lt_le_trans with wB. lia. apply Zpower_le_monotone; auto with zarith. intros. case_eq ([|p|] ?= 31); intros; [ apply H; rewrite (Z.compare_eq _ _ H0); auto with zarith | | - apply H; change ([|p|]>31)%Z in H0; auto with zarith ]. + apply H; change ([|p|]>31)%Z in H0; lia ]. change ([|p|]<31) in H0. - rewrite spec_add_mul_div by auto with zarith. + rewrite spec_add_mul_div by lia. change [|0|] with 0%Z; rewrite Z.mul_0_l, Z.add_0_l. generalize (phi_bounded p)(phi_bounded w); intros. assert (31-[|p|]<wB). - apply Z.le_lt_trans with 31%Z; auto with zarith. + apply Z.le_lt_trans with 31%Z. lia. compute; auto. assert ([|31-p|]=31-[|p|]). unfold sub31; rewrite phi_phi_inv. change [|31|] with 31%Z. - apply Zmod_small; auto with zarith. - rewrite spec_add_mul_div by (rewrite H4; auto with zarith). + apply Zmod_small. lia. + rewrite spec_add_mul_div by (rewrite H4; lia). change [|0|] with 0%Z; rewrite Zdiv_0_l, Z.add_0_r. rewrite H4. - apply shift_unshift_mod_2; simpl; auto with zarith. + apply shift_unshift_mod_2; simpl; lia. Qed. @@ -1744,20 +1740,20 @@ Section Int31_Specs. rewrite phi_phi_inv. apply Zmod_small. split. - change 0 with (Z.of_nat O); apply inj_le; omega. + change 0 with (Z.of_nat O); apply inj_le; lia. apply Z.le_lt_trans with (Z.of_nat 31). - apply inj_le; omega. + apply inj_le; lia. compute; auto. case_eq (firstl x); intros; auto. rewrite plus_Sn_m, plus_n_Sm. - replace (S (31 - S n)) with (31 - n)%nat by omega. - rewrite <- IHn; [ | omega | ]. + replace (S (31 - S n)) with (31 - n)%nat by lia. + rewrite <- IHn; [ | lia | ]. f_equal; f_equal. unfold add31. rewrite H1. f_equal. change [|In|] with 1. - replace (31-n)%nat with (S (31 - S n))%nat by omega. + replace (31-n)%nat with (S (31 - S n))%nat by lia. rewrite Nat2Z.inj_succ; ring. clear - H H2. @@ -1774,7 +1770,7 @@ Section Int31_Specs. assert ([|x|]<>0%Z). contradict H. rewrite <- (phi_inv_phi x); rewrite H; auto. - generalize (phi_bounded x); auto with zarith. + generalize (phi_bounded x); lia. Qed. Lemma spec_head0 : forall x, 0 < [|x|] -> @@ -1806,7 +1802,7 @@ Section Int31_Specs. rewrite <- nshiftl_S_tail; auto. change (2^(Z.of_nat 0)) with 1; rewrite Z.mul_1_l. - generalize (phi_bounded x); unfold size; split; auto with zarith. + generalize (phi_bounded x); unfold size; split. 2: lia. change (2^(Z.of_nat 31)/2) with (2^(Z.of_nat (pred size))). apply phi_lowerbound; auto. Qed. @@ -1852,20 +1848,20 @@ Section Int31_Specs. rewrite phi_phi_inv. apply Zmod_small. split. - change 0 with (Z.of_nat O); apply inj_le; omega. + change 0 with (Z.of_nat O); apply inj_le; lia. apply Z.le_lt_trans with (Z.of_nat 31). - apply inj_le; omega. + apply inj_le; lia. compute; auto. case_eq (firstr x); intros; auto. rewrite plus_Sn_m, plus_n_Sm. - replace (S (31 - S n)) with (31 - n)%nat by omega. - rewrite <- IHn; [ | omega | ]. + replace (S (31 - S n)) with (31 - n)%nat by lia. + rewrite <- IHn; [ | lia | ]. f_equal; f_equal. unfold add31. rewrite H1. f_equal. change [|In|] with 1. - replace (31-n)%nat with (S (31 - S n))%nat by omega. + replace (31-n)%nat with (S (31 - S n))%nat by lia. rewrite Nat2Z.inj_succ; ring. clear - H H2. @@ -1905,7 +1901,7 @@ Section Int31_Specs. exists [|shiftr x|]. split. - generalize (phi_bounded (shiftr x)); auto with zarith. + generalize (phi_bounded (shiftr x)); lia. rewrite phi_eqn2; auto. rewrite Z.succ_double_spec; simpl; ring. Qed. @@ -1918,7 +1914,7 @@ Section Int31_Specs. Lemma quotient_by_2 a: a - 1 <= (a/2) + (a/2). Proof. case (Z_mod_lt a 2); auto with zarith. - intros H1; rewrite Zmod_eq_full; auto with zarith. + intros H1; rewrite Zmod_eq_full; lia. Qed. Lemma sqrt_main_trick j k: 0 <= j -> 0 <= k -> @@ -1933,16 +1929,16 @@ Section Int31_Specs. generalize (sqr_pos (Z.succ j / 2)) (quotient_by_2 (Z.succ j)); unfold Z.succ. rewrite Z.pow_2_r, Z.mul_add_distr_r; repeat rewrite Z.mul_add_distr_l. - auto with zarith. + lia. intros k Hk _. replace ((Z.succ j + Z.succ k) / 2) with ((j + k)/2 + 1). generalize (Hrec Hj k Hk) (quotient_by_2 (j + k)). unfold Z.succ; repeat rewrite Z.pow_2_r; repeat rewrite Z.mul_add_distr_r; repeat rewrite Z.mul_add_distr_l. repeat rewrite Z.mul_1_l; repeat rewrite Z.mul_1_r. - auto with zarith. - rewrite Z.add_comm, <- Z_div_plus_full_l; auto with zarith. - apply f_equal2 with (f := Z.div); auto with zarith. + lia. + rewrite Z.add_comm, <- Z_div_plus_full_l by lia. + apply f_equal2 with (f := Z.div); lia. Qed. Lemma sqrt_main i j: 0 <= i -> 0 < j -> i < ((j + (i/j))/2 + 1) ^ 2. @@ -1956,25 +1952,25 @@ Section Int31_Specs. Lemma sqrt_init i: 1 < i -> i < (i/2 + 1) ^ 2. Proof. intros Hi. - assert (H1: 0 <= i - 2) by auto with zarith. - assert (H2: 1 <= (i / 2) ^ 2); auto with zarith. - replace i with (1* 2 + (i - 2)); auto with zarith. - rewrite Z.pow_2_r, Z_div_plus_full_l; auto with zarith. + assert (H1: 0 <= i - 2) by lia. + assert (H2: 1 <= (i / 2) ^ 2). + replace i with (1* 2 + (i - 2)) by lia. + rewrite Z.pow_2_r, Z_div_plus_full_l by lia. generalize (sqr_pos ((i - 2)/ 2)) (Z_div_pos (i - 2) 2). rewrite Z.mul_add_distr_r; repeat rewrite Z.mul_add_distr_l. - auto with zarith. + lia. generalize (quotient_by_2 i). rewrite Z.pow_2_r in H2 |- *; repeat (rewrite Z.mul_add_distr_r || rewrite Z.mul_add_distr_l || rewrite Z.mul_1_l || rewrite Z.mul_1_r). - auto with zarith. + lia. Qed. Lemma sqrt_test_true i j: 0 <= i -> 0 < j -> i/j >= j -> j ^ 2 <= i. Proof. intros Hi Hj Hd; rewrite Z.pow_2_r. - apply Z.le_trans with (j * (i/j)); auto with zarith. + apply Z.le_trans with (j * (i/j)). nia. apply Z_mult_div_ge; auto with zarith. Qed. @@ -1982,7 +1978,7 @@ Section Int31_Specs. Proof. intros Hi Hj H; case (Z.le_gt_cases j ((j + (i/j))/2)); auto. intros H1; contradict H; apply Z.le_ngt. - assert (2 * j <= j + (i/j)); auto with zarith. + assert (2 * j <= j + (i/j)). 2: lia. apply Z.le_trans with (2 * ((j + (i/j))/2)); auto with zarith. apply Z_mult_div_ge; auto with zarith. Qed. @@ -2001,8 +1997,7 @@ Section Int31_Specs. Lemma div31_phi i j: 0 < [|j|] -> [|fst (i/j)%int31|] = [|i|]/[|j|]. intros Hj; generalize (spec_div i j Hj). case div31; intros q r; simpl @fst. - intros (H1,H2); apply Zdiv_unique with [|r|]; auto with zarith. - rewrite H1; ring. + intros (H1,H2); apply Zdiv_unique with [|r|]; lia. Qed. Lemma sqrt31_step_correct rec i j: @@ -2016,24 +2011,27 @@ Section Int31_Specs. assert (Hp2: 0 < [|2|]) by exact (eq_refl Lt). intros Hi Hj Hij H31 Hrec; rewrite sqrt31_step_def. rewrite spec_compare, div31_phi; auto. - case Z.compare_spec; auto; intros Hc; - try (split; auto; apply sqrt_test_true; auto with zarith; fail). + case Z.compare_spec; intros Hc. + 1, 3: split; [ apply sqrt_test_true; lia | assumption ]. assert (E : [|(j + fst (i / j)%int31)|] = [|j|] + [|i|] / [|j|]). - { rewrite spec_add, div31_phi; auto using Z.mod_small with zarith. } - apply Hrec; rewrite !div31_phi, E; auto using sqrt_main with zarith. - split; try apply sqrt_test_false; auto with zarith. + { rewrite spec_add, div31_phi by lia. apply Z.mod_small. split. 2: lia. + generalize (Z.div_pos [|i|] [|j|]); lia. } + apply Hrec; rewrite !div31_phi, E; auto. + 2: apply sqrt_main; lia. + split. 2: apply sqrt_test_false; lia. apply Z.le_succ_l in Hj. change (1 <= [|j|]) in Hj. Z.le_elim Hj. - replace ([|j|] + [|i|]/[|j|]) with (1 * 2 + (([|j|] - 2) + [|i|] / [|j|])) by ring. - rewrite Z_div_plus_full_l; auto with zarith. - assert (0 <= [|i|]/ [|j|]) by auto with zarith. - assert (0 <= ([|j|] - 2 + [|i|] / [|j|]) / [|2|]); auto with zarith. + rewrite Z_div_plus_full_l by lia. + assert (0 <= [|i|]/ [|j|]) by (generalize (Z.div_pos [|i|] [|j|]); lia). + assert (0 <= ([|j|] - 2 + [|i|] / [|j|]) / [|2|]). 2: lia. + apply Z.div_pos; lia. - rewrite <- Hj, Zdiv_1_r. replace (1 + [|i|]) with (1 * 2 + ([|i|] - 1)) by ring. - rewrite Z_div_plus_full_l; auto with zarith. - assert (0 <= ([|i|] - 1) /2) by auto with zarith. - change ([|2|]) with 2; auto with zarith. + rewrite Z_div_plus_full_l by lia. + assert (0 <= ([|i|] - 1) /2) by (apply Z.div_pos; lia). + change [|2|] with 2. lia. Qed. Lemma iter31_sqrt_correct n rec i j: 0 < [|i|] -> 0 < [|j|] -> @@ -2044,18 +2042,16 @@ Section Int31_Specs. [|iter31_sqrt n rec i j|] ^ 2 <= [|i|] < ([|iter31_sqrt n rec i j|] + 1) ^ 2. Proof. revert rec i j; elim n; unfold iter31_sqrt; fold iter31_sqrt; clear n. - intros rec i j Hi Hj Hij H31 Hrec; apply sqrt31_step_correct; auto with zarith. - intros; apply Hrec; auto with zarith. - rewrite Z.pow_0_r; auto with zarith. + intros rec i j Hi Hj Hij H31 Hrec; apply sqrt31_step_correct; auto. + intros; apply Hrec. 2: rewrite Z.pow_0_r. 1-4: lia. intros n Hrec rec i j Hi Hj Hij H31 HHrec. apply sqrt31_step_correct; auto. - intros j1 Hj1 Hjp1; apply Hrec; auto with zarith. + intros j1 Hj1 Hjp1; apply Hrec. 1-4: lia. intros j2 Hj2 H2j2 Hjp2 Hj31; apply Hrec; auto with zarith. intros j3 Hj3 Hpj3. apply HHrec; auto. - rewrite Nat2Z.inj_succ, Z.pow_succ_r. - apply Z.le_trans with (2 ^Z.of_nat n + [|j2|]); auto with zarith. - apply Nat2Z.is_nonneg. + rewrite Nat2Z.inj_succ, Z.pow_succ_r by lia. + apply Z.le_trans with (2 ^Z.of_nat n + [|j2|]); lia. Qed. Lemma spec_sqrt : forall x, @@ -2063,13 +2059,13 @@ Section Int31_Specs. Proof. intros i; unfold sqrt31. rewrite spec_compare. case Z.compare_spec; change [|1|] with 1; - intros Hi; auto with zarith. - repeat rewrite Z.pow_2_r; auto with zarith. - apply iter31_sqrt_correct; auto with zarith. - rewrite div31_phi; change ([|2|]) with 2; auto with zarith. + intros Hi. lia. + 2: case (phi_bounded i); repeat rewrite Z.pow_2_r; auto with zarith. + apply iter31_sqrt_correct. lia. + rewrite div31_phi; change ([|2|]) with 2. 2: lia. replace ([|i|]) with (1 * 2 + ([|i|] - 2))%Z; try ring. - assert (0 <= ([|i|] - 2)/2)%Z by (apply Z_div_pos; auto with zarith). - rewrite Z_div_plus_full_l; auto with zarith. + assert (0 <= ([|i|] - 2)/2)%Z by (apply Z_div_pos; lia). + rewrite Z_div_plus_full_l; lia. rewrite div31_phi; change ([|2|]) with 2; auto with zarith. apply sqrt_init; auto. rewrite div31_phi; change ([|2|]) with 2; auto with zarith. @@ -2078,13 +2074,9 @@ Section Int31_Specs. case (phi_bounded i); auto. intros j2 H1 H2; contradict H2; apply Z.lt_nge. rewrite div31_phi; change ([|2|]) with 2; auto with zarith. - apply Z.le_lt_trans with ([|i|]); auto with zarith. - assert (0 <= [|i|]/2)%Z by (apply Z_div_pos; auto with zarith). - apply Z.le_trans with (2 * ([|i|]/2)); auto with zarith. - apply Z_mult_div_ge; auto with zarith. - case (phi_bounded i); unfold size; auto with zarith. - change [|0|] with 0; auto with zarith. - case (phi_bounded i); repeat rewrite Z.pow_2_r; auto with zarith. + case (phi_bounded i); unfold size; intros X Y. + apply Z.lt_le_trans with ([|i|]). apply Z.div_lt; lia. + lia. Qed. Lemma sqrt312_step_def rec ih il j: @@ -2113,12 +2105,12 @@ Section Int31_Specs. case (phi_bounded j); intros Hbj _. case (phi_bounded il); intros Hbil _. case (phi_bounded ih); intros Hbih Hbih1. - assert ([|ih|] < [|j|] + 1); auto with zarith. + assert ([|ih|] < [|j|] + 1). 2: lia. apply Z.square_lt_simpl_nonneg; auto with zarith. rewrite <- ?Z.pow_2_r; apply Z.le_lt_trans with (2 := H1). apply Z.le_trans with ([|ih|] * wB). - - rewrite ? Z.pow_2_r; auto with zarith. - - unfold phi2. change base with wB; auto with zarith. + - rewrite ? Z.pow_2_r; nia. + - unfold phi2. change base with wB; lia. Qed. Lemma div312_phi ih il j: (2^30 <= [|j|] -> [|ih|] < [|j|] -> @@ -2145,59 +2137,59 @@ Section Int31_Specs. case (phi_bounded il); intros Hil1 _. case (phi_bounded j); intros _ Hj1. assert (Hp3: (0 < phi2 ih il)). - { unfold phi2; apply Z.lt_le_trans with ([|ih|] * base); auto with zarith. - apply Z.mul_pos_pos; auto with zarith. - apply Z.lt_le_trans with (2:= Hih); auto with zarith. } + { unfold phi2; apply Z.lt_le_trans with ([|ih|] * base). 2: lia. + apply Z.mul_pos_pos. lia. auto with zarith. } rewrite spec_compare. case Z.compare_spec; intros Hc1. - split; auto. apply sqrt_test_true; auto. + unfold phi2, base; auto with zarith. + unfold phi2; rewrite Hc1. assert (0 <= [|il|]/[|j|]) by (apply Z_div_pos; auto with zarith). - rewrite Z.mul_comm, Z_div_plus_full_l; auto with zarith. - change base with wB. auto with zarith. + rewrite Z.mul_comm, Z_div_plus_full_l by lia. + change base with wB. lia. - case (Z.le_gt_cases (2 ^ 30) [|j|]); intros Hjj. + rewrite spec_compare; case Z.compare_spec; - rewrite div312_phi; auto; intros Hc; - try (split; auto; apply sqrt_test_true; auto with zarith; fail). + rewrite div312_phi; auto; intros Hc. + 1, 3: split; auto; apply sqrt_test_true; lia. apply Hrec. - * assert (Hf1: 0 <= phi2 ih il/ [|j|]) by auto with zarith. + * assert (Hf1: 0 <= phi2 ih il/ [|j|]). { apply Z.div_pos; lia. } apply Z.le_succ_l in Hj. change (1 <= [|j|]) in Hj. Z.le_elim Hj; [ | contradict Hc; apply Z.le_ngt; - rewrite <- Hj, Zdiv_1_r; auto with zarith ]. + rewrite <- Hj, Zdiv_1_r; lia ]. assert (Hf3: 0 < ([|j|] + phi2 ih il / [|j|]) / 2). { replace ([|j|] + phi2 ih il/ [|j|]) with - (1 * 2 + (([|j|] - 2) + phi2 ih il / [|j|])); try ring. - rewrite Z_div_plus_full_l; auto with zarith. - assert (0 <= ([|j|] - 2 + phi2 ih il / [|j|]) / 2) ; - auto with zarith. } + (1 * 2 + (([|j|] - 2) + phi2 ih il / [|j|])) by ring. + rewrite Z_div_plus_full_l by lia. + assert (0 <= ([|j|] - 2 + phi2 ih il / [|j|]) / 2). + apply Z.div_pos; lia. + lia. } assert (Hf4: ([|j|] + phi2 ih il / [|j|]) / 2 < [|j|]). - { apply sqrt_test_false; auto with zarith. } + { apply sqrt_test_false; lia. } generalize (spec_add_c j (fst (div3121 ih il j))). unfold interp_carry; case add31c; intros r; - rewrite div312_phi; auto with zarith. + rewrite div312_phi by lia. { rewrite div31_phi; change [|2|] with 2; auto with zarith. intros HH; rewrite HH; clear HH; auto with zarith. } { rewrite spec_add, div31_phi; change [|2|] with 2; auto. rewrite Z.mul_1_l; intros HH. - rewrite Z.add_comm, <- Z_div_plus_full_l; auto with zarith. + rewrite Z.add_comm, <- Z_div_plus_full_l by lia. change (phi v30 * 2) with (2 ^ Z.of_nat size). - rewrite HH, Zmod_small; auto with zarith. } + rewrite HH, Zmod_small; lia. } * replace (phi _) with (([|j|] + (phi2 ih il)/([|j|]))/2); - [ apply sqrt_main; auto with zarith | ]. + [ apply sqrt_main; lia | ]. generalize (spec_add_c j (fst (div3121 ih il j))). unfold interp_carry; case add31c; intros r; - rewrite div312_phi; auto with zarith. + rewrite div312_phi by lia. { rewrite div31_phi; auto with zarith. intros HH; rewrite HH; auto with zarith. } { intros HH; rewrite <- HH. change (1 * 2 ^ Z.of_nat size) with (phi (v30) * 2). - rewrite Z_div_plus_full_l; auto with zarith. + rewrite Z_div_plus_full_l by lia. rewrite Z.add_comm. rewrite spec_add, Zmod_small. - rewrite div31_phi; auto. - - split; auto with zarith. + - split. + case (phi_bounded (fst (r/2)%int31)); case (phi_bounded v30); auto with zarith. + rewrite div31_phi; change (phi 2) with 2; auto. @@ -2209,20 +2201,20 @@ Section Int31_Specs. * rewrite Z.mul_comm; apply Z_mult_div_ge; auto with zarith. * case (phi_bounded r); auto with zarith. } + contradict Hij; apply Z.le_ngt. - assert ((1 + [|j|]) <= 2 ^ 30); auto with zarith. + assert ((1 + [|j|]) <= 2 ^ 30). lia. apply Z.le_trans with ((2 ^ 30) * (2 ^ 30)); auto with zarith. - * assert (0 <= 1 + [|j|]); auto with zarith. - apply Z.mul_le_mono_nonneg; auto with zarith. + * assert (0 <= 1 + [|j|]). lia. + apply Z.mul_le_mono_nonneg; lia. * change ((2 ^ 30) * (2 ^ 30)) with ((2 ^ 29) * base). apply Z.le_trans with ([|ih|] * base); - change wB with base in *; auto with zarith. - unfold phi2, base; auto with zarith. + change wB with base in *; + unfold phi2, base; lia. - split; auto. apply sqrt_test_true; auto. + unfold phi2, base; auto with zarith. + apply Z.le_ge; apply Z.le_trans with (([|j|] * base)/[|j|]). - * rewrite Z.mul_comm, Z_div_mult; auto with zarith. - * apply Z.ge_le; apply Z_div_ge; auto with zarith. + * rewrite Z.mul_comm, Z_div_mult; lia. + * apply Z.ge_le; apply Z_div_ge; lia. Qed. Lemma iter312_sqrt_correct n rec ih il j: @@ -2235,17 +2227,15 @@ Section Int31_Specs. Proof. revert rec ih il j; elim n; unfold iter312_sqrt; fold iter312_sqrt; clear n. intros rec ih il j Hi Hj Hij Hrec; apply sqrt312_step_correct; auto with zarith. - intros; apply Hrec; auto with zarith. - rewrite Z.pow_0_r; auto with zarith. + intros; apply Hrec. 2: rewrite Z.pow_0_r. 1-3: lia. intros n Hrec rec ih il j Hi Hj Hij HHrec. apply sqrt312_step_correct; auto. - intros j1 Hj1 Hjp1; apply Hrec; auto with zarith. + intros j1 Hj1 Hjp1; apply Hrec. 1-3: lia. intros j2 Hj2 H2j2 Hjp2; apply Hrec; auto with zarith. intros j3 Hj3 Hpj3. apply HHrec; auto. - rewrite Nat2Z.inj_succ, Z.pow_succ_r. - apply Z.le_trans with (2 ^Z.of_nat n + [|j2|]); auto with zarith. - apply Nat2Z.is_nonneg. + rewrite Nat2Z.inj_succ, Z.pow_succ_r by lia. + lia. Qed. (* Avoid expanding [iter312_sqrt] before variables in the context. *) @@ -2264,18 +2254,18 @@ Section Int31_Specs. assert (Hb: 0 <= base) by (red; intros HH; discriminate). assert (Hi2: phi2 ih il < (phi Tn + 1) ^ 2). { change ((phi Tn + 1) ^ 2) with (2^62). - apply Z.le_lt_trans with ((2^31 -1) * base + (2^31 - 1)); auto with zarith. - 2: simpl; unfold Z.pow_pos; simpl; auto with zarith. + apply Z.le_lt_trans with ((2^31 -1) * base + (2^31 - 1)). + 2: simpl; unfold Z.pow_pos; simpl; lia. case (phi_bounded ih); case (phi_bounded il); intros H1 H2 H3 H4. unfold base, Z.pow, Z.pow_pos in H2,H4; simpl in H2,H4. - unfold phi2. cbn [Z.pow Z.pow_pos Pos.iter]. auto with zarith. } + unfold phi2. nia. } case (iter312_sqrt_correct 31 (fun _ _ j => j) ih il Tn); auto with zarith. change [|Tn|] with 2147483647; auto with zarith. intros j1 _ HH; contradict HH. apply Z.lt_nge. change [|Tn|] with 2147483647; auto with zarith. change (2 ^ Z.of_nat 31) with 2147483648; auto with zarith. - case (phi_bounded j1); auto with zarith. + case (phi_bounded j1); lia. set (s := iter312_sqrt 31 (fun _ _ j : int31 => j) ih il Tn). intros Hs1 Hs2. generalize (spec_mul_c s s); case mul31c. @@ -2287,22 +2277,22 @@ Section Int31_Specs. apply Z.le_trans with (2 ^ Z.of_nat size / 4 * base). simpl; auto with zarith. apply Z.le_trans with ([|ih|] * base); auto with zarith. - unfold phi2; case (phi_bounded il); auto with zarith. + unfold phi2; case (phi_bounded il); lia. intros ih1 il1. change [||WW ih1 il1||] with (phi2 ih1 il1). intros Hihl1. generalize (spec_sub_c il il1). case sub31c; intros il2 Hil2. - rewrite spec_compare; case Z.compare_spec. - unfold interp_carry in *. + - rewrite spec_compare; case Z.compare_spec. + + unfold interp_carry in *. intros H1; split. rewrite Z.pow_2_r, <- Hihl1. unfold phi2; ring[Hil2 H1]. replace [|il2|] with (phi2 ih il - phi2 ih1 il1). rewrite Hihl1. - rewrite <-Hbin in Hs2; auto with zarith. + rewrite <-Hbin in Hs2; lia. unfold phi2; rewrite H1, Hil2; ring. - unfold interp_carry. + + unfold interp_carry. intros H1; contradict Hs1. apply Z.lt_nge; rewrite Z.pow_2_r, <-Hihl1. unfold phi2. @@ -2310,39 +2300,39 @@ Section Int31_Specs. apply Z.lt_le_trans with (([|ih|] + 1) * base + 0). rewrite Z.mul_add_distr_r, Z.add_0_r; auto with zarith. case (phi_bounded il1); intros H3 _. - apply Z.add_le_mono; auto with zarith. - unfold interp_carry in *; change (1 * 2 ^ Z.of_nat size) with base. + nia. + + unfold interp_carry in *; change (1 * 2 ^ Z.of_nat size) with base. rewrite Z.pow_2_r, <- Hihl1, Hil2. intros H1. rewrite <- Z.le_succ_l, <- Z.add_1_r in H1. Z.le_elim H1. - contradict Hs2; apply Z.le_ngt. + * contradict Hs2; apply Z.le_ngt. replace (([|s|] + 1) ^ 2) with (phi2 ih1 il1 + 2 * [|s|] + 1). unfold phi2. case (phi_bounded il); intros Hpil _. assert (Hl1l: [|il1|] <= [|il|]). - { case (phi_bounded il2); rewrite Hil2; auto with zarith. } - assert ([|ih1|] * base + 2 * [|s|] + 1 <= [|ih|] * base); auto with zarith. + { case (phi_bounded il2); rewrite Hil2; lia. } + assert ([|ih1|] * base + 2 * [|s|] + 1 <= [|ih|] * base). 2: lia. case (phi_bounded s); change (2 ^ Z.of_nat size) with base; intros _ Hps. case (phi_bounded ih1); intros Hpih1 _; auto with zarith. - apply Z.le_trans with (([|ih1|] + 2) * base); auto with zarith. + apply Z.le_trans with (([|ih1|] + 2) * base). lia. rewrite Z.mul_add_distr_r. - assert (2 * [|s|] + 1 <= 2 * base); auto with zarith. + nia. rewrite Hihl1, Hbin; auto. - split. + * split. unfold phi2; rewrite <- H1; ring. replace (base + ([|il|] - [|il1|])) with (phi2 ih il - ([|s|] * [|s|])). - rewrite <-Hbin in Hs2; auto with zarith. + rewrite <-Hbin in Hs2; lia. rewrite <- Hihl1; unfold phi2; rewrite <- H1; ring. - unfold interp_carry in Hil2 |- *. + - unfold interp_carry in Hil2 |- *. unfold interp_carry; change (1 * 2 ^ Z.of_nat size) with base. assert (Hsih: [|ih - 1|] = [|ih|] - 1). { rewrite spec_sub, Zmod_small; auto; change [|1|] with 1. case (phi_bounded ih); intros H1 H2. generalize Hih; change (2 ^ Z.of_nat size / 4) with 536870912. - split; auto with zarith. } + lia. } rewrite spec_compare; case Z.compare_spec. - rewrite Hsih. + + rewrite Hsih. intros H1; split. rewrite Z.pow_2_r, <- Hihl1. unfold phi2; rewrite <-H1. @@ -2352,7 +2342,7 @@ Section Int31_Specs. change (2 ^ Z.of_nat size) with base; ring. replace [|il2|] with (phi2 ih il - phi2 ih1 il1). rewrite Hihl1. - rewrite <-Hbin in Hs2; auto with zarith. + rewrite <-Hbin in Hs2; lia. unfold phi2. rewrite <-H1. ring_simplify. @@ -2360,9 +2350,9 @@ Section Int31_Specs. ring. rewrite <-Hil2. change (2 ^ Z.of_nat size) with base; ring. - rewrite Hsih; intros H1. + + rewrite Hsih; intros H1. assert (He: [|ih|] = [|ih1|]). - { apply Z.le_antisymm; auto with zarith. + { apply Z.le_antisymm. lia. case (Z.le_gt_cases [|ih1|] [|ih|]); auto; intros H2. contradict Hs1; apply Z.lt_nge; rewrite Z.pow_2_r, <-Hihl1. unfold phi2. @@ -2371,42 +2361,41 @@ Section Int31_Specs. apply Z.lt_le_trans with (([|ih|] + 1) * base). rewrite Z.mul_add_distr_r, Z.mul_1_l; auto with zarith. case (phi_bounded il1); intros Hpil2 _. - apply Z.le_trans with (([|ih1|]) * base); auto with zarith. } + nia. } rewrite Z.pow_2_r, <-Hihl1; unfold phi2; rewrite <-He. contradict Hs1; apply Z.lt_nge; rewrite Z.pow_2_r, <-Hihl1. unfold phi2; rewrite He. - assert (phi il - phi il1 < 0); auto with zarith. + assert (phi il - phi il1 < 0). 2: lia. rewrite <-Hil2. - case (phi_bounded il2); auto with zarith. - intros H1. + case (phi_bounded il2); lia. + + intros H1. rewrite Z.pow_2_r, <-Hihl1. - assert (H2 : [|ih1|]+2 <= [|ih|]); auto with zarith. + assert (H2 : [|ih1|]+2 <= [|ih|]). lia. Z.le_elim H2. - contradict Hs2; apply Z.le_ngt. + * contradict Hs2; apply Z.le_ngt. replace (([|s|] + 1) ^ 2) with (phi2 ih1 il1 + 2 * [|s|] + 1). unfold phi2. - assert ([|ih1|] * base + 2 * phi s + 1 <= [|ih|] * base + ([|il|] - [|il1|])); - auto with zarith. + assert ([|ih1|] * base + 2 * phi s + 1 <= [|ih|] * base + ([|il|] - [|il1|])). + 2: lia. rewrite <-Hil2. change (-1 * 2 ^ Z.of_nat size) with (-base). case (phi_bounded il2); intros Hpil2 _. - apply Z.le_trans with ([|ih|] * base + - base); auto with zarith. + apply Z.le_trans with ([|ih|] * base + - base). 2: lia. case (phi_bounded s); change (2 ^ Z.of_nat size) with base; intros _ Hps. - assert (2 * [|s|] + 1 <= 2 * base); auto with zarith. - apply Z.le_trans with ([|ih1|] * base + 2 * base); auto with zarith. - assert (Hi: ([|ih1|] + 3) * base <= [|ih|] * base); auto with zarith. - rewrite Z.mul_add_distr_r in Hi; auto with zarith. + assert (2 * [|s|] + 1 <= 2 * base). lia. + apply Z.le_trans with ([|ih1|] * base + 2 * base). lia. + assert (Hi: ([|ih1|] + 3) * base <= [|ih|] * base). nia. lia. rewrite Hihl1, Hbin; auto. - unfold phi2; rewrite <-H2. + * unfold phi2; rewrite <-H2. split. - replace [|il|] with (([|il|] - [|il1|]) + [|il1|]); try ring. + replace [|il|] with (([|il|] - [|il1|]) + [|il1|]) by ring. rewrite <-Hil2. change (-1 * 2 ^ Z.of_nat size) with (-base); ring. replace (base + [|il2|]) with (phi2 ih il - phi2 ih1 il1). rewrite Hihl1. - rewrite <-Hbin in Hs2; auto with zarith. + rewrite <-Hbin in Hs2; lia. unfold phi2; rewrite <-H2. - replace [|il|] with (([|il|] - [|il1|]) + [|il1|]); try ring. + replace [|il|] with (([|il|] - [|il1|]) + [|il1|]) by ring. rewrite <-Hil2. change (-1 * 2 ^ Z.of_nat size) with (-base); ring. Qed. @@ -2436,8 +2425,8 @@ Qed. destruct H; auto with zarith. replace ([|x|] mod 2) with [|r|]. destruct H; auto with zarith. - case Z.compare_spec; auto with zarith. - apply Zmod_unique with [|q|]; auto with zarith. + case Z.compare_spec; lia. + apply Zmod_unique with [|q|]; lia. Qed. (* Bitwise *) diff --git a/theories/Numbers/Cyclic/Int31/Ring31.v b/theories/Numbers/Cyclic/Int31/Ring31.v index 890f42d301..1069a79e76 100644 --- a/theories/Numbers/Cyclic/Int31/Ring31.v +++ b/theories/Numbers/Cyclic/Int31/Ring31.v @@ -13,7 +13,7 @@ (** * Int31 numbers defines Z/(2^31)Z, and can hence be equipped with a ring structure and a ring tactic *) -Require Import Int31 Cyclic31 CyclicAxioms. +Require Import Lia Int31 Cyclic31 CyclicAxioms. Local Open Scope int31_scope. @@ -85,10 +85,11 @@ Qed. Lemma eqb31_eq : forall x y, eqb31 x y = true <-> x=y. Proof. unfold eqb31. intros x y. -rewrite Cyclic31.spec_compare. case Z.compare_spec. -intuition. apply Int31_canonic; auto. -intuition; subst; auto with zarith; try discriminate. -intuition; subst; auto with zarith; try discriminate. +rewrite Cyclic31.spec_compare. +split. +case Z.compare_spec. +intuition. apply Int31_canonic; auto. 1-2: easy. +now intros ->; rewrite Z.compare_refl. Qed. Lemma eqb31_correct : forall x y, eqb31 x y = true -> x=y. diff --git a/theories/Numbers/Cyclic/Int63/Int63.v b/theories/Numbers/Cyclic/Int63/Int63.v index 9e9481341f..febf4fa1be 100644 --- a/theories/Numbers/Cyclic/Int63/Int63.v +++ b/theories/Numbers/Cyclic/Int63/Int63.v @@ -15,6 +15,7 @@ Require Export DoubleType. Require Import Lia. Require Import Zpow_facts. Require Import Zgcd_alt. +Require ZArith. Import Znumtheory. Register bool as kernel.ind_bool. @@ -1354,8 +1355,8 @@ Lemma sqrt_spec : forall x, Proof. intros i; unfold sqrt. rewrite compare_spec. case Z.compare_spec; rewrite to_Z_1; - intros Hi; auto with zarith. - repeat rewrite Z.pow_2_r; auto with zarith. + intros Hi. + lia. apply iter_sqrt_correct; auto with zarith; rewrite lsr_spec, to_Z_1; change (2^1) with 2; auto with zarith. replace [|i|] with (1 * 2 + ([|i|] - 2))%Z; try ring. @@ -1571,12 +1572,11 @@ Lemma sqrt2_spec : forall x y, case (to_Z_bounded il); intros Hpil _. assert (Hl1l: [|il1|] <= [|il|]). case (to_Z_bounded il2); rewrite Hil2; auto with zarith. - assert ([|ih1|] * wB + 2 * [|s|] + 1 <= [|ih|] * wB); auto with zarith. + enough ([|ih1|] * wB + 2 * [|s|] + 1 <= [|ih|] * wB) by lia. case (to_Z_bounded s); intros _ Hps. - case (to_Z_bounded ih1); intros Hpih1 _; auto with zarith. - apply Z.le_trans with (([|ih1|] + 2) * wB); auto with zarith. - rewrite Zmult_plus_distr_l. - assert (2 * [|s|] + 1 <= 2 * wB); auto with zarith. + case (to_Z_bounded ih1); intros Hpih1 _. + apply Z.le_trans with (([|ih1|] + 2) * wB). lia. + auto with zarith. unfold zn2z_to_Z; rewrite <-Hihl1, Hbin; auto. intros H2; split. unfold zn2z_to_Z; rewrite <- H2; ring. @@ -1621,8 +1621,8 @@ Lemma sqrt2_spec : forall x y, case (to_Z_bounded s); intros _ Hps. assert (2 * [|s|] + 1 <= 2 * wB); auto with zarith. apply Z.le_trans with ([|ih1|] * wB + 2 * wB); auto with zarith. - assert (Hi: ([|ih1|] + 3) * wB <= [|ih|] * wB); auto with zarith. - rewrite Zmult_plus_distr_l in Hi; auto with zarith. + assert (Hi: ([|ih1|] + 3) * wB <= [|ih|] * wB) by auto with zarith. + lia. unfold zn2z_to_Z; rewrite <-Hihl1, Hbin; auto. intros H2; unfold zn2z_to_Z; rewrite <-H2. split. diff --git a/theories/Numbers/Cyclic/ZModulo/ZModulo.v b/theories/Numbers/Cyclic/ZModulo/ZModulo.v index 2785e89c5d..cf3e6668a5 100644 --- a/theories/Numbers/Cyclic/ZModulo/ZModulo.v +++ b/theories/Numbers/Cyclic/ZModulo/ZModulo.v @@ -23,6 +23,7 @@ Require Import Znumtheory. Require Import Zpow_facts. Require Import DoubleType. Require Import CyclicAxioms. +Require Import Lia. Local Open Scope Z_scope. @@ -113,7 +114,7 @@ Section ZModulo. Lemma spec_0 : [|zero|] = 0. Proof. unfold to_Z, zero. - apply Zmod_small; generalize wB_pos; auto with zarith. + apply Zmod_small; generalize wB_pos. lia. Qed. Lemma spec_1 : [|one|] = 1. @@ -128,10 +129,10 @@ Section ZModulo. Lemma spec_Bm1 : [|minus_one|] = wB - 1. Proof. unfold to_Z, minus_one. - apply Zmod_small; split; auto with zarith. + apply Zmod_small; split. 2: lia. unfold wB, base. - cut (1 <= 2 ^ Zpos digits); auto with zarith. - apply Z.le_trans with (Zpos digits); auto with zarith. + cut (1 <= 2 ^ Zpos digits). lia. + apply Z.le_trans with (Zpos digits). lia. apply Zpower2_le_lin; auto with zarith. Qed. @@ -162,7 +163,7 @@ Section ZModulo. assert (x mod wB <> 0). unfold eq0, to_Z in H. intro H0; rewrite H0 in H; discriminate. - rewrite Z_mod_nz_opp_full; auto with zarith. + rewrite Z_mod_nz_opp_full; lia. Qed. Lemma spec_opp : forall x, [|opp x|] = (-[|x|]) mod wB. @@ -175,14 +176,14 @@ Section ZModulo. Lemma spec_opp_carry : forall x, [|opp_carry x|] = wB - [|x|] - 1. Proof. intros; unfold opp_carry, to_Z; auto. - replace (- x - 1) with (- 1 - x) by omega. + replace (- x - 1) with (- 1 - x) by lia. rewrite <- Zminus_mod_idemp_r. - replace ( -1 - x mod wB) with (0 + ( -1 - x mod wB)) by omega. + replace ( -1 - x mod wB) with (0 + ( -1 - x mod wB)) by lia. rewrite <- (Z_mod_same_full wB). rewrite Zplus_mod_idemp_l. - replace (wB + (-1 - x mod wB)) with (wB - x mod wB -1) by omega. + replace (wB + (-1 - x mod wB)) with (wB - x mod wB -1) by lia. apply Zmod_small. - generalize (Z_mod_lt x wB wB_pos); omega. + generalize (Z_mod_lt x wB wB_pos); lia. Qed. Definition succ_c x := @@ -221,7 +222,7 @@ Section ZModulo. symmetry. rewrite Z.add_move_r. assert ((x+1) mod wB = 0) by (apply spec_eq0; auto). replace (wB-1) with ((wB-1) mod wB) by - (apply Zmod_small; generalize wB_pos; omega). + (apply Zmod_small; generalize wB_pos; lia). rewrite <- Zminus_mod_idemp_l; rewrite Z_mod_same; simpl; auto. apply Zmod_equal; auto. @@ -231,10 +232,10 @@ Section ZModulo. contradict H0. rewrite Z.add_move_r in H0; simpl in H0. rewrite <- Zplus_mod_idemp_l; rewrite H0. - replace (wB-1+1) with wB; auto with zarith; apply Z_mod_same; auto. + replace (wB-1+1) with wB by lia; apply Z_mod_same; auto. rewrite <- Zplus_mod_idemp_l. apply Zmod_small. - generalize (Z_mod_lt x wB wB_pos); omega. + generalize (Z_mod_lt x wB wB_pos); lia. Qed. Lemma spec_add_c : forall x y, [+|add_c x y|] = [|x|] + [|y|]. @@ -242,10 +243,10 @@ Section ZModulo. intros; unfold add_c, to_Z, interp_carry. destruct Z_lt_le_dec. apply Zmod_small; - generalize (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega. + generalize (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); lia. rewrite Z.mul_1_l, Z.add_comm, Z.add_move_r. apply Zmod_small; - generalize (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega. + generalize (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); lia. Qed. Lemma spec_add_carry_c : forall x y, [+|add_carry_c x y|] = [|x|] + [|y|] + 1. @@ -253,10 +254,10 @@ Section ZModulo. intros; unfold add_carry_c, to_Z, interp_carry. destruct Z_lt_le_dec. apply Zmod_small; - generalize (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega. + generalize (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); lia. rewrite Z.mul_1_l, Z.add_comm, Z.add_move_r. apply Zmod_small; - generalize (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega. + generalize (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); lia. Qed. Lemma spec_succ : forall x, [|succ x|] = ([|x|] + 1) mod wB. @@ -299,14 +300,14 @@ Section ZModulo. intros; unfold pred_c, to_Z, interp_carry. case_eq (eq0 x); intros. fold [|x|]; rewrite spec_eq0; auto. - replace ((wB-1) mod wB) with (wB-1); auto with zarith. - symmetry; apply Zmod_small; generalize wB_pos; omega. + replace ((wB-1) mod wB) with (wB-1). lia. + symmetry; apply Zmod_small; generalize wB_pos; lia. assert (x mod wB <> 0). unfold eq0, to_Z in *; now destruct (x mod wB). rewrite <- Zminus_mod_idemp_l. apply Zmod_small. - generalize (Z_mod_lt x wB wB_pos); omega. + generalize (Z_mod_lt x wB wB_pos); lia. Qed. Lemma spec_sub_c : forall x y, [-|sub_c x y|] = [|x|] - [|y|]. @@ -315,12 +316,12 @@ Section ZModulo. destruct Z_lt_le_dec. replace ((wB + (x mod wB - y mod wB)) mod wB) with (wB + (x mod wB - y mod wB)). - omega. + lia. symmetry; apply Zmod_small. - generalize wB_pos (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega. + generalize wB_pos (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); lia. apply Zmod_small. - generalize wB_pos (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega. + generalize wB_pos (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); lia. Qed. Lemma spec_sub_carry_c : forall x y, [-|sub_carry_c x y|] = [|x|] - [|y|] - 1. @@ -329,12 +330,12 @@ Section ZModulo. destruct Z_lt_le_dec. replace ((wB + (x mod wB - y mod wB - 1)) mod wB) with (wB + (x mod wB - y mod wB -1)). - omega. + lia. symmetry; apply Zmod_small. - generalize wB_pos (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega. + generalize wB_pos (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); lia. apply Zmod_small. - generalize wB_pos (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); omega. + generalize wB_pos (Z_mod_lt x wB wB_pos) (Z_mod_lt y wB wB_pos); lia. Qed. Lemma spec_pred : forall x, [|pred x|] = ([|x|] - 1) mod wB. @@ -381,12 +382,12 @@ Section ZModulo. subst h. split. apply Z_div_pos; auto with zarith. - apply Zdiv_lt_upper_bound; auto with zarith. + apply Zdiv_lt_upper_bound. lia. apply Z.mul_lt_mono_nonneg; auto with zarith. clear H H0 H1 H2. case_eq (eq0 h); simpl; intros. case_eq (eq0 l); simpl; intros. - rewrite <- H3, <- H4, (spec_eq0 h), (spec_eq0 l); auto with zarith. + rewrite <- H3, <- H4, (spec_eq0 h), (spec_eq0 l); auto. lia. rewrite H3, H4; auto with zarith. rewrite H3, H4; auto with zarith. Qed. @@ -409,7 +410,7 @@ Section ZModulo. 0 <= [|r|] < [|b|]. Proof. intros; unfold div. - assert ([|b|]>0) by auto with zarith. + assert ([|b|]>0) by lia. assert (Z.div_eucl [|a|] [|b|] = ([|a|]/[|b|], [|a|] mod [|b|])). unfold Z.modulo, Z.div; destruct Z.div_eucl; auto. generalize (Z_div_mod [|a|] [|b|] H0). @@ -417,7 +418,7 @@ Section ZModulo. injection H1 as [= ? ?]. assert ([|r|]=r). apply Zmod_small; generalize (Z_mod_lt b wB wB_pos); fold [|b|]; - auto with zarith. + lia. assert ([|q|]=q). apply Zmod_small. subst q. @@ -426,7 +427,7 @@ Section ZModulo. apply Zdiv_lt_upper_bound; auto with zarith. apply Z.lt_le_trans with (wB*1). rewrite Z.mul_1_r; auto with zarith. - apply Z.mul_le_mono_nonneg; generalize wB_pos; auto with zarith. + apply Z.mul_le_mono_nonneg; generalize wB_pos; lia. rewrite H5, H6; rewrite Z.mul_comm; auto with zarith. Qed. @@ -449,9 +450,9 @@ Section ZModulo. Proof. intros; unfold modulo. apply Zmod_small. - assert ([|b|]>0) by auto with zarith. + assert ([|b|]>0) by lia. generalize (Z_mod_lt [|a|] [|b|] H0) (Z_mod_lt b wB wB_pos). - fold [|b|]; omega. + fold [|b|]; lia. Qed. Lemma spec_modulo_gt : forall a b, [|a|] > [|b|] -> 0 < [|b|] -> @@ -470,19 +471,19 @@ Section ZModulo. destruct H2 as (q,H2); destruct H3 as (q',H3); clear H4. assert (H4:=Z.gcd_nonneg a b). destruct (Z.eq_dec (Z.gcd a b) 0) as [->|Hneq]. - generalize (Zmax_spec a b); omega. + generalize (Zmax_spec a b); lia. assert (0 <= q). - apply Z.mul_le_mono_pos_r with (Z.gcd a b); auto with zarith. + apply Z.mul_le_mono_pos_r with (Z.gcd a b); lia. destruct (Z.eq_dec q 0). subst q; simpl in *; subst a; simpl; auto. - generalize (Zmax_spec 0 b) (Zabs_spec b); omega. + generalize (Zmax_spec 0 b) (Zabs_spec b); lia. apply Z.le_trans with a. rewrite H2 at 2. rewrite <- (Z.mul_1_l (Z.gcd a b)) at 1. - apply Z.mul_le_mono_nonneg; auto with zarith. - generalize (Zmax_spec a b); omega. + apply Z.mul_le_mono_nonneg; lia. + generalize (Zmax_spec a b); lia. Qed. Lemma spec_gcd : forall a b, Zis_gcd [|a|] [|b|] [|gcd a b|]. @@ -497,7 +498,7 @@ Section ZModulo. apply Z.gcd_nonneg. apply Z.le_lt_trans with (Z.max [|a|] [|b|]). apply Zgcd_bound; auto with zarith. - generalize (Zmax_spec [|a|] [|b|]); omega. + generalize (Zmax_spec [|a|] [|b|]); lia. Qed. Lemma spec_gcd_gt : forall a b, [|a|] > [|b|] -> @@ -519,7 +520,7 @@ Section ZModulo. intros; unfold div21. generalize (Z_mod_lt a1 wB wB_pos); fold [|a1|]; intros. generalize (Z_mod_lt a2 wB wB_pos); fold [|a2|]; intros. - assert ([|b|]>0) by auto with zarith. + assert ([|b|]>0) by lia. remember ([|a1|]*wB+[|a2|]) as a. assert (Z.div_eucl a [|b|] = (a/[|b|], a mod [|b|])). unfold Z.modulo, Z.div; destruct Z.div_eucl; auto. @@ -528,18 +529,17 @@ Section ZModulo. injection H4 as [= ? ?]. assert ([|r|]=r). apply Zmod_small; generalize (Z_mod_lt b wB wB_pos); fold [|b|]; - auto with zarith. + lia. assert ([|q|]=q). apply Zmod_small. subst q. split. - apply Z_div_pos; auto with zarith. - subst a; auto with zarith. - apply Zdiv_lt_upper_bound; auto with zarith. + apply Z_div_pos. lia. + subst a. nia. + apply Zdiv_lt_upper_bound; nia. subst a. replace (wB*[|b|]) with (([|b|]-1)*wB + wB) by ring. - apply Z.lt_le_trans with ([|a1|]*wB+wB); auto with zarith. - rewrite H8, H9; rewrite Z.mul_comm; auto with zarith. + lia. Qed. Definition add_mul_div p x y := @@ -573,7 +573,7 @@ Section ZModulo. if is_even x then [|x|] mod 2 = 0 else [|x|] mod 2 = 1. Proof. intros; unfold is_even; destruct Z.eq_dec; auto. - generalize (Z_mod_lt [|x|] 2); omega. + generalize (Z_mod_lt [|x|] 2); lia. Qed. Definition sqrt x := Z.sqrt [|x|]. @@ -611,33 +611,33 @@ Section ZModulo. simpl zn2z_to_Z. remember ([|x|]*wB+[|y|]) as z. destruct z. - auto with zarith. - generalize (Z.sqrtrem_spec (Zpos p)). - destruct Z.sqrtrem as (s,r); intros [U V]; auto with zarith. + - auto with zarith. + - generalize (Z.sqrtrem_spec (Zpos p)). + destruct Z.sqrtrem as (s,r); intros [U V]. lia. assert (s < wB). + { destruct (Z_lt_le_dec s wB); auto. assert (wB * wB <= Zpos p). - rewrite U. - apply Z.le_trans with (s*s); try omega. - apply Z.mul_le_mono_nonneg; generalize wB_pos; auto with zarith. + apply Z.le_trans with (s*s). 2: lia. + apply Z.mul_le_mono_nonneg; generalize wB_pos; lia. assert (Zpos p < wB*wB). rewrite Heqz. replace (wB*wB) with ((wB-1)*wB+wB) by ring. - apply Z.add_le_lt_mono; auto with zarith. - apply Z.mul_le_mono_nonneg; auto with zarith. - generalize (spec_to_Z x); auto with zarith. - generalize wB_pos; auto with zarith. - omega. - replace [|s|] with s by (symmetry; apply Zmod_small; auto with zarith). + apply Z.add_le_lt_mono. 2: auto with zarith. + apply Z.mul_le_mono_nonneg. 1, 3-5: auto with zarith. + generalize wB_pos; lia. + generalize (spec_to_Z x); lia. + } + replace [|s|] with s by (symmetry; apply Zmod_small; lia). destruct Z_lt_le_dec; unfold interp_carry. - replace [|r|] with r by (symmetry; apply Zmod_small; auto with zarith). - rewrite Z.pow_2_r; auto with zarith. - replace [|r-wB|] with (r-wB) by (symmetry; apply Zmod_small; auto with zarith). - rewrite Z.pow_2_r; omega. + replace [|r|] with r by (symmetry; apply Zmod_small; lia). + rewrite Z.pow_2_r; lia. + replace [|r-wB|] with (r-wB) by (symmetry; apply Zmod_small; lia). + rewrite Z.pow_2_r; lia. - assert (0<=Zneg p). - rewrite Heqz; generalize wB_pos; auto with zarith. - compute in H0; elim H0; auto. + - assert (0<=Zneg p). + generalize (spec_to_Z x) (spec_to_Z y); nia. + lia. Qed. Lemma two_p_power2 : forall x, x>=0 -> two_p x = 2 ^ x. @@ -669,12 +669,12 @@ Section ZModulo. intros. assert (0 <= zdigits - Z.log2 (Zpos p) - 1 < wB) as Hrange. split. - cut (Z.log2 (Zpos p) < zdigits). omega. + cut (Z.log2 (Zpos p) < zdigits). lia. unfold zdigits. unfold wB, base in *. apply Z.log2_lt_pow2; intuition. apply Z.lt_trans with zdigits. - omega. + lia. unfold zdigits, wB, base; apply Zpower2_lt_lin; auto with zarith. unfold to_Z; rewrite (Zmod_small _ _ Hrange). @@ -728,7 +728,7 @@ Section ZModulo. rewrite Z.mul_comm. rewrite <- Z.pow_succ_r; auto with zarith. rewrite H1; auto. - rewrite <- H1; omega. + rewrite <- H1; lia. Qed. Definition tail0 x := diff --git a/theories/QArith/QArith_base.v b/theories/QArith/QArith_base.v index 54d35cded2..4239943d03 100644 --- a/theories/QArith/QArith_base.v +++ b/theories/QArith/QArith_base.v @@ -8,7 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -Require Export ZArith. +Require Export ZArith_base. Require Export ZArithRing. Require Export Morphisms Setoid Bool. diff --git a/theories/QArith/Qround.v b/theories/QArith/Qround.v index 8d68038582..35f113e226 100644 --- a/theories/QArith/Qround.v +++ b/theories/QArith/Qround.v @@ -9,6 +9,7 @@ (************************************************************************) Require Import QArith. +Import Zdiv. Lemma Qopp_lt_compat: forall p q : Q, p < q -> - q < - p. Proof. @@ -38,7 +39,7 @@ Proof. intros z. unfold Qceiling. simpl. -rewrite Zdiv_1_r. +rewrite Z.div_1_r. apply Z.opp_involutive. Qed. @@ -50,8 +51,7 @@ unfold Qle. simpl. replace (n*1)%Z with n by ring. rewrite Z.mul_comm. -apply Z_mult_div_ge. -auto with *. +now apply Z.mul_div_le. Qed. Hint Resolve Qfloor_le : qarith. diff --git a/theories/Reals/Cos_plus.v b/theories/Reals/Cos_plus.v index d09b3248ef..b411c4953a 100644 --- a/theories/Reals/Cos_plus.v +++ b/theories/Reals/Cos_plus.v @@ -14,7 +14,7 @@ Require Import SeqSeries. Require Import Rtrigo_def. Require Import Cos_rel. Require Import Max. -Require Import Omega. +Require Import Lia. Local Open Scope nat_scope. Local Open Scope R_scope. @@ -213,7 +213,7 @@ Proof. apply le_n_S. apply plus_le_compat_l; assumption. rewrite pred_of_minus. - omega. + lia. apply Rle_trans with (sum_f_R0 (fun k:nat => @@ -236,7 +236,7 @@ Proof. apply Rmult_le_compat_l. left; apply Rinv_0_lt_compat; apply INR_fact_lt_0. apply C_maj. - omega. + lia. right. unfold Rdiv; rewrite Rmult_comm. unfold Binomial.C. @@ -248,7 +248,7 @@ Proof. unfold Rsqr; reflexivity. apply INR_fact_neq_0. apply INR_fact_neq_0. - omega. + lia. apply INR_fact_neq_0. unfold Rdiv; rewrite Rmult_comm. unfold Binomial.C. @@ -258,7 +258,7 @@ Proof. replace (2 * S (N + n) - 2 * S (n0 + n))%nat with (2 * (N - n0))%nat. rewrite mult_INR. reflexivity. - omega. + lia. apply INR_fact_neq_0. apply Rle_trans with (sum_f_R0 (fun k:nat => INR N / INR (fact (S N)) * C ^ (4 * N)) (pred N)). @@ -279,7 +279,7 @@ Proof. apply Rmult_le_compat_l. apply Rle_0_sqr. apply le_INR. - omega. + lia. rewrite Rmult_comm; unfold Rdiv; apply Rmult_le_compat_l. apply pos_INR. apply Rle_trans with (/ INR (fact (S (N + n)))). @@ -458,7 +458,7 @@ Proof. (2 * (N - n0) + 1 + (2 * S (n0 + n) + 1))%nat. repeat rewrite pow_add. ring. - omega. + lia. apply INR_fact_neq_0. apply INR_fact_neq_0. apply Rle_ge; left; apply Rinv_0_lt_compat. @@ -517,7 +517,7 @@ Proof. replace (2 * S (S (n0 + n)))%nat with (S (2 * S (n0 + n) + 1)). apply le_n_Sn. ring. - omega. + lia. right. unfold Rdiv; rewrite Rmult_comm. unfold Binomial.C. @@ -529,7 +529,7 @@ Proof. unfold Rsqr; reflexivity. apply INR_fact_neq_0. apply INR_fact_neq_0. - omega. + lia. apply INR_fact_neq_0. unfold Rdiv; rewrite Rmult_comm. unfold Binomial.C. @@ -540,7 +540,7 @@ Proof. (2 * (N - n0) + 1)%nat. rewrite mult_INR. reflexivity. - omega. + lia. apply INR_fact_neq_0. apply Rle_trans with (sum_f_R0 (fun k:nat => INR N / INR (fact (S (S N))) * C ^ (4 * S N)) @@ -563,8 +563,8 @@ Proof. apply Rle_0_sqr. replace (S (pred (N - n))) with (N - n)%nat. apply le_INR. - omega. - omega. + lia. + lia. rewrite Rmult_comm; unfold Rdiv; apply Rmult_le_compat_l. apply pos_INR. apply Rle_trans with (/ INR (fact (S (S (N + n))))). @@ -592,7 +592,7 @@ Proof. rewrite Rmult_1_r. apply le_INR. apply fact_le. - omega. + lia. apply INR_fact_neq_0. apply INR_fact_neq_0. rewrite sum_cte. diff --git a/theories/Reals/Cos_rel.v b/theories/Reals/Cos_rel.v index d5086db6cf..4ce5cd6b1c 100644 --- a/theories/Reals/Cos_rel.v +++ b/theories/Reals/Cos_rel.v @@ -12,7 +12,7 @@ Require Import Rbase. Require Import Rfunctions. Require Import SeqSeries. Require Import Rtrigo_def. -Require Import OmegaTactic. +Require Import Lia. Local Open Scope R_scope. Definition A1 (x:R) (N:nat) : R := @@ -149,13 +149,13 @@ unfold Wn. apply Rmult_eq_compat_l. replace (2 * S i - S (2 * i0))%nat with (S (2 * (i - i0))). reflexivity. -omega. +lia. apply sum_eq; intros. unfold Wn. apply Rmult_eq_compat_l. replace (2 * S i - 2 * i0)%nat with (2 * (S i - i0))%nat. reflexivity. -omega. +lia. replace (- sum_f_R0 @@ -211,7 +211,7 @@ replace (S (2 * i0)) with (2 * i0 + 1)%nat; [ apply Rmult_eq_compat_l | ring ]. replace (2 * S i - (2 * i0 + 1))%nat with (2 * (i - i0) + 1)%nat. reflexivity. -omega. +lia. apply INR_fact_neq_0. apply INR_fact_neq_0. apply INR_fact_neq_0. @@ -240,7 +240,7 @@ rewrite Rmult_1_l. rewrite Rinv_mult_distr. replace (2 * i - 2 * i0)%nat with (2 * (i - i0))%nat. reflexivity. -omega. +lia. apply INR_fact_neq_0. apply INR_fact_neq_0. apply INR_fact_neq_0. diff --git a/theories/Reals/DiscrR.v b/theories/Reals/DiscrR.v index 9205df1bb7..2ae93c8705 100644 --- a/theories/Reals/DiscrR.v +++ b/theories/Reals/DiscrR.v @@ -9,7 +9,7 @@ (************************************************************************) Require Import RIneq. -Require Import Omega. +Require Import Lia. Local Open Scope R_scope. Lemma Rlt_R0_R2 : 0 < 2. @@ -49,7 +49,7 @@ Ltac omega_sup := repeat rewrite <- plus_IZR || rewrite <- mult_IZR || rewrite <- Ropp_Ropp_IZR || rewrite Z_R_minus; - apply IZR_lt; omega. + apply IZR_lt; lia. Ltac prove_sup := match goal with diff --git a/theories/Reals/Exp_prop.v b/theories/Reals/Exp_prop.v index 1636d81d25..2c822da055 100644 --- a/theories/Reals/Exp_prop.v +++ b/theories/Reals/Exp_prop.v @@ -17,7 +17,7 @@ Require Import PSeries_reg. Require Import Div2. Require Import Even. Require Import Max. -Require Import Omega. +Require Import Lia. Local Open Scope nat_scope. Local Open Scope R_scope. @@ -488,8 +488,8 @@ Proof. rewrite div2_S_double. apply S_pred with 0%nat; apply H3. reflexivity. - omega. - omega. + lia. + lia. rewrite H2. replace (pred (S (2 * N0))) with (2 * N0)%nat; [ idtac | reflexivity ]. replace (S (S (2 * N0))) with (2 * S N0)%nat. @@ -549,15 +549,15 @@ Proof. rewrite H6. replace (pred (2 * N1)) with (S (2 * pred N1)). rewrite div2_S_double. - omega. - omega. + lia. + lia. assert (0 < n)%nat. apply lt_le_trans with 2%nat. apply lt_O_Sn. apply le_trans with (max (2 * S N0) 2). apply le_max_r. apply H3. - omega. + lia. rewrite H6. replace (pred (S (2 * N1))) with (2 * N1)%nat. rewrite div2_double. diff --git a/theories/Reals/Machin.v b/theories/Reals/Machin.v index 08bc38a085..d5a39f527f 100644 --- a/theories/Reals/Machin.v +++ b/theories/Reals/Machin.v @@ -8,7 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -Require Import Omega. +Require Import Lia. Require Import Lra. Require Import Rbase. Require Import Rtrigo1. @@ -163,8 +163,8 @@ assert (cv : Un_cv PI_2_3_7_tg 0). rewrite <- (Rmult_0_r 2), <- Ropp_mult_distr_r_reverse. rewrite <- Rmult_plus_distr_l, Rabs_mult, (Rabs_pos_eq 2);[|lra]. rewrite Rmult_assoc; apply Rmult_lt_compat_l;[lra | ]. - apply (Pn1 n); omega. - apply (Pn2 n); omega. + apply (Pn1 n); lia. + apply (Pn2 n); lia. rewrite Machin_2_3_7. rewrite !atan_eq_ps_atan; try (split; lra). unfold ps_atan; destruct (in_int (/3)); destruct (in_int (/7)); diff --git a/theories/Reals/RIneq.v b/theories/Reals/RIneq.v index 7813c7b975..229e6018ca 100644 --- a/theories/Reals/RIneq.v +++ b/theories/Reals/RIneq.v @@ -19,7 +19,7 @@ Require Export Raxioms. Require Import Rpow_def. Require Import Zpower. Require Export ZArithRing. -Require Import Omega. +Require Import Lia. Require Export RealField. Local Open Scope Z_scope. @@ -1875,7 +1875,7 @@ Lemma eq_IZR : forall n m:Z, IZR n = IZR m -> n = m. Proof. intros z1 z2 H; generalize (Rminus_diag_eq (IZR z1) (IZR z2) H); rewrite (Z_R_minus z1 z2); intro; generalize (eq_IZR_R0 (z1 - z2) H0); - intro; omega. + intro; lia. Qed. (**********) @@ -1913,21 +1913,21 @@ Qed. Lemma IZR_ge : forall n m:Z, (n >= m)%Z -> IZR n >= IZR m. Proof. intros m n H; apply Rnot_lt_ge; red; intro. - generalize (lt_IZR m n H0); intro; omega. + generalize (lt_IZR m n H0); intro; lia. Qed. Lemma IZR_le : forall n m:Z, (n <= m)%Z -> IZR n <= IZR m. Proof. intros m n H; apply Rnot_gt_le; red; intro. - unfold Rgt in H0; generalize (lt_IZR n m H0); intro; omega. + unfold Rgt in H0; generalize (lt_IZR n m H0); intro; lia. Qed. Lemma IZR_lt : forall n m:Z, (n < m)%Z -> IZR n < IZR m. Proof. intros m n H; cut (m <= n)%Z. intro H0; elim (IZR_le m n H0); intro; auto. - generalize (eq_IZR m n H1); intro; exfalso; omega. - omega. + generalize (eq_IZR m n H1); intro; exfalso; lia. + lia. Qed. Lemma IZR_neq : forall z1 z2:Z, z1 <> z2 -> IZR z1 <> IZR z2. @@ -1954,7 +1954,7 @@ Lemma one_IZR_r_R1 : forall r (n m:Z), r < IZR n <= r + 1 -> r < IZR m <= r + 1 -> n = m. Proof. intros r z x [H1 H2] [H3 H4]. - cut ((z - x)%Z = 0%Z); auto with zarith. + cut ((z - x)%Z = 0%Z). lia. apply one_IZR_lt1. rewrite <- Z_R_minus; split. replace (-1) with (r - (r + 1)). diff --git a/theories/Reals/R_Ifp.v b/theories/Reals/R_Ifp.v index 5365e04000..5f0747d869 100644 --- a/theories/Reals/R_Ifp.v +++ b/theories/Reals/R_Ifp.v @@ -14,7 +14,7 @@ (**********************************************************) Require Import Rbase. -Require Import Omega. +Require Import Lia. Local Open Scope R_scope. (*********************************************************) @@ -60,7 +60,7 @@ Proof. apply lt_IZR in H1. rewrite <- minus_IZR in H2. apply le_IZR in H2. - omega. + lia. Qed. (**********) @@ -230,7 +230,7 @@ Proof. rewrite <- (plus_IZR (Int_part r1 - Int_part r2) 1) in H; generalize (up_tech (r1 - r2) (Int_part r1 - Int_part r2) H0 H); intros; clear H H0; unfold Int_part at 1; - omega. + lia. Qed. (**********) @@ -314,7 +314,7 @@ Proof. in H0; fold (IZR (Int_part r1) - IZR (Int_part r2) - 1) in H0; rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H0; rewrite (Z_R_minus (Int_part r1) (Int_part r2)) in H; - auto with zarith real. + auto with real. change (_ + -1) with (IZR (Int_part r1 - Int_part r2) - 1) in H; rewrite (Z_R_minus (Int_part r1 - Int_part r2) 1) in H; rewrite (Z_R_minus (Int_part r1 - Int_part r2) 1) in H0; @@ -323,7 +323,7 @@ Proof. intro; clear H; generalize (up_tech (r1 - r2) (Int_part r1 - Int_part r2 - 1) H1 H0); intros; clear H0 H1; unfold Int_part at 1; - omega. + lia. Qed. (**********) @@ -430,14 +430,14 @@ Proof. clear a b; change 2 with (1 + 1) in H0; rewrite <- (Rplus_assoc (IZR (Int_part r1) + IZR (Int_part r2)) 1 1) in H0; - auto with zarith real. + auto with real. rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H; rewrite <- (plus_IZR (Int_part r1) (Int_part r2)) in H0; rewrite <- (plus_IZR (Int_part r1 + Int_part r2) 1) in H; rewrite <- (plus_IZR (Int_part r1 + Int_part r2) 1) in H0; rewrite <- (plus_IZR (Int_part r1 + Int_part r2 + 1) 1) in H0; generalize (up_tech (r1 + r2) (Int_part r1 + Int_part r2 + 1) H H0); - intro; clear H H0; unfold Int_part at 1; omega. + intro; clear H H0; unfold Int_part at 1; lia. Qed. (**********) @@ -499,7 +499,7 @@ Proof. rewrite <- (plus_IZR (Int_part r1 + Int_part r2) 1) in H1; generalize (up_tech (r1 + r2) (Int_part r1 + Int_part r2) H0 H1); intro; clear H0 H1; unfold Int_part at 1; - omega. + lia. Qed. (**********) @@ -522,7 +522,7 @@ Proof. rewrite (Rplus_assoc (r1 + r2) (- (IZR (Int_part r1) + IZR (Int_part r2))) (-(1))) ; rewrite <- (Ropp_plus_distr (IZR (Int_part r1) + IZR (Int_part r2)) 1); - trivial with zarith real. + trivial with real. Qed. (**********) diff --git a/theories/Reals/Ranalysis2.v b/theories/Reals/Ranalysis2.v index 7a838f2772..3f560f202e 100644 --- a/theories/Reals/Ranalysis2.v +++ b/theories/Reals/Ranalysis2.v @@ -11,7 +11,6 @@ Require Import Rbase. Require Import Rfunctions. Require Import Ranalysis1. -Require Import Omega. Local Open Scope R_scope. (**********) diff --git a/theories/Reals/Ranalysis5.v b/theories/Reals/Ranalysis5.v index ca82222c25..11835bd24a 100644 --- a/theories/Reals/Ranalysis5.v +++ b/theories/Reals/Ranalysis5.v @@ -16,7 +16,7 @@ Require Import Lra. Require Import RiemannInt. Require Import SeqProp. Require Import Max. -Require Import Omega. +Require Import Lia. Require Import Lra. Local Open Scope R_scope. @@ -1095,11 +1095,11 @@ assert (Main : Rabs ((f (x+h) - fn N (x+h)) - (f x - fn N x) + (fn N (x+h) - fn apply Rlt_trans with (Rabs h * eps / 4 + Rabs (f x - fn N x) + Rabs h * Rabs (fn' N c - g x)). apply Rplus_lt_compat_r ; apply Rplus_lt_compat_r ; unfold R_dist in fnxh_CV_fxh ; rewrite Rabs_minus_sym ; apply fnxh_CV_fxh. - unfold N; omega. + unfold N; lia. apply Rlt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 + Rabs h * Rabs (fn' N c - g x)). apply Rplus_lt_compat_r ; apply Rplus_lt_compat_l. unfold R_dist in fnx_CV_fx ; rewrite Rabs_minus_sym ; apply fnx_CV_fx. - unfold N ; omega. + unfold N ; lia. replace (fn' N c - g x) with ((fn' N c - g c) + (g c - g x)) by field. apply Rle_lt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 + Rabs h * Rabs (fn' N c - g c) + Rabs h * Rabs (g c - g x)). @@ -1113,7 +1113,7 @@ assert (Main : Rabs ((f (x+h) - fn N (x+h)) - (f x - fn N x) + (fn N (x+h) - fn apply Rplus_lt_compat_r; apply Rplus_lt_compat_l; apply Rmult_lt_compat_l. apply Rabs_pos_lt ; assumption. rewrite Rabs_minus_sym ; apply fn'c_CVU_gc. - unfold N ; omega. + unfold N ; lia. assert (t : Boule x delta c). destruct P. apply Rabs_def2 in xhinbxdelta; destruct xhinbxdelta. @@ -1201,11 +1201,11 @@ assert (Main : Rabs ((f (x+h) - fn N (x+h)) - (f x - fn N x) + (fn N (x+h) - fn apply Rlt_trans with (Rabs h * eps / 4 + Rabs (f x - fn N x) + Rabs h * Rabs (fn' N c - g x)). apply Rplus_lt_compat_r ; apply Rplus_lt_compat_r ; unfold R_dist in fnxh_CV_fxh ; rewrite Rabs_minus_sym ; apply fnxh_CV_fxh. - unfold N; omega. + unfold N; lia. apply Rlt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 + Rabs h * Rabs (fn' N c - g x)). apply Rplus_lt_compat_r ; apply Rplus_lt_compat_l. unfold R_dist in fnx_CV_fx ; rewrite Rabs_minus_sym ; apply fnx_CV_fx. - unfold N ; omega. + unfold N ; lia. replace (fn' N c - g x) with ((fn' N c - g c) + (g c - g x)) by field. apply Rle_lt_trans with (Rabs h * eps / 4 + Rabs h * eps / 4 + Rabs h * Rabs (fn' N c - g c) + Rabs h * Rabs (g c - g x)). @@ -1219,7 +1219,7 @@ assert (Main : Rabs ((f (x+h) - fn N (x+h)) - (f x - fn N x) + (fn N (x+h) - fn apply Rplus_lt_compat_r; apply Rplus_lt_compat_l; apply Rmult_lt_compat_l. apply Rabs_pos_lt ; assumption. rewrite Rabs_minus_sym ; apply fn'c_CVU_gc. - unfold N ; omega. + unfold N ; lia. assert (t : Boule x delta c). destruct P. apply Rabs_def2 in xhinbxdelta; destruct xhinbxdelta. diff --git a/theories/Reals/Ratan.v b/theories/Reals/Ratan.v index 57bc89b7e5..e822b87cc6 100644 --- a/theories/Reals/Ratan.v +++ b/theories/Reals/Ratan.v @@ -20,7 +20,7 @@ Require Import SeqProp. Require Import Ranalysis5. Require Import SeqSeries. Require Import PartSum. -Require Import Omega. +Require Import Lia. Local Open Scope R_scope. @@ -76,30 +76,30 @@ clear. intros [ | n] P Hs Ho;[solve[apply Ho, Hs] | apply Hs; auto with arith]. intros N; pattern N; apply WLOG; clear N. intros [ | N] Npos n decr to0 cv nN. - clear -Npos; elimtype False; omega. + lia. assert (decr' : Un_decreasing (fun i => f (S N + i)%nat)). intros k; replace (S N+S k)%nat with (S (S N+k)) by ring. apply (decr (S N + k)%nat). assert (to' : Un_cv (fun i => f (S N + i)%nat) 0). intros eps ep; destruct (to0 eps ep) as [M PM]. - exists M; intros k kM; apply PM; omega. + exists M; intros k kM; apply PM; lia. assert (cv' : Un_cv (sum_f_R0 (tg_alt (fun i => ((-1) ^ S N * f(S N + i)%nat)))) (l - sum_f_R0 (tg_alt f) N)). intros eps ep; destruct (cv eps ep) as [M PM]; exists M. intros n' nM. match goal with |- ?C => set (U := C) end. - assert (nM' : (n' + S N >= M)%nat) by omega. + assert (nM' : (n' + S N >= M)%nat) by lia. generalize (PM _ nM'); unfold R_dist. rewrite (tech2 (tg_alt f) N (n' + S N)). assert (t : forall a b c, (a + b) - c = b - (c - a)) by (intros; ring). rewrite t; clear t; unfold U, R_dist; clear U. - replace (n' + S N - S N)%nat with n' by omega. + replace (n' + S N - S N)%nat with n' by lia. rewrite <- (sum_eq (tg_alt (fun i => (-1) ^ S N * f(S N + i)%nat))). tauto. intros i _; unfold tg_alt. rewrite <- Rmult_assoc, <- pow_add, !(plus_comm i); reflexivity. - omega. + lia. assert (cv'' : Un_cv (sum_f_R0 (tg_alt (fun i => f (S N + i)%nat))) ((-1) ^ S N * (l - sum_f_R0 (tg_alt f) N))). apply (Un_cv_ext (fun n => (-1) ^ S N * @@ -118,7 +118,7 @@ intros [ | N] Npos n decr to0 cv nN. rewrite neven. destruct (alternated_series_ineq _ _ p' decr to0 cv) as [D E]. unfold R_dist; rewrite Rabs_pos_eq;[ | lra]. - assert (dist : (p <= p')%nat) by omega. + assert (dist : (p <= p')%nat) by lia. assert (t := decreasing_prop _ _ _ (CV_ALT_step1 f decr) dist). apply Rle_trans with (sum_f_R0 (tg_alt f) (2 * p) - l). unfold Rminus; apply Rplus_le_compat_r; exact t. @@ -129,7 +129,7 @@ intros [ | N] Npos n decr to0 cv nN. rewrite nodd; destruct (alternated_series_ineq _ _ p' decr to0 cv) as [D E]. unfold R_dist; rewrite <- Rabs_Ropp, Rabs_pos_eq, Ropp_minus_distr; [ | lra]. - assert (dist : (p <= p')%nat) by omega. + assert (dist : (p <= p')%nat) by lia. apply Rle_trans with (l - sum_f_R0 (tg_alt f) (S (2 * p))). unfold Rminus; apply Rplus_le_compat_l, Ropp_le_contravar. solve[apply Rge_le, (growing_prop _ _ _ (CV_ALT_step0 f decr) dist)]. @@ -142,11 +142,11 @@ intros [ | N] Npos n decr to0 cv nN. rewrite neven; destruct (alternated_series_ineq _ _ p' decr to0 cv) as [D E]. unfold R_dist; rewrite Rabs_pos_eq;[ | lra]. - assert (dist : (S p < S p')%nat) by omega. + assert (dist : (S p < S p')%nat) by lia. apply Rle_trans with (sum_f_R0 (tg_alt f) (2 * S p) - l). unfold Rminus; apply Rplus_le_compat_r, (decreasing_prop _ _ _ (CV_ALT_step1 f decr)). - omega. + lia. rewrite keep, tech5; unfold tg_alt at 2; rewrite <- keep, pow_1_even. lra. rewrite nodd; destruct (alternated_series_ineq _ _ p' decr to0 cv) as [D E]. @@ -154,7 +154,7 @@ intros [ | N] Npos n decr to0 cv nN. rewrite Ropp_minus_distr. apply Rle_trans with (l - sum_f_R0 (tg_alt f) (S (2 * p))). unfold Rminus; apply Rplus_le_compat_l, Ropp_le_contravar, Rge_le, - (growing_prop _ _ _ (CV_ALT_step0 f decr)); omega. + (growing_prop _ _ _ (CV_ALT_step0 f decr)); lia. generalize C; rewrite keep, tech5; unfold tg_alt. rewrite <- keep, pow_1_even. assert (t : forall a b c, a <= b + 1 * c -> a - b <= c) by (intros; lra). @@ -166,7 +166,7 @@ clear WLOG; intros Hyp [ | n] decr to0 cv _. intros [A B]; rewrite Rabs_pos_eq; lra. apply Rle_trans with (f 1%nat). apply (Hyp 1%nat (le_n 1) (S n) decr to0 cv). - omega. + lia. solve[apply decr]. Qed. @@ -746,7 +746,7 @@ intros x Hx n. apply Rlt_le. apply Rinv_0_lt_compat. apply lt_INR_0. - omega. + lia. destruct (proj1 Hx) as [Hx1|Hx1]. destruct (proj2 Hx) as [Hx2|Hx2]. (* . 0 < x < 1 *) @@ -762,7 +762,7 @@ intros x Hx n. rewrite Rmult_1_r. exact Hx1. exact Hx2. - omega. + lia. apply Rgt_not_eq. exact Hx1. (* . x = 1 *) @@ -771,13 +771,13 @@ intros x Hx n. apply Rle_refl. (* . x = 0 *) rewrite <- Hx1. - do 2 (rewrite pow_i ; [ idtac | omega ]). + do 2 (rewrite pow_i ; [ idtac | lia ]). apply Rle_refl. apply Rlt_le. apply Rinv_lt_contravar. - apply Rmult_lt_0_compat ; apply lt_INR_0 ; omega. + apply Rmult_lt_0_compat ; apply lt_INR_0 ; lia. apply lt_INR. - omega. + lia. Qed. Lemma Ratan_seq_converging : forall x, (0 <= x <= 1)%R -> Un_cv (Ratan_seq x) 0. @@ -808,7 +808,7 @@ intros x Hx eps Heps. apply Rlt_le. apply Rinv_0_lt_compat. apply lt_INR_0. - omega. + lia. apply pow_incr. exact Hx. rewrite pow1. @@ -817,15 +817,15 @@ intros x Hx eps Heps. rewrite Rmult_1_l. apply Rinv_le_contravar. apply lt_INR_0. - omega. + lia. apply le_INR. - omega. + lia. rewrite <- (Rinv_involutive eps). apply Rinv_lt_contravar. apply Rmult_lt_0_compat. auto with real. apply lt_INR_0. - omega. + lia. apply Rlt_trans with (INR N). destruct (archimed (/ eps)) as (H,_). assert (0 < up (/ eps))%Z. @@ -837,7 +837,7 @@ intros x Hx eps Heps. rewrite INR_IZR_INZ, positive_nat_Z. exact HN. apply lt_INR. - omega. + lia. apply Rgt_not_eq. exact Heps. apply Rle_ge. @@ -848,7 +848,7 @@ intros x Hx eps Heps. apply Rlt_le. apply Rinv_0_lt_compat. apply lt_INR_0. - omega. + lia. Qed. Definition ps_atan_exists_01 (x : R) (Hx:0 <= x <= 1) : @@ -1045,7 +1045,7 @@ intros x n x_lb ; unfold Datan_seq ; induction n. apply Rmult_gt_0_compat. replace (x^2) with (x*x) by field ; apply Rmult_gt_0_compat ; assumption. assumption. - replace (2 * S n)%nat with (S (S (2 * n))) by intuition. + replace (2 * S n)%nat with (S (S (2 * n))) by lia. simpl ; field. Qed. @@ -1067,8 +1067,7 @@ Lemma Datan_seq_increasing : forall x y n, (n > 0)%nat -> 0 <= x < y -> Datan_se Proof. intros x y n n_lb x_encad ; assert (x_pos : x >= 0) by intuition. assert (y_pos : y > 0). apply Rle_lt_trans with (r2:=x) ; intuition. - induction n. - apply False_ind ; intuition. + induction n. lia. clear -x_encad x_pos y_pos ; induction n ; unfold Datan_seq. case x_pos ; clear x_pos ; intro x_pos. simpl ; apply Rmult_gt_0_lt_compat ; intuition. lra. @@ -1077,14 +1076,14 @@ intros x y n n_lb x_encad ; assert (x_pos : x >= 0) by intuition. simpl ; field. intuition. assert (Hrew : forall a, a^(2 * S (S n)) = (a ^ 2) * (a ^ (2 * S n))). - clear ; intro a ; replace (2 * S (S n))%nat with (S (S (2 * S n)))%nat by intuition. + clear ; intro a ; replace (2 * S (S n))%nat with (S (S (2 * S n)))%nat by lia. simpl ; field. case x_pos ; clear x_pos ; intro x_pos. rewrite Hrew ; rewrite Hrew. apply Rmult_gt_0_lt_compat ; intuition. apply Rmult_gt_0_lt_compat ; intuition ; lra. rewrite x_pos. - rewrite pow_i ; intuition. + rewrite pow_i. intuition. lia. Qed. Lemma Datan_seq_decreasing : forall x, -1 < x -> x < 1 -> Un_decreasing (Datan_seq x). @@ -1101,7 +1100,7 @@ assert (intabs : 0 <= Rabs x < 1). split;[apply Rabs_pos | apply Rabs_def1]; tauto. apply (pow_lt_1_compat (Rabs x) 2) in intabs. tauto. -omega. +lia. Qed. Lemma Datan_seq_CV_0 : forall x, -1 < x -> x < 1 -> Un_cv (Datan_seq x) 0. @@ -1112,7 +1111,7 @@ assert (x_ub2 : Rabs (x^2) < 1). rewrite <- pow2_abs. assert (H: 0 <= Rabs x < 1) by (split;[apply Rabs_pos | apply Rabs_def1; auto]). - apply (pow_lt_1_compat _ 2) in H;[tauto | omega]. + apply (pow_lt_1_compat _ 2) in H;[tauto | lia]. elim (pow_lt_1_zero (x^2) x_ub2 eps eps_pos) ; intros N HN ; exists N ; intros n Hn. unfold R_dist, Datan_seq. replace (x ^ (2 * n) - 0) with ((x ^ 2) ^ n). apply HN ; assumption. @@ -1130,7 +1129,7 @@ assert (Tool2 : / (1 + x ^ 2) > 0). apply Rinv_0_lt_compat ; tauto. assert (x_ub2' : 0<= Rabs (x^2) < 1). rewrite Rabs_pos_eq, <- pow2_abs;[ | apply pow2_ge_0]. - apply pow_lt_1_compat;[split;[apply Rabs_pos | ] | omega]. + apply pow_lt_1_compat;[split;[apply Rabs_pos | ] | lia]. apply Rabs_def1; assumption. assert (x_ub2 : Rabs (x^2) < 1) by tauto. assert (eps'_pos : ((1+x^2)*eps) > 0). @@ -1164,7 +1163,7 @@ assert (tool : forall a b c, 0 < b -> a < b * c -> a * / b < c). assumption. field; apply Rgt_not_eq; exact bp. apply tool;[exact Tool1 | ]. -apply HN; omega. +apply HN; lia. Qed. Lemma Datan_CVU_prelim : forall c (r : posreal), Rabs c + r < 1 -> @@ -1187,7 +1186,7 @@ apply (Alt_CVU (fun x n => Datan_seq n x) intros x [ | n] inb. solve[unfold Datan_seq; apply Rle_refl]. rewrite <- (Datan_seq_Rabs x); apply Rlt_le, Datan_seq_increasing. - omega. + lia. apply Boule_lt in inb; intuition. solve[apply Rabs_pos]. apply Datan_seq_CV_0. @@ -1212,7 +1211,7 @@ assert (Tool : forall N, (-1) ^ (S (2 * N)) = - 1). rewrite <- pow_add. replace (2 + S (2 * n))%nat with (S (2 * S n))%nat. reflexivity. - intuition. + lia. intros N x x_lb x_ub. induction N. unfold Datan_seq, Ratan_seq, tg_alt ; simpl. @@ -1251,10 +1250,10 @@ intros N x x_lb x_ub. apply Rabs_pos_lt ; assumption. rewrite Rabs_right. replace 1 with (/1) by field. - apply Rinv_1_lt_contravar ; intuition. + apply Rinv_1_lt_contravar. lra. apply lt_1_INR; lia. apply Rgt_ge ; replace (INR (2 * S N + 1)) with (INR (2*S N) + 1) ; [apply RiemannInt.RinvN_pos | ]. - replace (2 * S N + 1)%nat with (S (2 * S N))%nat by intuition ; + replace (2 * S N + 1)%nat with (S (2 * S N))%nat by lia. rewrite S_INR ; reflexivity. apply Hdelta ; assumption. rewrite Rmult_minus_distr_l. @@ -1266,7 +1265,7 @@ intros N x x_lb x_ub. - (x ^ (2 * S N + 1) / INR (2 * S N + 1))) / h)) by intuition. apply Rplus_eq_compat_l. field. split ; [apply Rgt_not_eq|] ; intuition. - clear ; replace (pred (2 * S N + 1)) with (2 * S N)%nat by intuition. + clear ; replace (pred (2 * S N + 1)) with (2 * S N)%nat by lia. field ; apply Rgt_not_eq ; intuition. field ; split ; [apply Rgt_not_eq |] ; intuition. elim (Main (eps/3) eps_3_pos) ; intros delta2 Hdelta2. @@ -1314,7 +1313,7 @@ apply (Alt_CVU (fun i r => Ratan_seq r i) ps_atan PI_tg (/2) pos_half); intros x n b; apply Boule_half_to_interval in b. rewrite <- (Rmult_1_l (PI_tg n)); unfold Ratan_seq, PI_tg. apply Rmult_le_compat_r. - apply Rlt_le, Rinv_0_lt_compat, (lt_INR 0); omega. + apply Rlt_le, Rinv_0_lt_compat, (lt_INR 0); lia. rewrite <- (pow1 (2 * n + 1)); apply pow_incr; assumption. exact PI_tg_cv. Qed. @@ -1458,10 +1457,10 @@ rewrite Rplus_assoc ; apply Rabs_triang. apply Halpha ; split. unfold D_x, no_cond ; split ; [ | apply Rgt_not_eq ] ; intuition. intuition. - apply HN2; unfold N; omega. + apply HN2; unfold N; lia. lra. rewrite <- Rabs_Ropp, Ropp_minus_distr; apply HN1. - unfold N; omega. + unfold N; lia. lra. assumption. field. diff --git a/theories/Reals/Rderiv.v b/theories/Reals/Rderiv.v index effbc3a404..69a41db4db 100644 --- a/theories/Reals/Rderiv.v +++ b/theories/Reals/Rderiv.v @@ -17,7 +17,7 @@ Require Import Rbase. Require Import Rfunctions. Require Import Rlimit. Require Import Lra. -Require Import Omega. +Require Import Lia. Local Open Scope R_scope. (*********) @@ -341,7 +341,7 @@ Proof. rewrite cond in H2; rewrite cond; simpl in H2; simpl; cut (1 + x0 * 1 * 0 = 1 * 1); [ intro A; rewrite A in H2; assumption | ring ]. - cut (n0 <> 0%nat -> S (n0 - 1) = n0); [ intro | omega ]; + cut (n0 <> 0%nat -> S (n0 - 1) = n0); [ intro | lia ]; rewrite (H3 cond) in H2; rewrite (Rmult_comm (x0 ^ n0) (INR n0)) in H2; rewrite (tech_pow_Rplus x0 n0 n0) in H2; assumption. Qed. diff --git a/theories/Reals/Rfunctions.v b/theories/Reals/Rfunctions.v index 17b39d22cb..7f9e019c5b 100644 --- a/theories/Reals/Rfunctions.v +++ b/theories/Reals/Rfunctions.v @@ -25,7 +25,7 @@ Require Export R_sqr. Require Export SplitAbsolu. Require Export SplitRmult. Require Export ArithProp. -Require Import Omega. +Require Import Lia. Require Import Zpower. Local Open Scope nat_scope. Local Open Scope R_scope. @@ -122,7 +122,7 @@ Hint Resolve pow_lt: real. Lemma Rlt_pow_R1 : forall (x:R) (n:nat), 1 < x -> (0 < n)%nat -> 1 < x ^ n. Proof. intros x n; elim n; simpl; auto with real. - intros H' H'0; exfalso; omega. + intros H' H'0; exfalso; lia. intros n0; case n0. simpl; rewrite Rmult_1_r; auto. intros n1 H' H'0 H'1. @@ -262,14 +262,14 @@ Proof. elim (IZN (up (b * / (Rabs x - 1))) H2); intros; exists x0; apply (Rge_trans (INR x0) (IZR (up (b * / (Rabs x - 1)))) (b * / (Rabs x - 1))). - rewrite INR_IZR_INZ; apply IZR_ge; omega. + rewrite INR_IZR_INZ; apply IZR_ge; lia. unfold Rge; left; assumption. exists 0%nat; apply (Rge_trans (INR 0) (IZR (up (b * / (Rabs x - 1)))) (b * / (Rabs x - 1))). - rewrite INR_IZR_INZ; apply IZR_ge; simpl; omega. + rewrite INR_IZR_INZ; apply IZR_ge; simpl; lia. unfold Rge; left; assumption. - omega. + lia. Qed. Lemma pow_ne_zero : forall n:nat, n <> 0%nat -> 0 ^ n = 0. @@ -745,7 +745,7 @@ Proof. - now simpl; rewrite Rmult_1_l. - now rewrite <- !pow_powerRZ, Rpow_mult_distr. - destruct Hmxy as [H|H]. - + assert(m = 0) as -> by now omega. + + assert(m = 0) as -> by now lia. now rewrite <- Hm, Rmult_1_l. + assert(x0 <> 0)%R by now intros ->; apply H; rewrite Rmult_0_l. assert(y0 <> 0)%R by now intros ->; apply H; rewrite Rmult_0_r. @@ -808,7 +808,7 @@ Proof. ring. rewrite Rmult_plus_distr_r; rewrite Hrecn; cut ((n + 1)%nat = S n). intro H; rewrite H; simpl; ring. - omega. + lia. Qed. Lemma sum_f_R0_triangle : diff --git a/theories/Reals/Rprod.v b/theories/Reals/Rprod.v index 15ec7891f7..ed2c953449 100644 --- a/theories/Reals/Rprod.v +++ b/theories/Reals/Rprod.v @@ -14,7 +14,7 @@ Require Import Rfunctions. Require Import Rseries. Require Import PartSum. Require Import Binomial. -Require Import Omega. +Require Import Lia. Local Open Scope R_scope. (** TT Ak; 0<=k<=N *) @@ -34,16 +34,16 @@ Lemma prod_SO_split : prod_f_R0 An k * prod_f_R0 (fun l:nat => An (k +1+l)%nat) (n - k -1). Proof. intros; induction n as [| n Hrecn]. - absurd (k < 0)%nat; omega. - cut (k = n \/ (k < n)%nat);[intro; elim H0; intro|omega]. - replace (S n - k - 1)%nat with O; [rewrite H1; simpl|omega]. + absurd (k < 0)%nat; lia. + cut (k = n \/ (k < n)%nat);[intro; elim H0; intro|lia]. + replace (S n - k - 1)%nat with O; [rewrite H1; simpl|lia]. replace (n+1+0)%nat with (S n); ring. - replace (S n - k-1)%nat with (S (n - k-1));[idtac|omega]. + replace (S n - k-1)%nat with (S (n - k-1));[idtac|lia]. simpl; replace (k + S (n - k))%nat with (S n). replace (k + 1 + S (n - k - 1))%nat with (S n). rewrite Hrecn; [ ring | assumption ]. - omega. - omega. + lia. + lia. Qed. (**********) @@ -116,11 +116,11 @@ Proof. assert (forall (n:nat), (0 < n)%nat -> (if eq_nat_dec n 0 then 1 else INR n) = INR n). intros n; case (eq_nat_dec n 0); auto with real. - intros; absurd (0 < n)%nat; omega. + intros; absurd (0 < n)%nat; lia. intros; unfold Rsqr; repeat rewrite fact_prodSO. cut ((k=N)%nat \/ (k < N)%nat \/ (N < k)%nat). intro H2; elim H2; intro H3. - rewrite H3; replace (2*N-N)%nat with N;[right; ring|omega]. + rewrite H3; replace (2*N-N)%nat with N;[right; ring|lia]. case H3; intro; clear H2 H3. rewrite (prod_SO_split (fun l:nat => if eq_nat_dec l 0 then 1 else INR l) (2 * N - k) N). rewrite Rmult_assoc; apply Rmult_le_compat_l. @@ -133,12 +133,12 @@ Proof. apply prod_SO_Rle; intros; split; auto. rewrite H0. rewrite H0. - apply le_INR; omega. - omega. - omega. + apply le_INR; lia. + lia. + lia. assumption. - omega. - omega. + lia. + lia. rewrite <- (Rmult_comm (prod_f_R0 (fun l:nat => if eq_nat_dec l 0 then 1 else INR l) k)); rewrite (prod_SO_split (fun l:nat => @@ -154,13 +154,13 @@ Proof. apply prod_SO_Rle; intros; split; auto. rewrite H0. rewrite H0. - apply le_INR; omega. - omega. - omega. - omega. - omega. + apply le_INR; lia. + lia. + lia. + lia. + lia. assumption. - omega. + lia. Qed. @@ -192,5 +192,5 @@ Proof. reflexivity. rewrite mult_INR; apply prod_neq_R0; apply INR_fact_neq_0. apply prod_neq_R0; apply INR_fact_neq_0. - omega. + lia. Qed. diff --git a/theories/Reals/Rsigma.v b/theories/Reals/Rsigma.v index 2a9c6953c5..7577c4b7b0 100644 --- a/theories/Reals/Rsigma.v +++ b/theories/Reals/Rsigma.v @@ -12,7 +12,7 @@ Require Import Rbase. Require Import Rfunctions. Require Import Rseries. Require Import PartSum. -Require Import Omega. +Require Import Lia. Local Open Scope R_scope. Set Implicit Arguments. @@ -57,12 +57,12 @@ Section Sigma. ring. replace (high - S (S k))%nat with (high - S k - 1)%nat. apply pred_of_minus. - omega. + lia. unfold sigma; replace (S k - low)%nat with (S (k - low)). pattern (S k) at 1; replace (S k) with (low + S (k - low))%nat. symmetry ; apply (tech5 (fun i:nat => f (low + i))). - omega. - omega. + lia. + lia. rewrite <- H2; unfold sigma; rewrite <- minus_n_n; simpl; replace (high - S low)%nat with (pred (high - low)). replace (sum_f_R0 (fun k0:nat => f (S (low + k0))) (pred (high - low))) with @@ -73,7 +73,7 @@ Section Sigma. apply sum_eq; intros; replace (S (low + i)) with (low + S i)%nat. reflexivity. ring. - omega. + lia. inversion H; [ right; reflexivity | left; assumption ]. Qed. diff --git a/theories/Reals/Rtrigo1.v b/theories/Reals/Rtrigo1.v index 0df1442f46..c2651d4120 100644 --- a/theories/Reals/Rtrigo1.v +++ b/theories/Reals/Rtrigo1.v @@ -18,7 +18,7 @@ Require Export Cos_rel. Require Export Cos_plus. Require Import ZArith_base. Require Import Zcomplements. -Import Omega. +Require Import Lia. Require Import Lra. Require Import Ranalysis1. Require Import Rsqrt_def. @@ -1741,7 +1741,7 @@ Proof. replace (3*(PI/2)) with (PI/2 + PI) in GT by field. rewrite Rplus_comm in GT. now apply Rplus_lt_reg_l in GT. } - omega. + lia. Qed. Lemma cos_eq_0_2PI_1 (x:R) : diff --git a/theories/Reals/SeqProp.v b/theories/Reals/SeqProp.v index d73f6ce0f3..34ea323a95 100644 --- a/theories/Reals/SeqProp.v +++ b/theories/Reals/SeqProp.v @@ -12,7 +12,7 @@ Require Import Rbase. Require Import Rfunctions. Require Import Rseries. Require Import Max. -Require Import Omega. +Require Import Lia. Local Open Scope R_scope. (*****************************************************************) @@ -1155,7 +1155,7 @@ Proof. rewrite Rmult_1_r; apply Rle_trans with (INR M_nat). left; rewrite INR_IZR_INZ. rewrite <- H4; assert (H8 := archimed (Rabs x)); elim H8; intros; assumption. - apply le_INR; omega. + apply le_INR; lia. apply INR_fact_neq_0. apply INR_fact_neq_0. ring. diff --git a/theories/Setoids/Setoid.v b/theories/Setoids/Setoid.v index 2f8be5de12..ddc9967bfa 100644 --- a/theories/Setoids/Setoid.v +++ b/theories/Setoids/Setoid.v @@ -12,6 +12,8 @@ Require Export Coq.Classes.SetoidTactics. Export Morphisms.ProperNotations. +Require Coq.ssr.ssrsetoid. + (** For backward compatibility *) Definition Setoid_Theory := @Equivalence. diff --git a/theories/Structures/OrderedTypeEx.v b/theories/Structures/OrderedTypeEx.v index cc216b21f8..e889150d92 100644 --- a/theories/Structures/OrderedTypeEx.v +++ b/theories/Structures/OrderedTypeEx.v @@ -9,7 +9,7 @@ (************************************************************************) Require Import OrderedType. -Require Import ZArith. +Require Import ZArith_base. Require Import PeanoNat. Require Import Ascii String. Require Import NArith Ndec. diff --git a/theories/ZArith/Zdigits.v b/theories/ZArith/Zdigits.v index 056e67db83..4896301aa7 100644 --- a/theories/ZArith/Zdigits.v +++ b/theories/ZArith/Zdigits.v @@ -15,11 +15,11 @@ Require Import Bvector. Require Import ZArith. Require Export Zpower. -Require Import Omega. +Require Import Lia. (** The evaluation of boolean vector is done both in binary and two's complement. The computed number belongs to Z. - We hence use Omega to perform computations in Z. + We hence use lia to perform computations in Z. Moreover, we use functions [2^n] where [n] is a natural number (here the vector length). *) @@ -155,10 +155,10 @@ Section Z_BRIC_A_BRAC. forall (n:nat) (bv:Bvector n), (binary_value n bv >= 0)%Z. Proof. induction bv as [| a n v IHbv]; cbn. - omega. + lia. - destruct a; destruct (binary_value n v); simpl; auto. - auto with zarith. + destruct a; destruct (binary_value n v); auto. + discriminate. Qed. Lemma two_compl_value_Sn : @@ -203,7 +203,7 @@ Section Z_BRIC_A_BRAC. auto. destruct p; auto. - simpl; intros; omega. + simpl; intros; lia. intro H; elim H; trivial. Qed. @@ -214,11 +214,11 @@ Section Z_BRIC_A_BRAC. (z < two_power_nat (S n))%Z -> (Z.div2 z < two_power_nat n)%Z. Proof. intros. - enough (2 * Z.div2 z < 2 * two_power_nat n)%Z by omega. + enough (2 * Z.div2 z < 2 * two_power_nat n)%Z by lia. rewrite <- two_power_nat_S. destruct (Zeven.Zeven_odd_dec z) as [Heven|Hodd]; intros. rewrite <- Zeven.Zeven_div2; auto. - generalize (Zeven.Zodd_div2 z Hodd); omega. + generalize (Zeven.Zodd_div2 z Hodd); lia. Qed. Lemma Z_to_two_compl_Sn_z : @@ -253,9 +253,9 @@ Section Z_BRIC_A_BRAC. intros n z; rewrite (two_power_nat_S n). generalize (Zmod2_twice z). destruct (Zeven.Zeven_odd_dec z) as [H| H]. - rewrite (Zeven_bit_value z H); intros; omega. + rewrite (Zeven_bit_value z H); intros; lia. - rewrite (Zodd_bit_value z H); intros; omega. + rewrite (Zodd_bit_value z H); intros; lia. Qed. Lemma Zlt_two_power_nat_S : @@ -265,9 +265,9 @@ Section Z_BRIC_A_BRAC. intros n z; rewrite (two_power_nat_S n). generalize (Zmod2_twice z). destruct (Zeven.Zeven_odd_dec z) as [H| H]. - rewrite (Zeven_bit_value z H); intros; omega. + rewrite (Zeven_bit_value z H); intros; lia. - rewrite (Zodd_bit_value z H); intros; omega. + rewrite (Zodd_bit_value z H); intros; lia. Qed. End Z_BRIC_A_BRAC. @@ -309,7 +309,7 @@ Section COHERENT_VALUE. (z < two_power_nat n)%Z -> binary_value n (Z_to_binary n z) = z. Proof. induction n as [| n IHn]. - unfold two_power_nat, shift_nat; simpl; intros; omega. + unfold two_power_nat, shift_nat; simpl; intros; lia. intros; rewrite Z_to_binary_Sn_z. rewrite binary_value_Sn. @@ -328,13 +328,13 @@ Section COHERENT_VALUE. Proof. induction n as [| n IHn]. unfold two_power_nat, shift_nat; simpl; intros. - assert (z = (-1)%Z \/ z = 0%Z). omega. + assert (z = (-1)%Z \/ z = 0%Z). lia. intuition; subst z; trivial. intros; rewrite Z_to_two_compl_Sn_z. rewrite two_compl_value_Sn. rewrite IHn. - generalize (Zmod2_twice z); omega. + generalize (Zmod2_twice z); lia. apply Zge_minus_two_power_nat_S; auto. diff --git a/theories/ZArith/Zgcd_alt.v b/theories/ZArith/Zgcd_alt.v index 0cc137ef5d..da2df40572 100644 --- a/theories/ZArith/Zgcd_alt.v +++ b/theories/ZArith/Zgcd_alt.v @@ -25,7 +25,7 @@ Require Import ZArith_base. Require Import ZArithRing. Require Import Zdiv. Require Import Znumtheory. -Require Import Omega. +Require Import Lia. Open Scope Z_scope. @@ -76,8 +76,7 @@ Open Scope Z_scope. Z.abs a < Z.of_nat n -> Zis_gcd a b (Zgcdn n a b). Proof. induction n. - simpl; intros. - exfalso; generalize (Z.abs_nonneg a); omega. + intros; lia. destruct a; intros; simpl; [ generalize (Zis_gcd_0_abs b); intuition | | ]; unfold Z.modulo; @@ -85,8 +84,7 @@ Open Scope Z_scope. destruct (Z.div_eucl b (Zpos p)) as (q,r); intros (H0,H1); rewrite Nat2Z.inj_succ in H; simpl Z.abs in H; - (assert (H2: Z.abs r < Z.of_nat n) by - (rewrite Z.abs_eq; auto with zarith)); + (assert (H2: Z.abs r < Z.of_nat n) by lia); assert (IH:=IHn r (Zpos p) H2); clear IHn; simpl in IH |- *; rewrite H0. @@ -108,15 +106,11 @@ Open Scope Z_scope. Lemma fibonacci_pos : forall n, 0 <= fibonacci n. Proof. enough (forall N n, (n<N)%nat -> 0<=fibonacci n) by eauto. - induction N. - inversion 1. + induction N. intros; lia. + intros [ | [ | n ] ]. 1-2: simpl; lia. intros. - destruct n. - simpl; auto with zarith. - destruct n. - simpl; auto with zarith. change (0 <= fibonacci (S n) + fibonacci n). - generalize (IHN n) (IHN (S n)); omega. + generalize (IHN n) (IHN (S n)); lia. Qed. Lemma fibonacci_incr : @@ -129,7 +123,7 @@ Open Scope Z_scope. destruct m. simpl; auto with zarith. change (fibonacci (S m) <= fibonacci (S m)+fibonacci m). - generalize (fibonacci_pos m); omega. + generalize (fibonacci_pos m); lia. Qed. (** 3) We prove that fibonacci numbers are indeed worst-case: @@ -144,8 +138,8 @@ Open Scope Z_scope. fibonacci (S (S n)) <= b. Proof. induction n. - intros [|a|a]; intros; simpl; omega. - intros [|a|a] b (Ha,Ha'); [simpl; omega | | easy ]. + intros [|a|a]; intros; simpl; lia. + intros [|a|a] b (Ha,Ha'); [simpl; lia | | easy ]. remember (S n) as m. rewrite Heqm at 2. simpl Zgcdn. unfold Z.modulo; generalize (Z_div_mod b (Zpos a) eq_refl). @@ -161,20 +155,13 @@ Open Scope Z_scope. apply Zis_gcd_sym. apply Zis_gcd_for_euclid2; auto. apply Zis_gcd_sym; auto. - + split; auto. - rewrite EQ. - apply Z.add_le_mono; auto. - apply Z.le_trans with (Zpos a * 1); auto. - now rewrite Z.mul_1_r. - apply Z.mul_le_mono_nonneg_l; auto with zarith. - change 1 with (Z.succ 0). apply Z.le_succ_l. - destruct q; auto with zarith. - assert (Zpos a * Zneg p < 0) by now compute. omega. + + split. auto. + destruct q. lia. 1-2: nia. - (* r = 0 *) clear IHn EQ Hr'; intros _. subst r; simpl; rewrite Heqm. destruct n. - + simpl. omega. + + simpl. lia. + now destruct 1. Qed. @@ -184,7 +171,7 @@ Open Scope Z_scope. 0 < a < b -> a < fibonacci (S n) -> Zis_gcd a b (Zgcdn n a b). Proof. - destruct a; [ destruct 1; exfalso; omega | | destruct 1; discriminate]. + destruct a. 1,3 : intros; lia. cut (forall k n b, k = (S (Pos.to_nat p) - n)%nat -> 0 < Zpos p < b -> Zpos p < fibonacci (S n) -> @@ -192,22 +179,17 @@ Open Scope Z_scope. destruct 2; eauto. clear n; induction k. intros. - assert (Pos.to_nat p < n)%nat by omega. apply Zgcdn_linear_bound. - simpl. - generalize (inj_le _ _ H2). - rewrite Nat2Z.inj_succ. - rewrite positive_nat_Z; auto. - omega. + lia. intros. generalize (Zgcdn_worst_is_fibonacci n (Zpos p) b H0); intros. assert (Zis_gcd (Zpos p) b (Zgcdn (S n) (Zpos p) b)). apply IHk; auto. - omega. + lia. replace (fibonacci (S (S n))) with (fibonacci (S n)+fibonacci n) by auto. - generalize (fibonacci_pos n); omega. + generalize (fibonacci_pos n); lia. replace (Zgcdn n (Zpos p) b) with (Zgcdn (S n) (Zpos p) b); auto. - generalize (H2 H3); clear H2 H3; omega. + generalize (H2 H3); clear H2 H3; lia. Qed. (** 4) The proposed bound leads to a fibonacci number that is big enough. *) @@ -215,7 +197,7 @@ Open Scope Z_scope. Lemma Zgcd_bound_fibonacci : forall a, 0 < a -> a < fibonacci (Zgcd_bound a). Proof. - destruct a; [omega| | intro H; discriminate]. + destruct a; [lia| | intro H; discriminate]. intros _. induction p; [ | | compute; auto ]; simpl Zgcd_bound in *; @@ -224,10 +206,10 @@ Open Scope Z_scope. assert (n <> O) by (unfold n; destruct p; simpl; auto). destruct n as [ |m]; [elim H; auto| ]. - generalize (fibonacci_pos m); rewrite Pos2Z.inj_xI; omega. + generalize (fibonacci_pos m); rewrite Pos2Z.inj_xI; lia. destruct n as [ |m]; [elim H; auto| ]. - generalize (fibonacci_pos m); rewrite Pos2Z.inj_xO; omega. + generalize (fibonacci_pos m); rewrite Pos2Z.inj_xO; lia. Qed. (* 5) the end: we glue everything together and take care of @@ -265,10 +247,10 @@ Open Scope Z_scope. Z.le_elim H1. + apply Zgcdn_ok_before_fibonacci; auto. apply Z.lt_le_trans with (fibonacci (S m)); - [ omega | apply fibonacci_incr; auto]. + [ lia | apply fibonacci_incr; auto]. + subst r; simpl. - destruct m as [ |m]; [exfalso; omega| ]. - destruct n as [ |n]; [exfalso; omega| ]. + destruct m as [ |m]; [ lia | ]. + destruct n as [ |n]; [ lia | ]. simpl; apply Zis_gcd_sym; apply Zis_gcd_0. Qed. @@ -277,7 +259,7 @@ Open Scope Z_scope. Proof. destruct a. - simpl; intros. - destruct n; [exfalso; omega | ]. + destruct n; [ lia | ]. simpl; generalize (Zis_gcd_0_abs b); intuition. - apply Zgcdn_is_gcd_pos. - rewrite <- Zgcd_bound_opp, <- Zgcdn_opp. diff --git a/theories/ZArith/Zpow_facts.v b/theories/ZArith/Zpow_facts.v index e65eb7cdc7..a669429ffa 100644 --- a/theories/ZArith/Zpow_facts.v +++ b/theories/ZArith/Zpow_facts.v @@ -8,7 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -Require Import ZArith_base ZArithRing Omega Zcomplements Zdiv Znumtheory. +Require Import ZArith_base ZArithRing Lia Zcomplements Zdiv Znumtheory. Require Export Zpower. Local Open Scope Z_scope. @@ -49,7 +49,7 @@ Proof. intros. now apply Z.pow_le_mono_r. Qed. Theorem Zpower_lt_monotone a b c : 1 < a -> 0 <= b < c -> a^b < a^c. -Proof. intros. apply Z.pow_lt_mono_r; auto with zarith. Qed. +Proof. intros. apply Z.pow_lt_mono_r; lia. Qed. Theorem Zpower_gt_1 x y : 1 < x -> 0 < y -> 1 < x^y. Proof. apply Z.pow_gt_1. Qed. @@ -87,10 +87,10 @@ Proof. assert (Hn := Nat2Z.is_nonneg n). destruct p; simpl Pos.size_nat. - specialize IHn with p. - rewrite Pos2Z.inj_xI, Nat2Z.inj_succ, Z.pow_succ_r; omega. + rewrite Nat2Z.inj_succ, Z.pow_succ_r; lia. - specialize IHn with p. - rewrite Pos2Z.inj_xO, Nat2Z.inj_succ, Z.pow_succ_r; omega. - - split; auto with zarith. + rewrite Nat2Z.inj_succ, Z.pow_succ_r; lia. + - split. lia. intros _. apply Z.pow_gt_1. easy. now rewrite Nat2Z.inj_succ, Z.lt_succ_r. Qed. @@ -103,8 +103,8 @@ Proof. intros Hn; destruct (Z.le_gt_cases 0 q) as [H1|H1]. - pattern q; apply natlike_ind; trivial. clear q H1. intros q Hq Rec. rewrite !Z.pow_succ_r; trivial. - rewrite Z.mul_mod_idemp_l; auto with zarith. - rewrite Z.mul_mod, Rec, <- Z.mul_mod; auto with zarith. + rewrite Z.mul_mod_idemp_l by lia. + rewrite Z.mul_mod, Rec, <- Z.mul_mod by lia. reflexivity. - rewrite !Z.pow_neg_r; auto with zarith. Qed. @@ -163,7 +163,7 @@ Qed. Lemma Zpower_divide p q : 0 < q -> (p | p ^ q). Proof. exists (p^(q - 1)). - rewrite Z.mul_comm, <- Z.pow_succ_r; f_equal; auto with zarith. + rewrite Z.mul_comm, <- Z.pow_succ_r by lia; f_equal; lia. Qed. Theorem rel_prime_Zpower_r i p q : @@ -190,7 +190,7 @@ Proof. - simpl; intros. assert (2<=p) by (apply prime_ge_2; auto). assert (p<=1) by (apply Z.divide_pos_le; auto with zarith). - omega. + lia. - intros n Hn Rec. rewrite Z.pow_succ_r by trivial. intros. assert (2<=p) by (apply prime_ge_2; auto). @@ -213,11 +213,11 @@ Proof. exists 1; rewrite Z.pow_1_r; apply prime_power_prime with n; auto. case not_prime_divide with (2 := Hpr); auto. intros p1 ((Hp1, Hpq1),(q1,->)). - assert (Hq1 : 0 < q1) by (apply Z.mul_lt_mono_pos_r with p1; auto with zarith). - destruct (IH p1) with p n as (r1,Hr1); auto with zarith. + assert (Hq1 : 0 < q1) by (apply Z.mul_lt_mono_pos_r with p1; lia). + destruct (IH p1) with p n as (r1,Hr1). 3-4: assumption. 1-2: lia. transitivity (q1 * p1); trivial. exists q1; auto with zarith. - destruct (IH q1) with p n as (r2,Hr2); auto with zarith. - split; auto with zarith. + destruct (IH q1) with p n as (r2,Hr2). 3-4: assumption. 2: lia. + split. lia. rewrite <- (Z.mul_1_r q1) at 1. apply Z.mul_lt_mono_pos_l; auto with zarith. transitivity (q1 * p1); trivial. exists p1; auto with zarith. diff --git a/theories/ZArith/Zquot.v b/theories/ZArith/Zquot.v index fea7db7921..b3e7fff7d6 100644 --- a/theories/ZArith/Zquot.v +++ b/theories/ZArith/Zquot.v @@ -63,6 +63,7 @@ Hint Resolve Zrem_0_l Zrem_0_r Zquot_0_l Zquot_0_r Z.quot_1_r Z.rem_1_r Ltac zero_or_not a := destruct (Z.eq_decidable a 0) as [->|?]; [rewrite ?Zquot_0_l, ?Zrem_0_l, ?Zquot_0_r, ?Zrem_0_r; + try lia; auto with zarith|]. Lemma Z_rem_same a : Z.rem a a = 0. @@ -100,7 +101,6 @@ Proof. zero_or_not b. now apply Z.rem_opp_opp. Qed. Theorem Zrem_sgn a b : 0 <= Z.sgn (Z.rem a b) * Z.sgn a. Proof. zero_or_not b. - - apply Z.square_nonneg. - zero_or_not (Z.rem a b). rewrite Z.rem_sign_nz; trivial. apply Z.square_nonneg. Qed. @@ -203,18 +203,18 @@ Qed. (* Division of positive numbers is positive. *) Lemma Z_quot_pos a b : 0 <= a -> 0 <= b -> 0 <= a÷b. -Proof. intros. zero_or_not b. apply Z.quot_pos; auto with zarith. Qed. +Proof. intros. zero_or_not b. apply Z.quot_pos; lia. Qed. (** As soon as the divisor is greater or equal than 2, the division is strictly decreasing. *) Lemma Z_quot_lt a b : 0 < a -> 2 <= b -> a÷b < a. -Proof. intros. apply Z.quot_lt; auto with zarith. Qed. +Proof. intros. apply Z.quot_lt; lia. Qed. (** [<=] is compatible with a positive division. *) Lemma Z_quot_monotone a b c : 0<=c -> a<=b -> a÷c <= b÷c. -Proof. intros. zero_or_not c. apply Z.quot_le_mono; auto with zarith. Qed. +Proof. intros. zero_or_not c. apply Z.quot_le_mono; lia. Qed. (** With our choice of division, rounding of (a÷b) is always done toward 0: *) @@ -228,12 +228,12 @@ Proof. intros. zero_or_not b. apply Z.mul_quot_ge; auto with zarith. Qed. iff the modulo is zero. *) Lemma Z_quot_exact_full a b : a = b*(a÷b) <-> Z.rem a b = 0. -Proof. intros. zero_or_not b. intuition. apply Z.quot_exact; auto. Qed. +Proof. intros. zero_or_not b. apply Z.quot_exact; auto. Qed. (** A modulo cannot grow beyond its starting point. *) Theorem Zrem_le a b : 0 <= a -> 0 <= b -> Z.rem a b <= a. -Proof. intros. zero_or_not b. apply Z.rem_le; auto with zarith. Qed. +Proof. intros. zero_or_not b. apply Z.rem_le; lia. Qed. (** Some additional inequalities about Zdiv. *) @@ -357,7 +357,7 @@ Qed. Theorem Zquot_mult_le: forall a b c, 0<=a -> 0<=b -> 0<=c -> c*(a÷b) <= (c*a)÷b. -Proof. intros. zero_or_not b. apply Z.quot_mul_le; auto with zarith. Qed. +Proof. intros. zero_or_not b. apply Z.quot_mul_le; lia. Qed. (** Z.rem is related to divisibility (see more in Znumtheory) *) @@ -376,7 +376,7 @@ Lemma Zquot2_odd_remainder : forall a, Proof. intros [ |p|p]. simpl. left. simpl. auto with zarith. - left. destruct p; simpl; auto with zarith. + left. destruct p; simpl; lia. right. destruct p; simpl; split; now auto with zarith. Qed. @@ -414,10 +414,10 @@ Theorem Zquotrem_Zdiv_eucl_pos : forall a b:Z, 0 <= a -> 0 < b -> Proof. intros. apply Zdiv_mod_unique with b. - apply Zrem_lt_pos; auto with zarith. - rewrite Z.abs_eq; auto with *; apply Z_mod_lt; auto with *. - rewrite <- Z_div_mod_eq; auto with *. - symmetry; apply Z.quot_rem; auto with *. + apply Zrem_lt_pos; lia. + rewrite Z.abs_eq by lia. apply Z_mod_lt; lia. + rewrite <- Z_div_mod_eq by lia. + symmetry; apply Z.quot_rem; lia. Qed. Theorem Zquot_Zdiv_pos : forall a b, 0 <= a -> 0 <= b -> diff --git a/theories/ZArith/Zwf.v b/theories/ZArith/Zwf.v index 853ec951ae..ca04bb4c8f 100644 --- a/theories/ZArith/Zwf.v +++ b/theories/ZArith/Zwf.v @@ -10,7 +10,7 @@ Require Import ZArith_base. Require Export Wf_nat. -Require Import Omega. +Require Import Lia. Local Open Scope Z_scope. (** Well-founded relations on Z. *) @@ -39,20 +39,19 @@ Section wf_proof. clear a; simple induction n; intros. (** n= 0 *) case H; intros. - case (lt_n_O (f a)); auto. + lia. apply Acc_intro; unfold Zwf; intros. - assert False; omega || contradiction. + lia. (** inductive case *) case H0; clear H0; intro; auto. apply Acc_intro; intros. apply H. unfold Zwf in H1. - case (Z.le_gt_cases c y); intro; auto with zarith. + case (Z.le_gt_cases c y); intro. 2: lia. left. - red in H0. apply lt_le_trans with (f a); auto with arith. unfold f. - apply Zabs2Nat.inj_lt; omega. + lia. apply (H (S (f a))); auto. Qed. @@ -83,9 +82,7 @@ Section wf_proof_up. Proof. apply well_founded_lt_compat with (f := f). unfold Zwf_up, f. - intros. - apply Zabs2Nat.inj_lt; try (apply Z.le_0_sub; intuition). - now apply Z.sub_lt_mono_l. + lia. Qed. End wf_proof_up. diff --git a/tools/CoqMakefile.in b/tools/CoqMakefile.in index 626ac0fe67..abfbd66e28 100644 --- a/tools/CoqMakefile.in +++ b/tools/CoqMakefile.in @@ -246,8 +246,10 @@ strip_dotslash = $(patsubst ./%,%,$(1)) with_undef = $(if $(filter-out undefined, $(origin $(1))),$($(1))) VO = vo +VOS = vos VOFILES = $(VFILES:.v=.$(VO)) +VOSFILES = $(VFILES:.v=.$(VOS)) GLOBFILES = $(VFILES:.v=.glob) HTMLFILES = $(VFILES:.v=.html) GHTMLFILES = $(VFILES:.v=.g.html) @@ -298,6 +300,7 @@ ALLNATIVEFILES = \ NATIVEFILES = $(wildcard $(ALLNATIVEFILES)) FILESTOINSTALL = \ $(VOFILES) \ + $(VOSFILES) \ $(VFILES) \ $(GLOBFILES) \ $(NATIVEFILES) \ @@ -408,6 +411,12 @@ checkproofs: -schedule-vio-checking $(J) $(VOFILES:%.vo=%.vio) .PHONY: checkproofs +vos: $(VOFILES:%.vo=%.vos) +.PHONY: vos + +vok: $(VOFILES:%.vo=%.vok) +.PHONY: vok + validate: $(VOFILES) $(TIMER) $(COQCHK) $(COQCHKFLAGS) $(COQLIBS) $^ .PHONY: validate @@ -558,6 +567,8 @@ clean:: $(HIDE)find . -name .coq-native -type d -empty -delete $(HIDE)rm -f $(VOFILES) $(HIDE)rm -f $(VOFILES:.vo=.vio) + $(HIDE)rm -f $(VOFILES:.vo=.vos) + $(HIDE)rm -f $(VOFILES:.vo=.vok) $(HIDE)rm -f $(BEAUTYFILES) $(VFILES:=.old) $(HIDE)rm -f all.ps all-gal.ps all.pdf all-gal.pdf all.glob all-mli.tex $(HIDE)rm -f $(VFILES:.v=.glob) @@ -666,6 +677,14 @@ $(VFILES:.v=.vio): %.vio: %.v $(SHOW)COQC -quick $< $(HIDE)$(TIMER) $(COQC) -quick $(COQDEBUG) $(COQFLAGS) $(COQLIBS) $< +$(VFILES:.v=.vos): %.vos: %.v + $(SHOW)COQC -vos $< + $(HIDE)$(TIMER) $(COQC) -vos $(COQDEBUG) $(COQFLAGS) $(COQLIBS) $< + +$(VFILES:.v=.vok): %.vok: %.v + $(SHOW)COQC -vok $< + $(HIDE)$(TIMER) $(COQC) -vok $(COQDEBUG) $(COQFLAGS) $(COQLIBS) $< + $(addsuffix .timing.diff,$(VFILES)): %.timing.diff : %.before-timing %.after-timing $(SHOW)PYTHON TIMING-DIFF $< $(HIDE)$(MAKE) --no-print-directory -f "$(SELF)" print-pretty-single-time-diff BEFORE=$*.before-timing AFTER=$*.after-timing TIME_OF_PRETTY_BUILD_FILE="$@" diff --git a/tools/coq_dune.ml b/tools/coq_dune.ml index ab180769b6..f62947ec67 100644 --- a/tools/coq_dune.ml +++ b/tools/coq_dune.ml @@ -170,6 +170,7 @@ let pp_rule fmt targets deps action = let gen_coqc_targets vo = [ vo.target ; replace_ext ~file:vo.target ~newext:".glob" + ; replace_ext ~file:vo.target ~newext:".vos" ; "." ^ replace_ext ~file:vo.target ~newext:".aux"] (* Generate the dune rule: *) diff --git a/tools/coqdep_common.ml b/tools/coqdep_common.ml index 8beb314046..ddedec12f8 100644 --- a/tools/coqdep_common.ml +++ b/tools/coqdep_common.ml @@ -235,15 +235,15 @@ let file_name s = function let depend_ML str = match search_mli_known str, search_ml_known str with | Some mlidir, Some mldir -> - let mlifile = file_name str mlidir - and mlfile = file_name str mldir in - (" "^mlifile^".cmi"," "^mlfile^".cmx") + let mlifile = file_name str mlidir + and mlfile = file_name str mldir in + (" "^mlifile^".cmi"," "^mlfile^".cmx") | None, Some mldir -> - let mlfile = file_name str mldir in - (" "^mlfile^".cmo"," "^mlfile^".cmx") + let mlfile = file_name str mldir in + (" "^mlfile^".cmo"," "^mlfile^".cmx") | Some mlidir, None -> - let mlifile = file_name str mlidir in - (" "^mlifile^".cmi"," "^mlifile^".cmi") + let mlifile = file_name str mlidir in + (" "^mlifile^".cmi"," "^mlifile^".cmi") | None, None -> "", "" let soustraite_fichier_ML dep md ext = @@ -254,9 +254,9 @@ let soustraite_fichier_ML dep md ext = let a_faire_opt = ref "" in List.iter (fun str -> - let byte,opt = depend_ML str in - a_faire := !a_faire ^ byte; - a_faire_opt := !a_faire_opt ^ opt) + let byte,opt = depend_ML str in + a_faire := !a_faire ^ byte; + a_faire_opt := !a_faire_opt ^ opt) (List.rev list); (!a_faire, !a_faire_opt) with @@ -274,15 +274,15 @@ let autotraite_fichier_ML md ext = let a_faire_opt = ref "" in begin try while true do - let (Use_module str) = caml_action buf in - if StrSet.mem str !deja_vu then - () - else begin - deja_vu := StrSet.add str !deja_vu; - let byte,opt = depend_ML str in - a_faire := !a_faire ^ byte; - a_faire_opt := !a_faire_opt ^ opt - end + let (Use_module str) = caml_action buf in + if StrSet.mem str !deja_vu then + () + else begin + deja_vu := StrSet.add str !deja_vu; + let byte,opt = depend_ML str in + a_faire := !a_faire ^ byte; + a_faire_opt := !a_faire_opt ^ opt + end done with Fin_fichier -> () end; @@ -301,14 +301,14 @@ let traite_fichier_modules md ext = let list = mllib_list (Lexing.from_channel chan) in List.fold_left (fun a_faire str -> match search_mlpack_known str with - | Some mldir -> - let file = file_name str mldir in + | Some mldir -> + let file = file_name str mldir in a_faire @ [file] - | None -> - match search_ml_known str with - | Some mldir -> - let file = file_name str mldir in - a_faire @ [file] + | None -> + match search_ml_known str with + | Some mldir -> + let file = file_name str mldir in + a_faire @ [file] | None -> a_faire) [] list with | Sys_error _ -> [] @@ -329,16 +329,16 @@ let escape = let c = s.[i] in if c = ' ' || c = '#' || c = ':' (* separators and comments *) || c = '%' (* pattern *) - || c = '?' || c = '[' || c = ']' || c = '*' (* expansion in filenames *) - || i=0 && c = '~' && (String.length s = 1 || s.[1] = '/' || - 'A' <= s.[1] && s.[1] <= 'Z' || - 'a' <= s.[1] && s.[1] <= 'z') (* homedir expansion *) + || c = '?' || c = '[' || c = ']' || c = '*' (* expansion in filenames *) + || i=0 && c = '~' && (String.length s = 1 || s.[1] = '/' || + 'A' <= s.[1] && s.[1] <= 'Z' || + 'a' <= s.[1] && s.[1] <= 'z') (* homedir expansion *) then begin - let j = ref (i-1) in - while !j >= 0 && s.[!j] = '\\' do - Buffer.add_char s' '\\'; decr j (* escape all preceding '\' *) - done; - Buffer.add_char s' '\\'; + let j = ref (i-1) in + while !j >= 0 && s.[!j] = '\\' do + Buffer.add_char s' '\\'; decr j (* escape all preceding '\' *) + done; + Buffer.add_char s' '\\'; end; if c = '$' then Buffer.add_char s' '$'; Buffer.add_char s' c @@ -362,75 +362,116 @@ end module VCache = Set.Make(VData) -let rec traite_fichier_Coq suffixe verbose f = +(** To avoid reading .v files several times for computing dependencies, + once for .vo, once for .vio, and once for .vos extensions, the + following code performs a single pass and produces a structured + list of dependencies, separating dependencies on compiled Coq files + (those loaded by [Require]) from other dependencies, e.g. dependencies + on ".v" files (for [Load]) or ".cmx", ".cmo", etc... (for [Declare]). *) + +type dependency = + | DepRequire of string (* one basename, to which we later append .vo or .vio or .vos *) + | DepOther of string (* filenames of dependencies, separated by spaces *) + +let string_of_dependency_list suffix_for_require deps = + let string_of_dep = function + | DepRequire basename -> basename ^ suffix_for_require + | DepOther s -> s + in + String.concat " " (List.map string_of_dep deps) + +let rec find_dependencies basename = + let verbose = true in (* for past/future use? *) try + (* Visited marks *) + let visited_ml = ref StrSet.empty in + let visited_v = ref VCache.empty in + let should_visit_v_and_mark from str = + if not (VCache.mem (from, str) !visited_v) then begin + visited_v := VCache.add (from, str) !visited_v; + true + end else false + in + (* Output: dependencies found *) + let dependencies = ref [] in + let add_dep dep = + dependencies := dep::!dependencies in + let add_dep_other s = + add_dep (DepOther s) in + + (* Reading file contents *) + let f = basename ^ ".v" in let chan = open_in f in let buf = Lexing.from_channel chan in - let deja_vu_v = ref VCache.empty in - let deja_vu_ml = ref StrSet.empty in try while true do - let tok = coq_action buf in - match tok with - | Require (from, strl) -> - List.iter (fun str -> - if not (VCache.mem (from, str) !deja_vu_v) then begin - deja_vu_v := VCache.add (from, str) !deja_vu_v; - try - let file_str = safe_assoc from verbose f str in - printf " %s%s" (canonize file_str) suffixe - with Not_found -> - if verbose && not (is_in_coqlib ?from str) then - let str = - match from with - | None -> str - | Some pth -> pth @ str - in - warning_module_notfound f str - end) strl - | Declare sl -> - let declare suff dir s = - let base = escape (file_name s dir) in - match !option_dynlink with - | No -> () - | Byte -> printf " %s%s" base suff - | Opt -> printf " %s.cmxs" base - | Both -> printf " %s%s %s.cmxs" base suff base - | Variable -> - printf " %s%s" base - (if suff=".cmo" then "$(DYNOBJ)" else "$(DYNLIB)") + let tok = coq_action buf in + match tok with + | Require (from, strl) -> + List.iter (fun str -> + if should_visit_v_and_mark from str then begin + try + let file_str = safe_assoc from verbose f str in + add_dep (DepRequire (canonize file_str)) + with Not_found -> + if verbose && not (is_in_coqlib ?from str) then + let str = + match from with + | None -> str + | Some pth -> pth @ str + in + warning_module_notfound f str + end) strl + | Declare sl -> + let declare suff dir s = + let base = escape (file_name s dir) in + match !option_dynlink with + | No -> () + | Byte -> add_dep_other (sprintf "%s%s" base suff) + | Opt -> add_dep_other (sprintf "%s.cmxs" base) + | Both -> add_dep_other (sprintf "%s%s" base suff); + add_dep_other (sprintf "%s.cmxs" base) + | Variable -> add_dep_other (sprintf "%s%s" base + (if suff=".cmo" then "$(DYNOBJ)" else "$(DYNLIB)")) in - let decl str = - let s = basename_noext str in - if not (StrSet.mem s !deja_vu_ml) then begin - deja_vu_ml := StrSet.add s !deja_vu_ml; - match search_mllib_known s with - | Some mldir -> declare ".cma" mldir s - | None -> - match search_mlpack_known s with - | Some mldir -> declare ".cmo" mldir s - | None -> - match search_ml_known s with - | Some mldir -> declare ".cmo" mldir s - | None -> warning_declare f str - end - in List.iter decl sl - | Load str -> - let str = Filename.basename str in - if not (VCache.mem (None, [str]) !deja_vu_v) then begin - deja_vu_v := VCache.add (None, [str]) !deja_vu_v; - try - let (file_str, _) = Hashtbl.find vKnown [str] in - let canon = canonize file_str in - printf " %s.v" canon; - traite_fichier_Coq suffixe true (canon ^ ".v") - with Not_found -> () - end - | AddLoadPath _ | AddRecLoadPath _ -> (* TODO *) () - done - with Fin_fichier -> close_in chan - | Syntax_error (i,j) -> close_in chan; error_cannot_parse f (i,j) - with Sys_error _ -> () + let decl str = + let s = basename_noext str in + if not (StrSet.mem s !visited_ml) then begin + visited_ml := StrSet.add s !visited_ml; + match search_mllib_known s with + | Some mldir -> declare ".cma" mldir s + | None -> + match search_mlpack_known s with + | Some mldir -> declare ".cmo" mldir s + | None -> + match search_ml_known s with + | Some mldir -> declare ".cmo" mldir s + | None -> warning_declare f str + end + in + List.iter decl sl + | Load str -> + let str = Filename.basename str in + if should_visit_v_and_mark None [str] then begin + try + let (file_str, _) = Hashtbl.find vKnown [str] in + let canon = canonize file_str in + add_dep_other (sprintf "%s.v" canon); + let deps = find_dependencies canon in + List.iter add_dep deps + with Not_found -> () + end + | AddLoadPath _ | AddRecLoadPath _ -> (* TODO: will this be handled? *) () + done; + List.rev !dependencies + with + | Fin_fichier -> + close_in chan; + List.rev !dependencies + | Syntax_error (i,j) -> + close_in chan; + error_cannot_parse f (i,j) + with Sys_error _ -> [] (* TODO: report an error? *) let mL_dependencies () = @@ -439,8 +480,8 @@ let mL_dependencies () = let fullname = file_name name dirname in let (dep,dep_opt) = traite_fichier_ML fullname ext in let intf = match search_mli_known name with - | None -> "" - | Some mldir -> " "^(file_name name mldir)^".cmi" + | None -> "" + | Some mldir -> " "^(file_name name mldir)^".cmi" in let efullname = escape fullname in printf "%s.cmo:%s%s\n" efullname dep intf; @@ -481,12 +522,14 @@ let coq_dependencies () = (fun (name,_) -> let ename = escape name in let glob = if !option_noglob then "" else " "^ename^".glob" in - printf "%s%s%s %s.v.beautified: %s.v" ename !suffixe glob ename ename; - traite_fichier_Coq !suffixe true (name ^ ".v"); - printf "\n"; - printf "%s.vio: %s.v" ename ename; - traite_fichier_Coq ".vio" true (name ^ ".v"); - printf "\n%!") + let deps = find_dependencies name in + printf "%s%s%s %s.v.beautified %s.required_vo: %s.v %s\n" ename !suffixe glob ename ename ename + (string_of_dependency_list !suffixe deps); + printf "%s.vio: %s.v %s\n" ename ename + (string_of_dependency_list ".vio" deps); + printf "%s.vos %s.vok %s.required_vos: %s.v %s\n" ename ename ename ename + (string_of_dependency_list ".vos" deps); + printf "%!") (List.rev !vAccu) let rec suffixes = function @@ -505,26 +548,26 @@ let add_caml_known phys_dir _ f = | _ -> () let add_coqlib_known recur phys_dir log_dir f = - match get_extension f [".vo"; ".vio"] with - | (basename, (".vo" | ".vio")) -> + match get_extension f [".vo"; ".vio"; ".vos"] with + | (basename, (".vo" | ".vio" | ".vos")) -> let name = log_dir@[basename] in let paths = if recur then suffixes name else [name] in List.iter (fun f -> Hashtbl.add coqlibKnown f ()) paths | _ -> () let add_known recur phys_dir log_dir f = - match get_extension f [".v"; ".vo"; ".vio"] with + match get_extension f [".v"; ".vo"; ".vio"; ".vos"] with | (basename,".v") -> - let name = log_dir@[basename] in - let file = phys_dir//basename in - let () = safe_hash_add compare_file clash_v vKnown (name, (file, true)) in - if recur then + let name = log_dir@[basename] in + let file = phys_dir//basename in + let () = safe_hash_add compare_file clash_v vKnown (name, (file, true)) in + if recur then let paths = List.tl (suffixes name) in let iter n = safe_hash_add compare_file clash_v vKnown (n, (file, false)) in List.iter iter paths - | (basename, (".vo" | ".vio")) when not(!option_boot) -> + | (basename, (".vo" | ".vio" | ".vos")) when not(!option_boot) -> let name = log_dir@[basename] in - let paths = if recur then suffixes name else [name] in + let paths = if recur then suffixes name else [name] in List.iter (fun f -> Hashtbl.add coqlibKnown f ()) paths | _ -> () @@ -576,12 +619,12 @@ let rec treat_file old_dirname old_name = let complete_name = file_name name dirname in match try (stat complete_name).st_kind with _ -> S_BLK with | S_DIR -> - (if name.[0] <> '.' then + (if name.[0] <> '.' then let newdirname = match dirname with | None -> name | Some d -> d//name - in + in Array.iter (treat_file (Some newdirname)) (Sys.readdir complete_name)) | S_REG -> (match get_extension name [".v";".ml";".mli";".mlg";".mllib";".mlpack"] with diff --git a/toplevel/ccompile.ml b/toplevel/ccompile.ml index 3600658e23..3cbbf3d186 100644 --- a/toplevel/ccompile.ml +++ b/toplevel/ccompile.ml @@ -88,6 +88,10 @@ let ensure_exists_with_prefix f_in f_out src_suffix tgt_suffix = | Some f -> ensure tgt_suffix long_f_dot_src f in long_f_dot_src, long_f_dot_tgt +let create_empty_file filename = + let f = open_out filename in + close_out f + (* Compile a vernac file *) let compile opts copts ~echo ~f_in ~f_out = let open Vernac.State in @@ -106,43 +110,53 @@ let compile opts copts ~echo ~f_in ~f_out = let output_native_objects = match opts.config.native_compiler with | NativeOff -> false | NativeOn {ondemand} -> not ondemand in - match copts.compilation_mode with - | BuildVo -> - let long_f_dot_v, long_f_dot_vo = - ensure_exists_with_prefix f_in f_out ".v" ".vo" in - + let mode = copts.compilation_mode in + let ext_in, ext_out = + match mode with + | BuildVo -> ".v", ".vo" + | BuildVio -> ".v", ".vio" + | Vio2Vo -> ".vio", ".vo" + | BuildVos -> ".v", ".vos" + | BuildVok -> ".v", ".vok" + in + let long_f_dot_in, long_f_dot_out = + ensure_exists_with_prefix f_in f_out ext_in ext_out in + match mode with + | BuildVo | BuildVok -> let doc, sid = Topfmt.(in_phase ~phase:LoadingPrelude) Stm.new_doc - Stm.{ doc_type = VoDoc long_f_dot_vo; + Stm.{ doc_type = VoDoc long_f_dot_out; iload_path; require_libs; stm_options; } in let state = { doc; sid; proof = None; time = opts.config.time } in let state = load_init_vernaculars opts ~state in let ldir = Stm.get_ldir ~doc:state.doc in Aux_file.(start_aux_file - ~aux_file:(aux_file_name_for long_f_dot_vo) - ~v_file:long_f_dot_v); + ~aux_file:(aux_file_name_for long_f_dot_out) + ~v_file:long_f_dot_in); Dumpglob.set_glob_output copts.glob_out; - Dumpglob.start_dump_glob ~vfile:long_f_dot_v ~vofile:long_f_dot_vo; + Dumpglob.start_dump_glob ~vfile:long_f_dot_in ~vofile:long_f_dot_out; Dumpglob.dump_string ("F" ^ Names.DirPath.to_string ldir ^ "\n"); let wall_clock1 = Unix.gettimeofday () in let check = Stm.AsyncOpts.(stm_options.async_proofs_mode = APoff) in - let state = Vernac.load_vernac ~echo ~check ~interactive:false ~state long_f_dot_v in + let state = Vernac.load_vernac ~echo ~check ~interactive:false ~state long_f_dot_in in let _doc = Stm.join ~doc:state.doc in let wall_clock2 = Unix.gettimeofday () in check_pending_proofs (); - Library.save_library_to ~output_native_objects ldir long_f_dot_vo (Global.opaque_tables ()); + if mode <> BuildVok (* Don't output proofs in -vok mode *) + then Library.save_library_to ~output_native_objects Library.ProofsTodoNone ldir long_f_dot_out (Global.opaque_tables ()); Aux_file.record_in_aux_at "vo_compile_time" (Printf.sprintf "%.3f" (wall_clock2 -. wall_clock1)); Aux_file.stop_aux_file (); + (* Produce an empty .vos file when producing a .vo in standard mode *) + if mode = BuildVo then create_empty_file (long_f_dot_out ^ "s"); + (* Produce an empty .vok file when in -vok mode *) + if mode = BuildVok then create_empty_file (long_f_dot_out); Dumpglob.end_dump_glob () - | BuildVio -> - let long_f_dot_v, long_f_dot_vio = - ensure_exists_with_prefix f_in f_out ".v" ".vio" in - + | BuildVio | BuildVos -> (* We need to disable error resiliency, otherwise some errors will be ignored in batch mode. c.f. #6707 @@ -158,26 +172,26 @@ let compile opts copts ~echo ~f_in ~f_out = let doc, sid = Topfmt.(in_phase ~phase:LoadingPrelude) Stm.new_doc - Stm.{ doc_type = VioDoc long_f_dot_vio; + Stm.{ doc_type = VioDoc long_f_dot_out; iload_path; require_libs; stm_options; } in let state = { doc; sid; proof = None; time = opts.config.time } in let state = load_init_vernaculars opts ~state in let ldir = Stm.get_ldir ~doc:state.doc in - let state = Vernac.load_vernac ~echo ~check:false ~interactive:false ~state long_f_dot_v in + let state = Vernac.load_vernac ~echo ~check:false ~interactive:false ~state long_f_dot_in in let doc = Stm.finish ~doc:state.doc in check_pending_proofs (); - let () = ignore (Stm.snapshot_vio ~doc ~output_native_objects ldir long_f_dot_vio) in + let create_vos = (mode = BuildVos) in + let () = ignore (Stm.snapshot_vio ~create_vos ~doc ~output_native_objects ldir long_f_dot_out) in Stm.reset_task_queue () | Vio2Vo -> - let long_f_dot_vio, long_f_dot_vo = - ensure_exists_with_prefix f_in f_out ".vio" ".vo" in + let sum, lib, univs, tasks, proofs = - Library.load_library_todo long_f_dot_vio in - let univs, proofs = Stm.finish_tasks long_f_dot_vo univs proofs tasks in - Library.save_library_raw long_f_dot_vo sum lib univs proofs + Library.load_library_todo long_f_dot_in in + let univs, proofs = Stm.finish_tasks long_f_dot_out univs proofs tasks in + Library.save_library_raw long_f_dot_out sum lib univs proofs let compile opts copts ~echo ~f_in ~f_out = ignore(CoqworkmgrApi.get 1); diff --git a/toplevel/coqc.ml b/toplevel/coqc.ml index 642dc94ab2..178aa362c0 100644 --- a/toplevel/coqc.ml +++ b/toplevel/coqc.ml @@ -30,6 +30,9 @@ coqc specific options:\ \n into fi.vo\ \n -schedule-vio-checking j f1..fn run up to j instances of Coq to check all\ \n proofs in each fi.vio\ +\n -vos process statements but ignore opaque proofs, and produce a .vos file\ +\n -vok process the file by loading .vos instead of .vo files for\ +\n dependencies, and produce an empty .vok file on success\ \n\ \nUndocumented:\ \n -vio2vo [see manual]\ @@ -53,11 +56,7 @@ let coqc_main copts ~opts = if opts.Coqargs.post.Coqargs.output_context then begin let sigma, env = let e = Global.env () in Evd.from_env e, e in - let library_accessor = Library.indirect_accessor in - let mod_ops = { Printmod.import_module = Declaremods.import_module - ; process_module_binding = Declaremods.process_module_binding - } in - Feedback.msg_notice Pp.(Flags.(with_option raw_print (Prettyp.print_full_pure_context ~mod_ops ~library_accessor env) sigma) ++ fnl ()) + Feedback.msg_notice Pp.(Flags.(with_option raw_print (Prettyp.print_full_pure_context env) sigma) ++ fnl ()) end; CProfile.print_profile () diff --git a/toplevel/coqcargs.ml b/toplevel/coqcargs.ml index c4e3571281..e614d4fe6d 100644 --- a/toplevel/coqcargs.ml +++ b/toplevel/coqcargs.ml @@ -8,7 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -type compilation_mode = BuildVo | BuildVio | Vio2Vo +type compilation_mode = BuildVo | BuildVio | Vio2Vo | BuildVos | BuildVok type t = { compilation_mode : compilation_mode @@ -166,6 +166,13 @@ let parse arglist : t = { oval with compilation_output_name = Some (next ()) } | "-quick" -> set_compilation_mode oval BuildVio + |"-vos" -> + Flags.load_vos_libraries := true; + { oval with compilation_mode = BuildVos } + |"-vok" -> + Flags.load_vos_libraries := true; + { oval with compilation_mode = BuildVok } + | "-check-vio-tasks" -> let tno = get_task_list (next ()) in let tfile = next () in diff --git a/toplevel/coqcargs.mli b/toplevel/coqcargs.mli index 13bea3bf3e..677a3f2e48 100644 --- a/toplevel/coqcargs.mli +++ b/toplevel/coqcargs.mli @@ -8,7 +8,21 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -type compilation_mode = BuildVo | BuildVio | Vio2Vo +(** Compilation modes: + - BuildVo : process statements and proofs (standard compilation), + and also output an empty .vos file + - BuildVio : process statements, delay proofs in futures + - Vio2Vo : load delayed proofs and process them + - BuildVos : process statements, and discard proofs, + and load .vos files for required libraries + - BuildVok : like BuildVo, but load .vos files for required libraries + + When loading the .vos version of a required library, if the file exists but is + empty, then we attempt to load the .vo version of that library. + This trick is useful to avoid the need for the user to compile .vos version + when an up to date .vo version is already available. +*) +type compilation_mode = BuildVo | BuildVio | Vio2Vo | BuildVos | BuildVok type t = { compilation_mode : compilation_mode diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index eded9f4bcd..309f5b657a 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -271,6 +271,8 @@ let init_document opts = state before we take the first snapshot. This was not guaranteed in the past, but now is thanks to the STM API. *) + (* Next line allows loading .vos files when in interactive mode *) + Flags.load_vos_libraries := true; let iload_path = build_load_path opts in let require_libs = require_libs opts in let stm_options = opts.config.stm_flags in diff --git a/user-contrib/Ltac2/Constr.v b/user-contrib/Ltac2/Constr.v index 1e330b06d7..a0b25afc37 100644 --- a/user-contrib/Ltac2/Constr.v +++ b/user-contrib/Ltac2/Constr.v @@ -45,6 +45,7 @@ Ltac2 Type kind := [ | CoFix (int, ident option binder_annot array, constr array, constr array) | Proj (projection, constr) | Uint63 (uint63) +| Float (float) ]. Ltac2 @ external kind : constr -> kind := "ltac2" "constr_kind". @@ -77,3 +78,6 @@ Ltac2 @ external in_context : ident -> constr -> (unit -> unit) -> constr := "lt (** On a focused goal [Γ ⊢ A], [in_context id c tac] evaluates [tac] in a focused goal [Γ, id : c ⊢ ?X] and returns [fun (id : c) => t] where [t] is the proof built by the tactic. *) + +Ltac2 @ external pretype : preterm -> constr := "ltac2" "constr_pretype". +(** Pretype the provided preterm. Assumes the goal to be focussed. *) diff --git a/user-contrib/Ltac2/Init.v b/user-contrib/Ltac2/Init.v index 88454ff2fb..65f0a362b1 100644 --- a/user-contrib/Ltac2/Init.v +++ b/user-contrib/Ltac2/Init.v @@ -17,6 +17,7 @@ Ltac2 Type string. Ltac2 Type char. Ltac2 Type ident. Ltac2 Type uint63. +Ltac2 Type float. (** Constr-specific built-in types *) Ltac2 Type meta. @@ -30,6 +31,7 @@ Ltac2 Type constructor. Ltac2 Type projection. Ltac2 Type pattern. Ltac2 Type constr. +Ltac2 Type preterm. Ltac2 Type message. Ltac2 Type exn := [ .. ]. diff --git a/user-contrib/Ltac2/g_ltac2.mlg b/user-contrib/Ltac2/g_ltac2.mlg index 8a878bb0d0..cc3a7c0f79 100644 --- a/user-contrib/Ltac2/g_ltac2.mlg +++ b/user-contrib/Ltac2/g_ltac2.mlg @@ -175,13 +175,13 @@ GRAMMAR EXTEND Gram { CAst.make ~loc @@ CTacCse (e, bl) } ] | "4" LEFTA [ ] + | [ e0 = SELF; ","; el = LIST1 NEXT SEP "," -> + { let el = e0 :: el in + CAst.make ~loc @@ CTacApp (CAst.make ~loc @@ CTacCst (AbsKn (Tuple (List.length el))), el) } ] | "::" RIGHTA [ e1 = tac2expr; "::"; e2 = tac2expr -> { CAst.make ~loc @@ CTacApp (CAst.make ~loc @@ CTacCst (AbsKn (Other Tac2core.Core.c_cons)), [e1; e2]) } ] - | [ e0 = SELF; ","; el = LIST1 NEXT SEP "," -> - { let el = e0 :: el in - CAst.make ~loc @@ CTacApp (CAst.make ~loc @@ CTacCst (AbsKn (Tuple (List.length el))), el) } ] | "1" LEFTA [ e = tac2expr; el = LIST1 tac2expr LEVEL "0" -> { CAst.make ~loc @@ CTacApp (e, el) } @@ -838,11 +838,11 @@ END GRAMMAR EXTEND Gram Pcoq.Constr.operconstr: LEVEL "0" [ [ IDENT "ltac2"; ":"; "("; tac = tac2expr; ")" -> - { let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in + { let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2_constr) tac in CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) } | test_ampersand_ident; "&"; id = Prim.ident -> { let tac = Tac2quote.of_exact_hyp ~loc (CAst.make ~loc id) in - let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in + let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2_constr) tac in CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) } | test_dollar_ident; "$"; id = Prim.ident -> { let id = Loc.tag ~loc id in @@ -873,7 +873,7 @@ let rules = [ Stop ++ Aentry test_ampersand_ident ++ Atoken (PKEYWORD "&") ++ Aentry Prim.ident, begin fun id _ _ loc -> let tac = Tac2quote.of_exact_hyp ~loc (CAst.make ~loc id) in - let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) ([], tac) in + let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2_constr) tac in CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) end ); @@ -882,7 +882,7 @@ let rules = [ Stop ++ Atoken (PIDENT (Some "ltac2")) ++ Atoken (PKEYWORD ":") ++ Atoken (PKEYWORD "(") ++ Aentry tac2expr ++ Atoken (PKEYWORD ")"), begin fun _ tac _ _ _ loc -> - let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) ([], tac) in + let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2_constr) tac in CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) end ) diff --git a/user-contrib/Ltac2/tac2core.ml b/user-contrib/Ltac2/tac2core.ml index 34870345a5..55cd7f7692 100644 --- a/user-contrib/Ltac2/tac2core.ml +++ b/user-contrib/Ltac2/tac2core.ml @@ -17,6 +17,28 @@ open Tac2expr open Tac2entries.Pltac open Proofview.Notations +let constr_flags = + let open Pretyping in + { + use_typeclasses = true; + solve_unification_constraints = true; + fail_evar = true; + expand_evars = true; + program_mode = false; + polymorphic = false; + } + +let open_constr_no_classes_flags = + let open Pretyping in + { + use_typeclasses = false; + solve_unification_constraints = true; + fail_evar = false; + expand_evars = true; + program_mode = false; + polymorphic = false; + } + (** Standard values *) module Value = Tac2ffi @@ -428,6 +450,8 @@ let () = define1 "constr_kind" constr begin fun c -> |] | Int n -> v_blk 17 [|Value.of_uint63 n|] + | Float f -> + v_blk 18 [|Value.of_float f|] end end @@ -508,6 +532,9 @@ let () = define1 "constr_make" valexpr begin fun knd -> | (17, [|n|]) -> let n = Value.to_uint63 n in EConstr.mkInt n + | (18, [|f|]) -> + let f = Value.to_float f in + EConstr.mkFloat f | _ -> assert false in return (Value.of_constr c) @@ -587,6 +614,30 @@ let () = define3 "constr_in_context" ident constr closure begin fun id t c -> throw err_notfocussed end +(** preterm -> constr *) +let () = define1 "constr_pretype" (repr_ext val_preterm) begin fun c -> + let open Pretyping in + let open Ltac_pretype in + let pretype env sigma = + Proofview.V82.wrap_exceptions begin fun () -> + (* For now there are no primitives to create preterms with a non-empty + closure. I do not know whether [closed_glob_constr] is really the type + we want but it does not hurt in the meantime. *) + let { closure; term } = c in + let vars = { + ltac_constrs = closure.typed; + ltac_uconstrs = closure.untyped; + ltac_idents = closure.idents; + ltac_genargs = Id.Map.empty; + } in + let flags = constr_flags in + let sigma, t = understand_ltac flags env sigma vars WithoutTypeConstraint term in + let t = Value.of_constr t in + Proofview.Unsafe.tclEVARS sigma <*> Proofview.tclUNIT t + end in + pf_apply pretype +end + (** Patterns *) let empty_context = EConstr.mkMeta Constr_matching.special_meta @@ -976,28 +1027,6 @@ end (** ML types *) -let constr_flags () = - let open Pretyping in - { - use_typeclasses = true; - solve_unification_constraints = true; - fail_evar = true; - expand_evars = true; - program_mode = false; - polymorphic = false; - } - -let open_constr_no_classes_flags () = - let open Pretyping in - { - use_typeclasses = false; - solve_unification_constraints = true; - fail_evar = false; - expand_evars = true; - program_mode = false; - polymorphic = false; - } - (** Embed all Ltac2 data into Values *) let to_lvar ist = let open Glob_ops in @@ -1033,7 +1062,7 @@ let interp_constr flags ist c = let () = let intern = intern_constr in - let interp ist c = interp_constr (constr_flags ()) ist c in + let interp ist c = interp_constr constr_flags ist c in let print env c = str "constr:(" ++ Printer.pr_lglob_constr_env env c ++ str ")" in let subst subst c = Detyping.subst_glob_constr (Global.env()) subst c in let obj = { @@ -1046,7 +1075,7 @@ let () = let () = let intern = intern_constr in - let interp ist c = interp_constr (open_constr_no_classes_flags ()) ist c in + let interp ist c = interp_constr open_constr_no_classes_flags ist c in let print env c = str "open_constr:(" ++ Printer.pr_lglob_constr_env env c ++ str ")" in let subst subst c = Detyping.subst_glob_constr (Global.env()) subst c in let obj = { @@ -1092,6 +1121,27 @@ let () = define_ml_object Tac2quote.wit_pattern obj let () = + let interp _ c = + let open Ltac_pretype in + let closure = { + idents = Id.Map.empty; + typed = Id.Map.empty; + untyped = Id.Map.empty; + } in + let c = { closure; term = c } in + return (Value.of_ext val_preterm c) + in + let subst subst c = Detyping.subst_glob_constr (Global.env()) subst c in + let print env c = str "preterm:(" ++ Printer.pr_lglob_constr_env env c ++ str ")" in + let obj = { + ml_intern = (fun _ _ e -> Empty.abort e); + ml_interp = interp; + ml_subst = subst; + ml_print = print; + } in + define_ml_object Tac2quote.wit_preterm obj + +let () = let intern self ist ref = match ref.CAst.v with | Tac2qexpr.QHypothesis id -> GlbVal (GlobRef.VarRef id), gtypref t_reference @@ -1221,15 +1271,15 @@ let () = let () = let interp ist poly env sigma concl (ids, tac) = - (* Syntax prevents bound variables in constr quotations *) - let () = assert (List.is_empty ids) in + (* Syntax prevents bound notation variables in constr quotations *) + let () = assert (Id.Set.is_empty ids) in let ist = Tac2interp.get_env ist in let tac = Proofview.tclIGNORE (Tac2interp.interp ist tac) in let name, poly = Id.of_string "ltac2", poly in let c, sigma = Pfedit.refine_by_tactic ~name ~poly env sigma concl tac in (EConstr.of_constr c, sigma) in - GlobEnv.register_constr_interp0 wit_ltac2 interp + GlobEnv.register_constr_interp0 wit_ltac2_constr interp let () = let interp ist poly env sigma concl id = @@ -1247,6 +1297,29 @@ let () = let pr_top _ = Genprint.TopPrinterBasic mt in Genprint.register_print0 wit_ltac2_quotation pr_raw pr_glb pr_top +let () = + let subs globs (ids, tac) = + (* Let-bind the notation terms inside the tactic *) + let fold id (c, _) (rem, accu) = + let c = GTacExt (Tac2quote.wit_preterm, c) in + let rem = Id.Set.remove id rem in + rem, (Name id, c) :: accu + in + let rem, bnd = Id.Map.fold fold globs (ids, []) in + let () = if not @@ Id.Set.is_empty rem then + (* FIXME: provide a reasonable middle-ground with the behaviour + introduced by 8d9b66b. We should be able to pass mere syntax to + term notation without facing the wrath of the internalization. *) + let plural = if Id.Set.cardinal rem <= 1 then " " else "s " in + CErrors.user_err (str "Missing notation term for variable" ++ str plural ++ + pr_sequence Id.print (Id.Set.elements rem) ++ + str ", probably an ill-typed expression") + in + let tac = if List.is_empty bnd then tac else GTacLet (false, bnd, tac) in + (Id.Set.empty, tac) + in + Genintern.register_ntn_subst0 wit_ltac2_constr subs + (** Ltac2 in Ltac1 *) let () = diff --git a/user-contrib/Ltac2/tac2entries.ml b/user-contrib/Ltac2/tac2entries.ml index 6b7b75f0d4..bcc5f54505 100644 --- a/user-contrib/Ltac2/tac2entries.ml +++ b/user-contrib/Ltac2/tac2entries.ml @@ -374,6 +374,15 @@ let register_typedef ?(local = false) isrec types = | ({loc;v=id}, _) :: _ -> user_err ?loc (str "Multiple definition of the type name " ++ Id.print id) in + let () = + let check_existing_type ({v=id},_) = + let qid = Libnames.make_qualid (Lib.current_dirpath false) id in + try let _ = Tac2env.locate_type qid in + user_err (str "Multiple definition of the type name " ++ pr_qualid qid) + with Not_found -> () + in + List.iter check_existing_type types + in let check ({loc;v=id}, (params, def)) = let same_name {v=id1} {v=id2} = Id.equal id1 id2 in let () = match List.duplicates same_name params with @@ -394,6 +403,21 @@ let register_typedef ?(local = false) isrec types = | (id, _) :: _ -> user_err (str "Multiple definitions of the constructor " ++ Id.print id) in + let () = + let check_uppercase_ident (id,_) = + if not (Tac2env.is_constructor_id id) + then user_err (str "Constructor name should start with an uppercase letter " ++ Id.print id) + in + List.iter check_uppercase_ident cs + in + let () = + let check_existing_ctor (id, _) = + let qid = Libnames.make_qualid (Lib.current_dirpath false) id in + if Tac2env.mem_constructor qid + then user_err (str "Constructor already defined in this module " ++ pr_qualid qid) + in + List.iter check_existing_ctor cs + in () | CTydRec ps -> let same_name (id1, _, _) (id2, _, _) = Id.equal id1 id2 in @@ -474,6 +498,21 @@ let register_open ?(local = false) qid (params, def) = match def with | CTydOpn -> () | CTydAlg def -> + let () = + let same_name (id1, _) (id2, _) = Id.equal id1 id2 in + let () = match List.duplicates same_name def with + | [] -> () + | (id, _) :: _ -> + user_err (str "Multiple definitions of the constructor " ++ Id.print id) + in + let check_existing_ctor (id, _) = + let qid = Libnames.make_qualid (Lib.current_dirpath false) id in + if Tac2env.mem_constructor qid + then user_err (str "Constructor already defined in this module " ++ pr_qualid qid) + in + let () = List.iter check_existing_ctor def in + () + in let intern_type t = let tpe = CTydDef (Some t) in let (_, ans) = intern_typedef Id.Map.empty (params, tpe) in @@ -482,6 +521,8 @@ let register_open ?(local = false) qid (params, def) = | _ -> assert false in let map (id, tpe) = + if not (Tac2env.is_constructor_id id) + then user_err (str "Constructor name should start with an uppercase letter " ++ Id.print id) ; let tpe = List.map intern_type tpe in { edata_name = id; edata_args = tpe } in diff --git a/user-contrib/Ltac2/tac2env.ml b/user-contrib/Ltac2/tac2env.ml index 963c3aa37f..b0a910f10e 100644 --- a/user-contrib/Ltac2/tac2env.ml +++ b/user-contrib/Ltac2/tac2env.ml @@ -196,6 +196,11 @@ let shortest_qualid_of_constructor kn = let sp = KNmap.find kn tab.tab_cstr_rev in KnTab.shortest_qualid Id.Set.empty sp tab.tab_cstr +let mem_constructor qid = + let tab = !nametab in + try ignore (KnTab.locate qid tab.tab_cstr) ; true + with Not_found -> false + let push_type vis sp kn = let tab = !nametab in let tab_type = KnTab.push vis sp kn tab.tab_type in @@ -284,12 +289,12 @@ let ltac1_prefix = (** Generic arguments *) let wit_ltac2 = Genarg.make0 "ltac2:value" +let wit_ltac2_constr = Genarg.make0 "ltac2:in-constr" let wit_ltac2_quotation = Genarg.make0 "ltac2:quotation" let () = Geninterp.register_val0 wit_ltac2 None let () = Geninterp.register_val0 wit_ltac2_quotation None -let is_constructor qid = - let (_, id) = repr_qualid qid in +let is_constructor_id id = let id = Id.to_string id in assert (String.length id > 0); match id with @@ -298,3 +303,7 @@ let is_constructor qid = match id.[0] with | 'A'..'Z' -> true | _ -> false + +let is_constructor qid = + let (_, id) = repr_qualid qid in + is_constructor_id id diff --git a/user-contrib/Ltac2/tac2env.mli b/user-contrib/Ltac2/tac2env.mli index 2f4a49a0f5..effb9f705a 100644 --- a/user-contrib/Ltac2/tac2env.mli +++ b/user-contrib/Ltac2/tac2env.mli @@ -83,6 +83,7 @@ val locate_extended_all_ltac : qualid -> tacref list val shortest_qualid_of_ltac : tacref -> qualid val push_constructor : visibility -> full_path -> ltac_constructor -> unit +val mem_constructor : qualid -> bool val locate_constructor : qualid -> ltac_constructor val locate_extended_all_constructor : qualid -> ltac_constructor list val shortest_qualid_of_constructor : ltac_constructor -> qualid @@ -141,8 +142,15 @@ val ltac1_prefix : ModPath.t (** {5 Generic arguments} *) val wit_ltac2 : (Id.t CAst.t list * raw_tacexpr, Id.t list * glb_tacexpr, Util.Empty.t) genarg_type +(** Ltac2 quotations in Ltac1 code *) + +val wit_ltac2_constr : (raw_tacexpr, Id.Set.t * glb_tacexpr, Util.Empty.t) genarg_type +(** Ltac2 quotations in Gallina terms *) + val wit_ltac2_quotation : (Id.t Loc.located, Id.t, Util.Empty.t) genarg_type +(** Ltac2 quotations for variables "$x" in Gallina terms *) (** {5 Helper functions} *) +val is_constructor_id : Id.t -> bool val is_constructor : qualid -> bool diff --git a/user-contrib/Ltac2/tac2ffi.ml b/user-contrib/Ltac2/tac2ffi.ml index 0e6fb94095..9ae17bf9bc 100644 --- a/user-contrib/Ltac2/tac2ffi.ml +++ b/user-contrib/Ltac2/tac2ffi.ml @@ -33,6 +33,8 @@ type valexpr = (** Arbitrary data *) | ValUint63 of Uint63.t (** Primitive integers *) +| ValFloat of Float64.t + (** Primitive floats *) and closure = MLTactic : (valexpr, 'v) arity0 * 'v -> closure @@ -50,21 +52,21 @@ type t = valexpr let is_int = function | ValInt _ -> true -| ValBlk _ | ValStr _ | ValCls _ | ValOpn _ | ValExt _ | ValUint63 _ -> false +| ValBlk _ | ValStr _ | ValCls _ | ValOpn _ | ValExt _ | ValUint63 _ | ValFloat _ -> false let tag v = match v with | ValBlk (n, _) -> n -| ValInt _ | ValStr _ | ValCls _ | ValOpn _ | ValExt _ | ValUint63 _ -> +| ValInt _ | ValStr _ | ValCls _ | ValOpn _ | ValExt _ | ValUint63 _ | ValFloat _ -> CErrors.anomaly (Pp.str "Unexpected value shape") let field v n = match v with | ValBlk (_, v) -> v.(n) -| ValInt _ | ValStr _ | ValCls _ | ValOpn _ | ValExt _ | ValUint63 _ -> +| ValInt _ | ValStr _ | ValCls _ | ValOpn _ | ValExt _ | ValUint63 _ | ValFloat _ -> CErrors.anomaly (Pp.str "Unexpected value shape") let set_field v n w = match v with | ValBlk (_, v) -> v.(n) <- w -| ValInt _ | ValStr _ | ValCls _ | ValOpn _ | ValExt _ | ValUint63 _ -> +| ValInt _ | ValStr _ | ValCls _ | ValOpn _ | ValExt _ | ValUint63 _ | ValFloat _ -> CErrors.anomaly (Pp.str "Unexpected value shape") let make_block tag v = ValBlk (tag, v) @@ -89,6 +91,7 @@ let val_exn = Val.create "exn" let val_constr = Val.create "constr" let val_ident = Val.create "ident" let val_pattern = Val.create "pattern" +let val_preterm = Val.create "preterm" let val_pp = Val.create "pp" let val_sort = Val.create "sort" let val_cast = Val.create "cast" @@ -195,7 +198,7 @@ let of_closure cls = ValCls cls let to_closure = function | ValCls cls -> cls -| ValExt _ | ValInt _ | ValBlk _ | ValStr _ | ValOpn _ | ValUint63 _ -> assert false +| ValExt _ | ValInt _ | ValBlk _ | ValStr _ | ValOpn _ | ValUint63 _ | ValFloat _ -> assert false let closure = { r_of = of_closure; @@ -332,6 +335,17 @@ let uint63 = { r_id = false; } +let of_float f = ValFloat f +let to_float = function +| ValFloat f -> f +| _ -> assert false + +let float = { + r_of = of_float; + r_to = to_float; + r_id = false; +} + let of_constant c = of_ext val_constant c let to_constant c = to_ext val_constant c let constant = repr_ext val_constant diff --git a/user-contrib/Ltac2/tac2ffi.mli b/user-contrib/Ltac2/tac2ffi.mli index 480eee51fc..ee13f00568 100644 --- a/user-contrib/Ltac2/tac2ffi.mli +++ b/user-contrib/Ltac2/tac2ffi.mli @@ -32,6 +32,8 @@ type valexpr = (** Arbitrary data *) | ValUint63 of Uint63.t (** Primitive integers *) +| ValFloat of Float64.t + (** Primitive floats *) type 'a arity @@ -151,6 +153,10 @@ val of_uint63 : Uint63.t -> valexpr val to_uint63 : valexpr -> Uint63.t val uint63 : Uint63.t repr +val of_float : Float64.t -> valexpr +val to_float : valexpr -> Float64.t +val float : Float64.t repr + type ('a, 'b) fun1 val app_fun1 : ('a, 'b) fun1 -> 'a repr -> 'b repr -> 'a -> 'b Proofview.tactic @@ -165,6 +171,7 @@ val valexpr : valexpr repr val val_constr : EConstr.t Val.tag val val_ident : Id.t Val.tag val val_pattern : Pattern.constr_pattern Val.tag +val val_preterm : Ltac_pretype.closed_glob_constr Val.tag val val_pp : Pp.t Val.tag val val_sort : ESorts.t Val.tag val val_cast : Constr.cast_kind Val.tag diff --git a/user-contrib/Ltac2/tac2intern.ml b/user-contrib/Ltac2/tac2intern.ml index 5b3aa799a1..4e39b21c53 100644 --- a/user-contrib/Ltac2/tac2intern.ml +++ b/user-contrib/Ltac2/tac2intern.ml @@ -28,6 +28,7 @@ let t_int = coq_type "int" let t_string = coq_type "string" let t_constr = coq_type "constr" let t_ltac1 = ltac1_type "t" +let t_preterm = coq_type "preterm" (** Union find *) @@ -1511,7 +1512,7 @@ let () = let ids = List.map (fun { CAst.v = id } -> id) ids in let env = match Genintern.Store.get ist.extra ltac2_env with | None -> - (* Only happens when Ltac2 is called from a constr or ltac1 quotation *) + (* Only happens when Ltac2 is called from a toplevel ltac1 quotation *) let env = empty_env () in if !Ltac_plugin.Tacintern.strict_check then env else { env with env_str = false } @@ -1527,7 +1528,36 @@ let () = (ist, (ids, tac)) in Genintern.register_intern0 wit_ltac2 intern + +let () = + let open Genintern in + let intern ist tac = + let env = match Genintern.Store.get ist.extra ltac2_env with + | None -> + (* Only happens when Ltac2 is called from a constr quotation *) + let env = empty_env () in + if !Ltac_plugin.Tacintern.strict_check then env + else { env with env_str = false } + | Some env -> env + in + (* Special handling of notation variables *) + let fold id _ (ids, env) = + let () = assert (not @@ Id.Map.mem id env.env_var) in + let t = monomorphic (GTypRef (Other t_preterm, [])) in + let env = push_name (Name id) t env in + (Id.Set.add id ids, env) + in + let ntn_vars = ist.intern_sign.notation_variable_status in + let ids, env = Id.Map.fold fold ntn_vars (Id.Set.empty, env) in + let loc = tac.loc in + let (tac, t) = intern_rec env tac in + let () = check_elt_unit loc env t in + (ist, (ids, tac)) + in + Genintern.register_intern0 wit_ltac2_constr intern + let () = Genintern.register_subst0 wit_ltac2 (fun s (ids, e) -> ids, subst_expr s e) +let () = Genintern.register_subst0 wit_ltac2_constr (fun s (ids, e) -> ids, subst_expr s e) let () = let open Genintern in @@ -1540,6 +1570,12 @@ let () = else { env with env_str = false } | Some env -> env in + (* Special handling of notation variables *) + let () = + if Id.Map.mem id ist.intern_sign.notation_variable_status then + (* Always fail *) + unify ?loc env (GTypRef (Other t_preterm, [])) (GTypRef (Other t_constr, [])) + in let t = try Id.Map.find id env.env_var with Not_found -> diff --git a/user-contrib/Ltac2/tac2quote.ml b/user-contrib/Ltac2/tac2quote.ml index 405c80fa9b..645b92c302 100644 --- a/user-contrib/Ltac2/tac2quote.ml +++ b/user-contrib/Ltac2/tac2quote.ml @@ -23,6 +23,7 @@ let wit_reference = Arg.create "reference" let wit_ident = Arg.create "ident" let wit_constr = Arg.create "constr" let wit_open_constr = Arg.create "open_constr" +let wit_preterm = Arg.create "preterm" let wit_ltac1 = Arg.create "ltac1" let wit_ltac1val = Arg.create "ltac1val" diff --git a/user-contrib/Ltac2/tac2quote.mli b/user-contrib/Ltac2/tac2quote.mli index da28e04df0..f1564cd443 100644 --- a/user-contrib/Ltac2/tac2quote.mli +++ b/user-contrib/Ltac2/tac2quote.mli @@ -97,6 +97,8 @@ val wit_constr : (Constrexpr.constr_expr, Glob_term.glob_constr) Arg.tag val wit_open_constr : (Constrexpr.constr_expr, Glob_term.glob_constr) Arg.tag +val wit_preterm : (Util.Empty.t, Glob_term.glob_constr) Arg.tag + val wit_ltac1 : (Id.t CAst.t list * Ltac_plugin.Tacexpr.raw_tactic_expr, Id.t list * Ltac_plugin.Tacexpr.glob_tactic_expr) Arg.tag (** Ltac1 AST quotation, seen as a 'tactic'. Its type is unit in Ltac2. *) diff --git a/vernac/attributes.ml b/vernac/attributes.ml index 6af454eee5..b7a3b002bd 100644 --- a/vernac/attributes.ml +++ b/vernac/attributes.ml @@ -18,13 +18,17 @@ and vernac_flag_value = | VernacFlagLeaf of string | VernacFlagList of vernac_flags +let warn_unsupported_attributes = + CWarnings.create ~name:"unsupported-attributes" ~category:"parsing" ~default:CWarnings.AsError + (fun atts -> + let keys = List.map fst atts in + let keys = List.sort_uniq String.compare keys in + let conj = match keys with [_] -> "this attribute: " | _ -> "these attributes: " in + Pp.(str "This command does not support " ++ str conj ++ prlist str keys ++ str".")) + let unsupported_attributes = function | [] -> () - | atts -> - let keys = List.map fst atts in - let keys = List.sort_uniq String.compare keys in - let conj = match keys with [_] -> "this attribute: " | _ -> "these attributes: " in - user_err Pp.(str "This command does not support " ++ str conj ++ prlist str keys ++ str".") + | atts -> warn_unsupported_attributes atts type 'a key_parser = 'a option -> vernac_flag_value -> 'a diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index 98fe436a22..5822a1a586 100644 --- a/vernac/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -248,6 +248,7 @@ let build_beq_scheme mode kn = | Meta _ -> raise (EqUnknown "meta-variable") | Evar _ -> raise (EqUnknown "existential variable") | Int _ -> raise (EqUnknown "int") + | Float _ -> raise (EqUnknown "float") in aux t in diff --git a/vernac/classes.ml b/vernac/classes.ml index 09866a75c9..e9a0ed7c34 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -47,7 +47,7 @@ let add_instance_hint inst path local info poly = in Flags.silently (fun () -> Hints.add_hints ~local [typeclasses_db] - (Hints.HintsResolveEntry + (Hints.HintsResolveEntry [info, poly, false, Hints.PathHints path, inst'])) () let is_local_for_hint i = @@ -287,7 +287,7 @@ let type_ctx_instance ~program_mode env sigma ctx inst subst = decl :: ctx -> let t' = substl subst (RelDecl.get_type decl) in let (sigma, c'), l = - match decl with + match decl with | LocalAssum _ -> interp_casted_constr_evars ~program_mode env sigma (List.hd l) t', List.tl l | LocalDef (_,b,_) -> (sigma, substl subst b), l in @@ -301,8 +301,8 @@ let id_of_class cl = match cl.cl_impl with | ConstRef kn -> Label.to_id @@ Constant.label kn | IndRef (kn,i) -> - let mip = (Environ.lookup_mind kn (Global.env ())).Declarations.mind_packets in - mip.(0).Declarations.mind_typename + let mip = (Environ.lookup_mind kn (Global.env ())).Declarations.mind_packets in + mip.(0).Declarations.mind_typename | _ -> assert false let instance_hook info global imps ?hook cst = @@ -314,15 +314,9 @@ let instance_hook info global imps ?hook cst = (match hook with Some h -> h cst | None -> ()) let declare_instance_constant info global imps ?hook name decl poly sigma term termtype = - (* XXX: Duplication of the declare_constant path *) - let sigma = - let levels = Univ.LSet.union (CVars.universes_of_constr termtype) - (CVars.universes_of_constr term) in - Evd.restrict_universe_context sigma levels - in - let uctx = Evd.check_univ_decl ~poly sigma decl in let kind = Decls.(IsDefinition Instance) in - let entry = Declare.definition_entry ~types:termtype ~univs:uctx term in + let sigma, entry = DeclareDef.prepare_definition + ~allow_evars:false ~poly sigma decl ~types:(Some termtype) ~body:term in let kn = Declare.declare_constant ~name ~kind (Declare.DefinitionEntry entry) in Declare.definition_message name; DeclareUniv.declare_univ_binders (GlobRef.ConstRef kn) (Evd.universe_binders sigma); @@ -341,7 +335,7 @@ let do_declare_instance sigma ~global ~poly k u ctx ctx' pri decl imps subst nam DeclareUniv.declare_univ_binders (GlobRef.ConstRef cst) (Evd.universe_binders sigma); instance_hook pri global imps (GlobRef.ConstRef cst) -let declare_instance_program env sigma ~global ~poly id pri imps decl term termtype = +let declare_instance_program env sigma ~global ~poly name pri imps univdecl term termtype = let hook { DeclareDef.Hook.S.scope; dref; _ } = let cst = match dref with GlobRef.ConstRef kn -> kn | _ -> assert false in Impargs.declare_manual_implicits false dref imps; @@ -350,19 +344,13 @@ let declare_instance_program env sigma ~global ~poly id pri imps decl term termt let sigma = Evd.from_env env in declare_instance env sigma (Some pri) (not global) (GlobRef.ConstRef cst) in - let obls, constr, typ = - match term with - | Some t -> - let termtype = EConstr.of_constr termtype in - let obls, _, constr, typ = - Obligations.eterm_obligations env id sigma 0 t termtype - in obls, Some constr, typ - | None -> [||], None, termtype - in + let obls, _, term, typ = Obligations.eterm_obligations env name sigma 0 term termtype in let hook = DeclareDef.Hook.make hook in let ctx = Evd.evar_universe_context sigma in - ignore(Obligations.add_definition ~name:id ?term:constr - ~univdecl:decl ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) ~poly ~kind:Decls.Instance ~hook typ ctx obls) + let scope, kind = DeclareDef.Global Declare.ImportDefaultBehavior, Decls.Instance in + let _ : DeclareObl.progress = + Obligations.add_definition ~name ~term ~univdecl ~scope ~poly ~kind ~hook typ ctx obls + in () let declare_instance_open sigma ?hook ~tac ~global ~poly id pri imps udecl ids term termtype = (* spiwack: it is hard to reorder the actions to do @@ -374,20 +362,24 @@ let declare_instance_open sigma ?hook ~tac ~global ~poly id pri imps udecl ids t let kind = Decls.(IsDefinition Instance) in let hook = DeclareDef.Hook.(make (fun { S.dref ; _ } -> instance_hook pri global imps ?hook dref)) in let info = Lemmas.Info.make ~hook ~kind () in - let lemma = Lemmas.start_lemma ~name:id ~poly ~udecl ~info sigma (EConstr.of_constr termtype) in + (* XXX: We need to normalize the type, otherwise Admitted / Qed will fails! + This is due to a bug in proof_global :( *) + let termtype = Evarutil.nf_evar sigma termtype in + let lemma = Lemmas.start_lemma ~name:id ~poly ~udecl ~info sigma termtype in (* spiwack: I don't know what to do with the status here. *) let lemma = - if not (Option.is_empty term) then + match term with + | Some term -> let init_refine = Tacticals.New.tclTHENLIST [ - Refine.refine ~typecheck:false (fun sigma -> (sigma, Option.get term)); + Refine.refine ~typecheck:false (fun sigma -> sigma, term); Proofview.Unsafe.tclNEWGOALS (CList.map Proofview.with_empty_state gls); Tactics.New.reduce_after_refine; ] in let lemma, _ = Lemmas.by init_refine lemma in lemma - else + | None -> let lemma, _ = Lemmas.by (Tactics.auto_intros_tac ids) lemma in lemma in @@ -419,7 +411,6 @@ let do_instance_resolve_TC term termtype sigma env = let sigma = Evd.minimize_universes sigma in (* Check that the type is free of evars now. *) Pretyping.check_evars env (Evd.from_env env) sigma termtype; - let termtype = to_constr sigma termtype in termtype, sigma let do_instance_type_ctx_instance props k env' ctx' sigma ~program_mode subst = @@ -459,9 +450,9 @@ let do_instance_type_ctx_instance props k env' ctx' sigma ~program_mode subst = let do_instance_interactive env sigma ?hook ~tac ~global ~poly cty k u ctx ctx' pri decl imps subst id = let term, termtype = if List.is_empty k.cl_props then - let term, termtype = - do_instance_subst_constructor_and_ty subst k u (ctx' @ ctx) in - Some term, termtype + let term, termtype = + do_instance_subst_constructor_and_ty subst k u (ctx' @ ctx) in + Some term, termtype else None, it_mkProd_or_LetIn cty ctx in let termtype, sigma = do_instance_resolve_TC term termtype sigma env in @@ -489,7 +480,6 @@ let do_instance env env' sigma ?hook ~global ~poly cty k u ctx ctx' pri decl imp if Evd.has_undefined sigma then CErrors.user_err Pp.(str "Unsolved obligations remaining.") else - let term = to_constr sigma term in 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 = @@ -499,24 +489,23 @@ let do_instance_program env env' sigma ?hook ~global ~poly cty k u ctx ctx' pri check_duplicate ?loc fs; let subst, sigma = do_instance_type_ctx_instance fs k env' ctx' sigma ~program_mode:true subst in - let term, termtype = - do_instance_subst_constructor_and_ty subst k u (ctx' @ ctx) in - Some term, termtype, sigma + let term, termtype = + do_instance_subst_constructor_and_ty subst k u (ctx' @ ctx) in + term, termtype, sigma | Some (_, term) -> let sigma, def = interp_casted_constr_evars ~program_mode:true env' sigma term cty in let termtype = it_mkProd_or_LetIn cty ctx in let term = it_mkLambda_or_LetIn def ctx in - Some term, termtype, sigma + term, termtype, sigma | None -> let subst, sigma = do_instance_type_ctx_instance [] k env' ctx' sigma ~program_mode:true subst in let term, termtype = do_instance_subst_constructor_and_ty subst k u (ctx' @ ctx) in - Some term, termtype, sigma in + term, termtype, sigma in let termtype, sigma = do_instance_resolve_TC term termtype sigma env in if not (Evd.has_undefined sigma) && not (Option.is_empty opt_props) then - let term = to_constr sigma (Option.get term) in declare_instance_constant pri global imps ?hook id decl poly sigma term termtype else declare_instance_program env sigma ~global ~poly id pri imps decl term termtype diff --git a/vernac/comArguments.ml b/vernac/comArguments.ml new file mode 100644 index 0000000000..737e0427ec --- /dev/null +++ b/vernac/comArguments.ml @@ -0,0 +1,306 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +open CAst +open Util +open Names +open Vernacexpr + +let smart_global r = + let gr = Smartlocate.smart_global r in + Dumpglob.add_glob ?loc:r.loc gr; + gr + +let cache_bidi_hints (_name, (gr, ohint)) = + match ohint with + | None -> Pretyping.clear_bidirectionality_hint gr + | Some nargs -> Pretyping.add_bidirectionality_hint gr nargs + +let load_bidi_hints _ r = + cache_bidi_hints r + +let subst_bidi_hints (subst, (gr, ohint as orig)) = + let gr' = Globnames.subst_global_reference subst gr in + if gr == gr' then orig else (gr', ohint) + +let discharge_bidi_hints (_name, (gr, ohint)) = + if Globnames.isVarRef gr && Lib.is_in_section gr then None + else + let vars = Lib.variable_section_segment_of_reference gr in + let n = List.length vars in + Some (gr, Option.map ((+) n) ohint) + +let inBidiHints = + let open Libobject in + declare_object { (default_object "BIDIRECTIONALITY-HINTS" ) with + load_function = load_bidi_hints; + cache_function = cache_bidi_hints; + classify_function = (fun o -> Substitute o); + subst_function = subst_bidi_hints; + discharge_function = discharge_bidi_hints; + } + + +let warn_arguments_assert = + CWarnings.create ~name:"arguments-assert" ~category:"vernacular" + Pp.(fun sr -> + strbrk "This command is just asserting the names of arguments of " ++ + Printer.pr_global sr ++ strbrk". If this is what you want add " ++ + strbrk "': assert' to silence the warning. If you want " ++ + strbrk "to clear implicit arguments add ': clear implicits'. " ++ + strbrk "If you want to clear notation scopes add ': clear scopes'") + +(* [nargs_for_red] is the number of arguments required to trigger reduction, + [args] is the main list of arguments statuses, + [more_implicits] is a list of extra lists of implicit statuses *) +let vernac_arguments ~section_local reference args more_implicits nargs_for_red nargs_before_bidi flags = + let env = Global.env () in + let sigma = Evd.from_env env in + let assert_flag = List.mem `Assert flags in + let rename_flag = List.mem `Rename flags in + let clear_scopes_flag = List.mem `ClearScopes flags in + let extra_scopes_flag = List.mem `ExtraScopes flags in + let clear_implicits_flag = List.mem `ClearImplicits flags in + let default_implicits_flag = List.mem `DefaultImplicits flags in + let never_unfold_flag = List.mem `ReductionNeverUnfold flags in + let nomatch_flag = List.mem `ReductionDontExposeCase flags in + let clear_bidi_hint = List.mem `ClearBidiHint flags in + + let err_incompat x y = + CErrors.user_err Pp.(str ("Options \""^x^"\" and \""^y^"\" are incompatible.")) in + + if assert_flag && rename_flag then + err_incompat "assert" "rename"; + if clear_scopes_flag && extra_scopes_flag then + err_incompat "clear scopes" "extra scopes"; + if clear_implicits_flag && default_implicits_flag then + err_incompat "clear implicits" "default implicits"; + + let sr = smart_global reference in + let inf_names = + let ty, _ = Typeops.type_of_global_in_context env sr in + Impargs.compute_implicits_names env sigma (EConstr.of_constr ty) + in + let prev_names = + try Arguments_renaming.arguments_names sr with Not_found -> inf_names + in + let num_args = List.length inf_names in + assert (Int.equal num_args (List.length prev_names)); + + let names_of args = List.map (fun a -> a.name) args in + + (* Checks *) + + let err_extra_args names = + CErrors.user_err ~hdr:"vernac_declare_arguments" + Pp.(strbrk "Extra arguments: " ++ + prlist_with_sep pr_comma Name.print names ++ str ".") + in + let err_missing_args names = + CErrors.user_err ~hdr:"vernac_declare_arguments" + Pp.(strbrk "The following arguments are not declared: " ++ + prlist_with_sep pr_comma Name.print names ++ str ".") + in + + let rec check_extra_args extra_args = + match extra_args with + | [] -> () + | { notation_scope = None } :: _ -> + CErrors.user_err Pp.(str"Extra arguments should specify a scope.") + | { notation_scope = Some _ } :: args -> check_extra_args args + in + + let args, scopes = + let scopes = List.map (fun { notation_scope = s } -> s) args in + if List.length args > num_args then + let args, extra_args = List.chop num_args args in + if extra_scopes_flag then + (check_extra_args extra_args; (args, scopes)) + else err_extra_args (names_of extra_args) + else args, scopes + in + + if Option.cata (fun n -> n > num_args) false nargs_for_red then + CErrors.user_err Pp.(str "The \"/\" modifier should be put before any extra scope."); + + if Option.cata (fun n -> n > num_args) false nargs_before_bidi then + CErrors.user_err Pp.(str "The \"&\" modifier should be put before any extra scope."); + + let scopes_specified = List.exists Option.has_some scopes in + + if scopes_specified && clear_scopes_flag then + CErrors.user_err Pp.(str "The \"clear scopes\" flag is incompatible with scope annotations."); + + let names = List.map (fun { name } -> name) args in + let names = names :: List.map (List.map fst) more_implicits in + + let rename_flag_required = ref false in + let example_renaming = ref None in + let save_example_renaming renaming = + rename_flag_required := !rename_flag_required + || not (Name.equal (fst renaming) Anonymous); + if Option.is_empty !example_renaming then + example_renaming := Some renaming + in + + let rec names_union names1 names2 = + match names1, names2 with + | [], [] -> [] + | _ :: _, [] -> names1 + | [], _ :: _ -> names2 + | (Name _ as name) :: names1, Anonymous :: names2 + | Anonymous :: names1, (Name _ as name) :: names2 -> + name :: names_union names1 names2 + | name1 :: names1, name2 :: names2 -> + if Name.equal name1 name2 then + name1 :: names_union names1 names2 + else CErrors.user_err Pp.(str "Argument lists should agree on the names they provide.") + in + + let names = List.fold_left names_union [] names in + + let rec rename prev_names names = + match prev_names, names with + | [], [] -> [] + | [], _ :: _ -> err_extra_args names + | _ :: _, [] when assert_flag -> + (* Error messages are expressed in terms of original names, not + renamed ones. *) + err_missing_args (List.lastn (List.length prev_names) inf_names) + | _ :: _, [] -> prev_names + | prev :: prev_names, Anonymous :: names -> + prev :: rename prev_names names + | prev :: prev_names, (Name id as name) :: names -> + if not (Name.equal prev name) then save_example_renaming (prev,name); + name :: rename prev_names names + in + + let names = rename prev_names names in + let renaming_specified = Option.has_some !example_renaming in + + if !rename_flag_required && not rename_flag then begin + let msg = let open Pp in + match !example_renaming with + | None -> + strbrk "To rename arguments the \"rename\" flag must be specified." + | Some (o,n) -> + strbrk "Flag \"rename\" expected to rename " ++ Name.print o ++ + strbrk " into " ++ Name.print n ++ str "." + in CErrors.user_err ~hdr:"vernac_declare_arguments" msg + end; + + let duplicate_names = + List.duplicates Name.equal (List.filter ((!=) Anonymous) names) + in + if not (List.is_empty duplicate_names) then begin + CErrors.user_err Pp.(strbrk "Some argument names are duplicated: " ++ + prlist_with_sep pr_comma Name.print duplicate_names) + end; + + let implicits = + List.map (fun { name; implicit_status = i } -> (name,i)) args + in + let implicits = implicits :: more_implicits in + + let implicits = List.map (List.map snd) implicits in + let implicits_specified = match implicits with + | [l] -> List.exists (function Impargs.NotImplicit -> false | _ -> true) l + | _ -> true in + + if implicits_specified && clear_implicits_flag then + CErrors.user_err Pp.(str "The \"clear implicits\" flag is incompatible with implicit annotations"); + + if implicits_specified && default_implicits_flag then + CErrors.user_err Pp.(str "The \"default implicits\" flag is incompatible with implicit annotations"); + + let rargs = + Util.List.map_filter (function (n, true) -> Some n | _ -> None) + (Util.List.map_i (fun i { recarg_like = b } -> i, b) 0 args) + in + + let red_behavior = + let open Reductionops.ReductionBehaviour in + match never_unfold_flag, nomatch_flag, rargs, nargs_for_red with + | true, false, [], None -> Some NeverUnfold + | true, true, _, _ -> err_incompat "simpl never" "simpl nomatch" + | true, _, _::_, _ -> err_incompat "simpl never" "!" + | true, _, _, Some _ -> err_incompat "simpl never" "/" + | false, false, [], None -> None + | false, false, _, _ -> Some (UnfoldWhen { nargs = nargs_for_red; + recargs = rargs; + }) + | false, true, _, _ -> Some (UnfoldWhenNoMatch { nargs = nargs_for_red; + recargs = rargs; + }) + in + + + let red_modifiers_specified = Option.has_some red_behavior in + + let bidi_hint_specified = Option.has_some nargs_before_bidi in + + if bidi_hint_specified && clear_bidi_hint then + err_incompat "clear bidirectionality hint" "&"; + + + (* Actions *) + + if renaming_specified then begin + Arguments_renaming.rename_arguments section_local sr names + end; + + if scopes_specified || clear_scopes_flag then begin + let scopes = List.map (Option.map (fun {loc;v=k} -> + try ignore (Notation.find_scope k); k + with CErrors.UserError _ -> + Notation.find_delimiters_scope ?loc k)) scopes + in + Notation.declare_arguments_scope section_local (smart_global reference) scopes + end; + + if implicits_specified || clear_implicits_flag then + Impargs.set_implicits section_local (smart_global reference) implicits; + + if default_implicits_flag then + Impargs.declare_implicits section_local (smart_global reference); + + if red_modifiers_specified then begin + match sr with + | GlobRef.ConstRef _ -> + Reductionops.ReductionBehaviour.set + ~local:section_local sr (Option.get red_behavior) + + | _ -> + CErrors.user_err + Pp.(strbrk "Modifiers of the behavior of the simpl tactic "++ + strbrk "are relevant for constants only.") + end; + + if bidi_hint_specified then begin + let n = Option.get nargs_before_bidi in + if section_local then + Pretyping.add_bidirectionality_hint sr n + else + Lib.add_anonymous_leaf (inBidiHints (sr, Some n)) + end; + + if clear_bidi_hint then begin + if section_local then + Pretyping.clear_bidirectionality_hint sr + else + Lib.add_anonymous_leaf (inBidiHints (sr, None)) + end; + + if not (renaming_specified || + implicits_specified || + scopes_specified || + red_modifiers_specified || + bidi_hint_specified) && (List.is_empty flags) then + warn_arguments_assert sr diff --git a/vernac/comArguments.mli b/vernac/comArguments.mli new file mode 100644 index 0000000000..f78e01a11f --- /dev/null +++ b/vernac/comArguments.mli @@ -0,0 +1,19 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +val vernac_arguments + : section_local:bool + -> Libnames.qualid Constrexpr.or_by_notation + -> Vernacexpr.vernac_argument_status list + -> (Names.Name.t * Impargs.implicit_kind) list list + -> int option + -> int option + -> Vernacexpr.arguments_modifier list + -> unit diff --git a/vernac/comInductive.ml b/vernac/comInductive.ml index cee5b7c1f4..36aa7a37a2 100644 --- a/vernac/comInductive.ml +++ b/vernac/comInductive.ml @@ -354,6 +354,67 @@ let restrict_inductive_universes sigma ctx_params arities constructors = let uvars = List.fold_right (fun (_,ctypes,_) -> List.fold_right merge_universes_of_constr ctypes) constructors uvars in Evd.restrict_universe_context sigma uvars +let interp_mutual_inductive_constr ~env0 ~sigma ~template ~udecl ~env_ar ~env_params ~ctx_params ~indnames ~arities ~arityconcl ~constructors ~env_ar_params ~cumulative ~poly ~private_ind ~finite = + (* Compute renewed arities *) + let sigma = Evd.minimize_universes sigma in + let nf = Evarutil.nf_evars_universes sigma in + let constructors = List.map (on_pi2 (List.map nf)) constructors in + let arities = List.map EConstr.(to_constr sigma) arities in + let sigma = List.fold_left make_anonymous_conclusion_flexible sigma arityconcl in + let sigma, arities = inductive_levels env_ar_params sigma arities constructors in + let sigma = Evd.minimize_universes sigma in + let nf = Evarutil.nf_evars_universes sigma in + let arities = List.map (on_snd nf) arities in + let constructors = List.map (on_pi2 (List.map nf)) constructors in + let ctx_params = List.map Termops.(map_rel_decl (EConstr.to_constr sigma)) ctx_params in + let arityconcl = List.map (Option.map (fun (_anon, s) -> EConstr.ESorts.kind sigma s)) arityconcl in + let sigma = restrict_inductive_universes sigma ctx_params (List.map snd arities) constructors in + let uctx = Evd.check_univ_decl ~poly sigma udecl in + List.iter (fun c -> check_evars env_params (Evd.from_env env_params) sigma (EConstr.of_constr (snd c))) arities; + Context.Rel.iter (fun c -> check_evars env0 (Evd.from_env env0) sigma (EConstr.of_constr c)) ctx_params; + List.iter (fun (_,ctyps,_) -> + List.iter (fun c -> check_evars env_ar_params (Evd.from_env env_ar_params) sigma (EConstr.of_constr c)) ctyps) + constructors; + + (* Build the inductive entries *) + let entries = List.map4 (fun indname (templatearity, arity) concl (cnames,ctypes,cimpls) -> + let template_candidate () = + templatearity || template_polymorphism_candidate env0 uctx ctx_params concl in + let template = match template with + | Some template -> + if poly && template then user_err + Pp.(strbrk "Template-polymorphism and universe polymorphism are not compatible."); + if template && not (template_candidate ()) then + user_err Pp.(strbrk "Inductive " ++ Id.print indname ++ + str" cannot be made template polymorphic."); + template + | None -> + should_auto_template indname (template_candidate ()) + in + { mind_entry_typename = indname; + mind_entry_arity = arity; + mind_entry_template = template; + mind_entry_consnames = cnames; + mind_entry_lc = ctypes + }) + indnames arities arityconcl constructors + in + let variance = if poly && cumulative then Some (InferCumulativity.dummy_variance uctx) else None in + (* Build the mutual inductive entry *) + let mind_ent = + { mind_entry_params = ctx_params; + mind_entry_record = None; + mind_entry_finite = finite; + mind_entry_inds = entries; + mind_entry_private = if private_ind then Some false else None; + mind_entry_universes = uctx; + mind_entry_variance = variance; + } + in + (if poly && cumulative then + InferCumulativity.infer_inductive env_ar mind_ent + else mind_ent), Evd.universe_binders sigma + let interp_params env udecl uparamsl paramsl = let sigma, udecl = interp_univ_decl_opt env udecl in let sigma, (uimpls, ((env_uparams, ctx_uparams), useruimpls)) = @@ -432,73 +493,16 @@ let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) not let fullarities = List.map (fun c -> EConstr.it_mkProd_or_LetIn c ctx_uparams) fullarities in let env_ar = push_types env0 indnames relevances fullarities in let env_ar_params = EConstr.push_rel_context ctx_params env_ar in - (* Try further to solve evars, and instantiate them *) let sigma = solve_remaining_evars all_and_fail_flags env_params sigma in - (* Compute renewed arities *) - let sigma = Evd.minimize_universes sigma in - let nf = Evarutil.nf_evars_universes sigma in - let constructors = List.map (fun (idl,cl,impsl) -> (idl,List.map nf cl,impsl)) constructors in - let arities = List.map EConstr.(to_constr sigma) arities in - let sigma = List.fold_left make_anonymous_conclusion_flexible sigma arityconcl in - let sigma, arities = inductive_levels env_ar_params sigma arities constructors in - let sigma = Evd.minimize_universes sigma in - let nf = Evarutil.nf_evars_universes sigma in - let arities = List.map (fun (template, arity) -> template, nf arity) arities in - let constructors = List.map (fun (idl,cl,impsl) -> (idl,List.map nf cl,impsl)) constructors in - let ctx_params = List.map Termops.(map_rel_decl (EConstr.to_constr sigma)) ctx_params in - let arityconcl = List.map (Option.map (fun (anon, s) -> EConstr.ESorts.kind sigma s)) arityconcl in - let sigma = restrict_inductive_universes sigma ctx_params (List.map snd arities) constructors in - let uctx = Evd.check_univ_decl ~poly sigma udecl in - List.iter (fun c -> check_evars env_params (Evd.from_env env_params) sigma (EConstr.of_constr (snd c))) arities; - Context.Rel.iter (fun c -> check_evars env0 (Evd.from_env env0) sigma (EConstr.of_constr c)) ctx_params; - List.iter (fun (_,ctyps,_) -> - List.iter (fun c -> check_evars env_ar_params (Evd.from_env env_ar_params) sigma (EConstr.of_constr c)) ctyps) - constructors; - - (* Build the inductive entries *) - let entries = List.map4 (fun ind (templatearity, arity) concl (cnames,ctypes,cimpls) -> - let template_candidate () = - templatearity || template_polymorphism_candidate env0 uctx ctx_params concl in - let template = match template with - | Some template -> - if poly && template then user_err - Pp.(strbrk "Template-polymorphism and universe polymorphism are not compatible."); - if template && not (template_candidate ()) then - user_err Pp.(strbrk "Inductive " ++ Id.print ind.ind_name ++ - str" cannot be made template polymorphic."); - template - | None -> - should_auto_template ind.ind_name (template_candidate ()) - in - { mind_entry_typename = ind.ind_name; - mind_entry_arity = arity; - mind_entry_template = template; - mind_entry_consnames = cnames; - mind_entry_lc = ctypes - }) - indl arities arityconcl constructors - in let impls = - List.map2 (fun indimpls (_,_,cimpls) -> + List.map2 (fun indimpls (_,_,cimpls) -> indimpls, List.map (fun impls -> - userimpls @ impls) cimpls) indimpls constructors + userimpls @ impls) cimpls) indimpls constructors in - let variance = if poly && cumulative then Some (InferCumulativity.dummy_variance uctx) else None in - (* Build the mutual inductive entry *) - let mind_ent = - { mind_entry_params = ctx_params; - mind_entry_record = None; - mind_entry_finite = finite; - mind_entry_inds = entries; - mind_entry_private = if private_ind then Some false else None; - mind_entry_universes = uctx; - mind_entry_variance = variance; - } - in - (if poly && cumulative then - InferCumulativity.infer_inductive env_ar mind_ent - else mind_ent), Evd.universe_binders sigma, impls + let mie, pl = interp_mutual_inductive_constr ~env0 ~template ~sigma ~env_params ~env_ar ~ctx_params ~udecl ~arities ~arityconcl ~constructors ~env_ar_params ~poly ~finite ~cumulative ~private_ind ~indnames in + (mie, pl, impls) + (* Very syntactical equality *) let eq_local_binders bl1 bl2 = diff --git a/vernac/comInductive.mli b/vernac/comInductive.mli index 067fb3d2ca..45e539b1e4 100644 --- a/vernac/comInductive.mli +++ b/vernac/comInductive.mli @@ -49,6 +49,25 @@ val declare_mutual_inductive_with_eliminations -> Names.MutInd.t [@@ocaml.deprecated "Please use DeclareInd.declare_mutual_inductive_with_eliminations"] +val interp_mutual_inductive_constr : + env0:Environ.env -> + sigma:Evd.evar_map -> + template:bool option -> + udecl:UState.universe_decl -> + env_ar:Environ.env -> + env_params:Environ.env -> + ctx_params:(EConstr.t, EConstr.t) Context.Rel.Declaration.pt list -> + indnames:Names.Id.t list -> + arities:EConstr.t list -> + arityconcl:(bool * EConstr.ESorts.t) option list -> + constructors:(Names.Id.t list * Constr.constr list * 'a list list) list -> + env_ar_params:Environ.env -> + cumulative:bool -> + poly:bool -> + private_ind:bool -> + finite:Declarations.recursivity_kind -> + Entries.mutual_inductive_entry * UnivNames.universe_binders + (************************************************************************) (** Internal API, exported for Record *) (************************************************************************) diff --git a/vernac/declaremods.ml b/vernac/declaremods.ml index c7b68d18c2..65cd4cd6a4 100644 --- a/vernac/declaremods.ml +++ b/vernac/declaremods.ml @@ -1068,3 +1068,9 @@ let debug_print_modtab _ = in let modules = MPmap.fold pr_modinfo (ModObjs.all ()) (mt ()) in hov 0 modules + + +let mod_ops = { + Printmod.import_module = import_module; + process_module_binding = process_module_binding; +} diff --git a/vernac/declaremods.mli b/vernac/declaremods.mli index ae84704656..23f25bc597 100644 --- a/vernac/declaremods.mli +++ b/vernac/declaremods.mli @@ -126,3 +126,5 @@ val debug_print_modtab : unit -> Pp.t val process_module_binding : MBId.t -> Declarations.module_alg_expr -> unit + +val mod_ops : Printmod.mod_ops diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index efcb2635be..b4c0a33585 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -244,7 +244,8 @@ GRAMMAR EXTEND Gram ; register_type_token: - [ [ "#int63_type" -> { CPrimitives.PT_int63 } ] ] + [ [ "#int63_type" -> { CPrimitives.PT_int63 } + | "#float64_type" -> { CPrimitives.PT_float64 } ] ] ; register_prim_token: @@ -272,6 +273,24 @@ GRAMMAR EXTEND Gram | "#int63_lt" -> { CPrimitives.Int63lt } | "#int63_le" -> { CPrimitives.Int63le } | "#int63_compare" -> { CPrimitives.Int63compare } + | "#float64_opp" -> { CPrimitives.Float64opp } + | "#float64_abs" -> { CPrimitives.Float64abs } + | "#float64_eq" -> { CPrimitives.Float64eq } + | "#float64_lt" -> { CPrimitives.Float64lt } + | "#float64_le" -> { CPrimitives.Float64le } + | "#float64_compare" -> { CPrimitives.Float64compare } + | "#float64_classify" -> { CPrimitives.Float64classify } + | "#float64_add" -> { CPrimitives.Float64add } + | "#float64_sub" -> { CPrimitives.Float64sub } + | "#float64_mul" -> { CPrimitives.Float64mul } + | "#float64_div" -> { CPrimitives.Float64div } + | "#float64_sqrt" -> { CPrimitives.Float64sqrt } + | "#float64_of_int63" -> { CPrimitives.Float64ofInt63 } + | "#float64_normfr_mantissa" -> { CPrimitives.Float64normfr_mantissa } + | "#float64_frshiftexp" -> { CPrimitives.Float64frshiftexp } + | "#float64_ldshiftexp" -> { CPrimitives.Float64ldshiftexp } + | "#float64_next_up" -> { CPrimitives.Float64next_up } + | "#float64_next_down" -> { CPrimitives.Float64next_down } ] ] ; @@ -418,19 +437,19 @@ GRAMMAR EXTEND Gram rec_definition: [ [ id_decl = ident_decl; bl = binders_fixannot; - rtype = type_cstr; + rtype = rec_type_cstr; body_def = OPT [":="; def = lconstr -> { def } ]; notations = decl_notation -> { let binders, rec_order = bl in {fname = fst id_decl; univs = snd id_decl; rec_order; binders; rtype; body_def; notations} } ] ] ; corec_definition: - [ [ id_decl = ident_decl; binders = binders; rtype = type_cstr; + [ [ id_decl = ident_decl; binders = binders; rtype = rec_type_cstr; body_def = OPT [":="; def = lconstr -> { def }]; notations = decl_notation -> { {fname = fst id_decl; univs = snd id_decl; rec_order = (); binders; rtype; body_def; notations} } ]] ; - type_cstr: + rec_type_cstr: [ [ ":"; c=lconstr -> { c } | -> { CAst.make ~loc @@ CHole (None, IntroAnonymous, None) } ] ] ; diff --git a/vernac/library.ml b/vernac/library.ml index 8125c3de35..244424de6b 100644 --- a/vernac/library.ml +++ b/vernac/library.ml @@ -430,23 +430,33 @@ let error_recursively_dependent_library dir = (* Security weakness: file might have been changed on disk between writing the content and computing the checksum... *) -let save_library_to ?todo ~output_native_objects dir f otab = - let except = match todo with - | None -> - (* XXX *) - (* assert(!Flags.compilation_mode = Flags.BuildVo); *) - assert(Filename.check_suffix f ".vo"); - Future.UUIDSet.empty - | Some (l,_) -> - assert(Filename.check_suffix f ".vio"); - List.fold_left (fun e (r,_) -> Future.UUIDSet.add r.Stateid.uuid e) - Future.UUIDSet.empty l in +type ('document,'counters) todo_proofs = + | ProofsTodoNone (* for .vo *) + | ProofsTodoSomeEmpty of Future.UUIDSet.t (* for .vos *) + | ProofsTodoSome of Future.UUIDSet.t * ((Future.UUID.t,'document) Stateid.request * bool) list * 'counters (* for .vio *) + +let save_library_to todo_proofs ~output_native_objects dir f otab = + assert( + let expected_extension = match todo_proofs with + | ProofsTodoNone -> ".vo" + | ProofsTodoSomeEmpty _ -> ".vos" + | ProofsTodoSome _ -> ".vio" + in + Filename.check_suffix f expected_extension); + let except = match todo_proofs with + | ProofsTodoNone -> Future.UUIDSet.empty + | ProofsTodoSomeEmpty except -> except + | ProofsTodoSome (except,l,_) -> except + in let cenv, seg, ast = Declaremods.end_library ~output_native_objects ~except dir in let opaque_table, f2t_map = Opaqueproof.dump ~except otab in let tasks, utab = - match todo with - | None -> None, None - | Some (tasks, rcbackup) -> + match todo_proofs with + | ProofsTodoNone -> None, None + | ProofsTodoSomeEmpty _except -> + None, + Some (Univ.ContextSet.empty,false) + | ProofsTodoSome (_except, tasks, rcbackup) -> let tasks = List.map Stateid.(fun (r,b) -> try { r with uuid = Future.UUIDMap.find r.uuid f2t_map }, b diff --git a/vernac/library.mli b/vernac/library.mli index 6a32413248..ec485e6408 100644 --- a/vernac/library.mli +++ b/vernac/library.mli @@ -36,10 +36,18 @@ type seg_univ = (* all_cst, finished? *) Univ.ContextSet.t * bool type seg_proofs = Opaqueproof.opaque_proofterm array -(** End the compilation of a library and save it to a ".vo" file. +(** End the compilation of a library and save it to a ".vo" file, + a ".vio" file, or a ".vos" file, depending on the todo_proofs + argument. [output_native_objects]: when producing vo objects, also compile the native-code version. *) + +type ('document,'counters) todo_proofs = + | ProofsTodoNone (* for .vo *) + | ProofsTodoSomeEmpty of Future.UUIDSet.t (* for .vos *) + | ProofsTodoSome of Future.UUIDSet.t * ((Future.UUID.t,'document) Stateid.request * bool) list * 'counters (* for .vio *) + val save_library_to : - ?todo:(((Future.UUID.t,'document) Stateid.request * bool) list * 'counters) -> + ('document,'counters) todo_proofs -> output_native_objects:bool -> DirPath.t -> string -> Opaqueproof.opaquetab -> unit diff --git a/vernac/loadpath.ml b/vernac/loadpath.ml index bea0c943c3..b3dc254a63 100644 --- a/vernac/loadpath.ml +++ b/vernac/loadpath.ml @@ -138,6 +138,18 @@ let select_vo_file ~warn loadpath base = System.where_in_path ~warn loadpath name in Some (lpath, file) with Not_found -> None in + if !Flags.load_vos_libraries then begin + (* If the .vos file exists and is not empty, it describes the library. + If the .vos file exists and is empty, then load the .vo file. + If the .vos file is missing, then fail. *) + match find ".vos" with + | None -> Error LibNotFound + | Some (_, vos as resvos) -> + if (Unix.stat vos).Unix.st_size > 0 then Ok resvos else + match find ".vo" with + | None -> Error LibNotFound + | Some resvo -> Ok resvo + end else match find ".vo", find ".vio" with | None, None -> Error LibNotFound @@ -189,8 +201,10 @@ let error_unmapped_dir qid = ]) let error_lib_not_found qid = + let vos = !Flags.load_vos_libraries in + let vos_msg = if vos then [Pp.str " (while searching for a .vos file)"] else [] in CErrors.user_err ~hdr:"load_absolute_library_from" - Pp.(seq [ str "Cannot find library "; Libnames.pr_qualid qid; str" in loadpath"]) + Pp.(seq ([ str "Cannot find library "; Libnames.pr_qualid qid; str" in loadpath"]@vos_msg)) let try_locate_absolute_library dir = match locate_absolute_library dir with diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index f91983d31c..3dbf7afb78 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -1082,8 +1082,13 @@ let string_of_definition_object_kind = let open Decls in function let rec print_arguments n nbidi l = match n, nbidi, l with | Some 0, _, l -> spc () ++ str"/" ++ print_arguments None nbidi l - | _, Some 0, l -> spc () ++ str"|" ++ print_arguments n None l - | _, _, [] -> mt() + | _, Some 0, l -> spc () ++ str"&" ++ print_arguments n None l + | None, None, [] -> mt() + | _, _, [] -> + let dummy = {name=Anonymous; recarg_like=false; + notation_scope=None; implicit_status=Impargs.NotImplicit} + in + print_arguments n nbidi [dummy] | n, nbidi, { name = id; recarg_like = k; notation_scope = s; implicit_status = imp } :: tl -> diff --git a/printing/prettyp.ml b/vernac/prettyp.ml index c995887f31..5ebc89892c 100644 --- a/printing/prettyp.ml +++ b/vernac/prettyp.ml @@ -17,7 +17,6 @@ open CErrors open Util open CAst open Names -open Nameops open Termops open Declarations open Environ @@ -30,25 +29,27 @@ open Printer open Printmod open Context.Rel.Declaration -(* module RelDecl = Context.Rel.Declaration *) +module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration type object_pr = { print_inductive : MutInd.t -> UnivNames.univ_name_list option -> Pp.t; - print_constant_with_infos : Opaqueproof.indirect_accessor -> Constant.t -> UnivNames.univ_name_list option -> Pp.t; + print_constant_with_infos : Constant.t -> UnivNames.univ_name_list option -> Pp.t; print_section_variable : env -> Evd.evar_map -> variable -> Pp.t; print_syntactic_def : env -> KerName.t -> Pp.t; - print_module : mod_ops:Printmod.mod_ops -> bool -> ModPath.t -> Pp.t; - print_modtype : mod_ops:Printmod.mod_ops -> ModPath.t -> Pp.t; + print_module : bool -> ModPath.t -> Pp.t; + print_modtype : ModPath.t -> Pp.t; print_named_decl : env -> Evd.evar_map -> Constr.named_declaration -> Pp.t; - print_library_entry : mod_ops:Printmod.mod_ops -> Opaqueproof.indirect_accessor -> env -> Evd.evar_map -> bool -> (object_name * Lib.node) -> Pp.t option; - print_context : mod_ops:Printmod.mod_ops -> Opaqueproof.indirect_accessor -> env -> Evd.evar_map -> bool -> int option -> Lib.library_segment -> Pp.t; + print_library_entry : env -> Evd.evar_map -> bool -> (object_name * Lib.node) -> Pp.t option; + print_context : env -> Evd.evar_map -> bool -> int option -> Lib.library_segment -> Pp.t; print_typed_value_in_env : Environ.env -> Evd.evar_map -> EConstr.constr * EConstr.types -> Pp.t; print_eval : Reductionops.reduction_function -> env -> Evd.evar_map -> Constrexpr.constr_expr -> EConstr.unsafe_judgment -> Pp.t; } -let gallina_print_module = print_module -let gallina_print_modtype = print_modtype +let gallina_print_module = print_module ~mod_ops:Declaremods.mod_ops +let gallina_print_modtype = print_modtype ~mod_ops:Declaremods.mod_ops + + (**************) (** Utilities *) @@ -94,7 +95,7 @@ let print_ref reduce ref udecl = else mt () in let priv = None in (* We deliberately don't print private univs in About. *) - hov 0 (pr_global ref ++ inst ++ str " :" ++ spc () ++ pr_letype_env env sigma typ ++ + hov 0 (pr_global ref ++ inst ++ str " :" ++ spc () ++ pr_letype_env env sigma typ ++ Printer.pr_abstract_universe_ctx sigma ?variance univs ?priv) (********************************) @@ -123,25 +124,20 @@ let print_impargs_list prefix l = List.flatten (List.map (fun (cond,imps) -> match cond with | None -> - List.map (fun pp -> add_colon prefix ++ pp) - (print_one_impargs_list imps) + List.map (fun pp -> add_colon prefix ++ pp) + (print_one_impargs_list imps) | Some (n1,n2) -> [v 2 (prlist_with_sep cut (fun x -> x) - [(if ismt prefix then str "When" else prefix ++ str ", when") ++ - str " applied to " ++ - (if Int.equal n1 n2 then int_or_no n2 else - if Int.equal n1 0 then str "no more than " ++ int n2 - else int n1 ++ str " to " ++ int_or_no n2) ++ - str (String.plural n2 " argument") ++ str ":"; + [(if ismt prefix then str "When" else prefix ++ str ", when") ++ + str " applied to " ++ + (if Int.equal n1 n2 then int_or_no n2 else + if Int.equal n1 0 then str "no more than " ++ int n2 + else int n1 ++ str " to " ++ int_or_no n2) ++ + str (String.plural n2 " argument") ++ str ":"; v 0 (prlist_with_sep cut (fun x -> x) - (if List.exists is_status_implicit imps - then print_one_impargs_list imps - else [str "No implicit arguments"]))])]) l) - -let print_renames_list prefix l = - if List.is_empty l then [] else - [add_colon prefix ++ str "Arguments are renamed to " ++ - hv 2 (prlist_with_sep pr_comma (fun x -> x) (List.map Name.print l))] + (if List.exists is_status_implicit imps + then print_one_impargs_list imps + else [str "No implicit arguments"]))])]) l) let need_expansion impl ref = let typ, _ = Typeops.type_of_global_in_context (Global.env ()) ref in @@ -163,19 +159,6 @@ let print_impargs ref = else [str "No implicit arguments"])) (*********************) -(** Printing Scopes *) - -let print_argument_scopes prefix = function - | [Some sc] -> - [add_colon prefix ++ str"Argument scope is [" ++ str sc ++ str"]"] - | l when not (List.for_all Option.is_empty l) -> - [add_colon prefix ++ hov 2 (str"Argument scopes are" ++ spc() ++ - str "[" ++ - pr_sequence (function Some sc -> str sc | None -> str "_") l ++ - str "]")] - | _ -> [] - -(*********************) (** Printing Opacity *) type opacity = @@ -191,8 +174,8 @@ let opacity env = let cb = Environ.lookup_constant cst env in (match cb.const_body with | Undef _ | Primitive _ -> None - | OpaqueDef _ -> Some FullyOpaque - | Def _ -> Some + | OpaqueDef _ -> Some FullyOpaque + | Def _ -> Some (TransparentMaybeOpacified (Conv_oracle.get_strategy (Environ.oracle env) (ConstKey cst)))) | _ -> None @@ -254,19 +237,91 @@ let print_primitive_record recflag mipv = function | FakeRecord | NotRecord -> [] let print_primitive ref = - match ref with + match ref with | GlobRef.IndRef ind -> let mib,_ = Global.lookup_inductive ind in print_primitive_record mib.mind_finite mib.mind_packets mib.mind_record | _ -> [] -let print_name_infos ref = - let impls = implicits_of_global ref in +let needs_extra_scopes ref scopes = + let open Constr in + let rec aux env t = function + | [] -> false + | _::scopes -> match kind (Reduction.whd_all env t) with + | Prod (na,dom,codom) -> aux (push_rel (RelDecl.LocalAssum (na,dom)) env) codom scopes + | _ -> true + in + let env = Global.env() in + let ty, _ctx = Typeops.type_of_global_in_context env ref in + aux env ty scopes + +let implicit_kind_of_status = function + | None -> Anonymous, NotImplicit + | Some (id,_,(maximal,_)) -> Name id, if maximal then MaximallyImplicit else Implicit + +let is_dummy {Vernacexpr.implicit_status; name; recarg_like; notation_scope} = + name = Anonymous && not recarg_like && notation_scope = None && implicit_status = NotImplicit + +let rec main_implicits i renames recargs scopes impls = + if renames = [] && recargs = [] && scopes = [] && impls = [] then [] + else + let recarg_like, recargs = match recargs with + | j :: recargs when i = j -> true, recargs + | _ -> false, recargs + in + let (name, implicit_status) = + match renames, impls with + | _, (Some _ as i) :: _ -> implicit_kind_of_status i + | name::_, _ -> (name,NotImplicit) + | [], (None::_ | []) -> (Anonymous, NotImplicit) + in + let notation_scope = match scopes with + | scope :: _ -> Option.map CAst.make scope + | [] -> None + in + let status = {Vernacexpr.implicit_status; name; recarg_like; notation_scope} in + let tl = function [] -> [] | _::tl -> tl in + (* recargs is special -> tl handled above *) + let rest = main_implicits (i+1) (tl renames) recargs (tl scopes) (tl impls) in + if is_dummy status && rest = [] + then [] (* we may have a trail of dummies due to eg "clear scopes" *) + else status :: rest + +let print_arguments ref = + let qid = Nametab.shortest_qualid_of_global Id.Set.empty ref in + let flags, recargs, nargs_for_red = + let open Reductionops.ReductionBehaviour in + match get ref with + | None -> [], [], None + | Some NeverUnfold -> [`ReductionNeverUnfold], [], None + | Some (UnfoldWhen { nargs; recargs }) -> [], recargs, nargs + | Some (UnfoldWhenNoMatch { nargs; recargs }) -> [`ReductionDontExposeCase], recargs, nargs + in + let flags, renames = match Arguments_renaming.arguments_names ref with + | exception Not_found -> flags, [] + | [] -> flags, [] + | renames -> `Rename::flags, renames + in let scopes = Notation.find_arguments_scope ref in - let renames = - try Arguments_renaming.arguments_names ref with Not_found -> [] in + let flags = if needs_extra_scopes ref scopes then `ExtraScopes::flags else flags in + let impls = Impargs.extract_impargs_data (Impargs.implicits_of_global ref) in + let impls, moreimpls = match impls with + | (_, impls) :: rest -> impls, rest + | [] -> assert false + in + let impls = main_implicits 0 renames recargs scopes impls in + let moreimpls = List.map (fun (_,i) -> List.map implicit_kind_of_status i) moreimpls in + let bidi = Pretyping.get_bidirectionality_hint ref in + if impls = [] && moreimpls = [] && nargs_for_red = None && bidi = None && flags = [] then [] + else + let open Constrexpr in + let open Vernacexpr in + [Ppvernac.pr_vernac_expr + (VernacArguments (CAst.make (AN qid), impls, moreimpls, nargs_for_red, bidi, flags))] + +let print_name_infos ref = let type_info_for_implicit = - if need_expansion (select_impargs_size 0 impls) ref then + if need_expansion (select_impargs_size 0 (implicits_of_global ref)) ref then (* Need to reduce since implicits are computed with products flattened *) [str "Expanded type for implicit arguments"; print_ref true ref None; blankline] @@ -275,42 +330,15 @@ let print_name_infos ref = print_type_in_type ref @ print_primitive ref @ type_info_for_implicit @ - print_renames_list (mt()) renames @ - print_impargs_list (mt()) impls @ - print_argument_scopes (mt()) scopes @ + print_arguments ref @ print_if_is_coercion ref -let print_id_args_data test pr id l = - if List.exists test l then - pr (str "For " ++ Id.print id) l - else - [] - -let print_args_data_of_inductive_ids get test pr sp mipv = - List.flatten (Array.to_list (Array.mapi - (fun i mip -> - print_id_args_data test pr mip.mind_typename (get (GlobRef.IndRef (sp,i))) @ - List.flatten (Array.to_list (Array.mapi - (fun j idc -> - print_id_args_data test pr idc (get (GlobRef.ConstructRef ((sp,i),j+1)))) - mip.mind_consnames))) - mipv)) - -let print_inductive_implicit_args = - print_args_data_of_inductive_ids - implicits_of_global (fun l -> not (List.is_empty (positions_of_implicits l))) - print_impargs_list - -let print_inductive_renames = - print_args_data_of_inductive_ids - (fun r -> - try Arguments_renaming.arguments_names r with Not_found -> []) - ((!=) Anonymous) - print_renames_list - -let print_inductive_argument_scopes = - print_args_data_of_inductive_ids - Notation.find_arguments_scope (Option.has_some) print_argument_scopes +let print_inductive_args sp mipv = + let flatmapi f v = List.flatten (Array.to_list (Array.mapi f v)) in + flatmapi + (fun i mip -> print_arguments (GlobRef.IndRef (sp,i)) @ + flatmapi (fun j _ -> print_arguments (GlobRef.ConstructRef ((sp,i),j+1))) + mip.mind_consnames) mipv let print_bidi_hints gr = match Pretyping.get_bidirectionality_hint gr with @@ -367,10 +395,10 @@ let locate_any_name qid = let pr_located_qualid = function | Term ref -> let ref_str = let open GlobRef in match ref with - ConstRef _ -> "Constant" - | IndRef _ -> "Inductive" - | ConstructRef _ -> "Constructor" - | VarRef _ -> "Variable" in + ConstRef _ -> "Constant" + | IndRef _ -> "Inductive" + | ConstructRef _ -> "Constructor" + | VarRef _ -> "Variable" in str ref_str ++ spc () ++ pr_path (Nametab.path_of_global ref) | Syntactic kn -> str "Notation" ++ spc () ++ pr_path (Nametab.path_of_syndef kn) @@ -470,19 +498,19 @@ let print_located_qualid name flags qid = in match located with | [] -> - let (dir,id) = repr_qualid qid in - if DirPath.is_empty dir then - str "No " ++ str name ++ str " of basename" ++ spc () ++ Id.print id - else - str "No " ++ str name ++ str " of suffix" ++ spc () ++ pr_qualid qid + let (dir,id) = repr_qualid qid in + if DirPath.is_empty dir then + str "No " ++ str name ++ str " of basename" ++ spc () ++ Id.print id + else + str "No " ++ str name ++ str " of suffix" ++ spc () ++ pr_qualid qid | l -> - prlist_with_sep fnl - (fun (o,oqid) -> - hov 2 (pr_located_qualid o ++ - (if not (qualid_eq oqid qid) then - spc() ++ str "(shorter name to refer to it in current context is " + prlist_with_sep fnl + (fun (o,oqid) -> + hov 2 (pr_located_qualid o ++ + (if not (qualid_eq oqid qid) then + spc() ++ str "(shorter name to refer to it in current context is " ++ pr_qualid oqid ++ str")" - else mt ()) ++ + else mt ()) ++ display_alias o)) l let print_located_term ref = print_located_qualid "term" LocTerm ref @@ -509,8 +537,8 @@ let print_named_def env sigma name body typ = let pbody = if Constr.isCast body then surround pbody else pbody in (str "*** [" ++ str name ++ str " " ++ hov 0 (str ":=" ++ brk (1,2) ++ pbody ++ spc () ++ - str ":" ++ brk (1,2) ++ ptyp) ++ - str "]") + str ":" ++ brk (1,2) ++ ptyp) ++ + str "]") let print_named_assum env sigma name typ = str "*** [" ++ str name ++ str " : " ++ pr_ltype_env env sigma typ ++ str "]" @@ -536,9 +564,7 @@ let gallina_print_inductive sp udecl = pr_mutual_inductive_body env sp mib udecl ++ with_line_skip (print_primitive_record mib.mind_finite mipv mib.mind_record @ - print_inductive_renames sp mipv @ - print_inductive_implicit_args sp mipv @ - print_inductive_argument_scopes sp mipv) + print_inductive_args sp mipv) let print_named_decl env sigma id = gallina_print_named_decl env sigma (Global.lookup_named id) ++ fnl () @@ -561,9 +587,9 @@ let print_instance sigma cb = pr_universe_instance sigma inst else mt() -let print_constant indirect_accessor with_values sep sp udecl = +let print_constant with_values sep sp udecl = let cb = Global.lookup_constant sp in - let val_0 = Global.body_of_constant_body indirect_accessor cb in + let val_0 = Global.body_of_constant_body Library.indirect_accessor cb in let typ = cb.const_type in let univs = let open Univ in @@ -571,7 +597,7 @@ let print_constant indirect_accessor with_values sep sp udecl = match cb.const_body with | Undef _ | Def _ | Primitive _ -> cb.const_universes | OpaqueDef o -> - let body_uctxs = Opaqueproof.force_constraints indirect_accessor otab o in + let body_uctxs = Opaqueproof.force_constraints Library.indirect_accessor otab o in match cb.const_universes with | Monomorphic ctx -> Monomorphic (ContextSet.union body_uctxs ctx) @@ -588,21 +614,21 @@ let print_constant indirect_accessor with_values sep sp udecl = hov 0 ( match val_0 with | None -> - str"*** [ " ++ - print_basename sp ++ print_instance sigma cb ++ str " : " ++ cut () ++ pr_ltype typ ++ - str" ]" ++ + str"*** [ " ++ + print_basename sp ++ print_instance sigma cb ++ str " : " ++ cut () ++ pr_ltype typ ++ + str" ]" ++ Printer.pr_universes sigma univs | Some (c, priv, ctx) -> let priv = match priv with | Opaqueproof.PrivateMonomorphic () -> None | Opaqueproof.PrivatePolymorphic (_, ctx) -> Some ctx in - print_basename sp ++ print_instance sigma cb ++ str sep ++ cut () ++ - (if with_values then print_typed_body env sigma (Some c,typ) else pr_ltype typ)++ + print_basename sp ++ print_instance sigma cb ++ str sep ++ cut () ++ + (if with_values then print_typed_body env sigma (Some c,typ) else pr_ltype typ)++ Printer.pr_universes sigma univs ?priv) -let gallina_print_constant_with_infos indirect_accessor sp udecl = - print_constant indirect_accessor true " = " sp udecl ++ +let gallina_print_constant_with_infos sp udecl = + print_constant true " = " sp udecl ++ with_line_skip (print_name_infos (GlobRef.ConstRef sp)) let gallina_print_syntactic_def env kn = @@ -618,38 +644,38 @@ let gallina_print_syntactic_def env kn = Constrextern.without_specific_symbols [Notation.SynDefRule kn] (pr_glob_constr_env env) c) -let gallina_print_leaf_entry ~mod_ops indirect_accessor env sigma with_values ((sp,kn as oname),lobj) = +let gallina_print_leaf_entry env sigma with_values ((sp,kn as oname),lobj) = let sep = if with_values then " = " else " : " in match lobj with | AtomicObject o -> let tag = object_tag o in begin match (oname,tag) with | (_,"VARIABLE") -> - (* Outside sections, VARIABLES still exist but only with universes + (* Outside sections, VARIABLES still exist but only with universes constraints *) (try Some(print_named_decl env sigma (basename sp)) with Not_found -> None) | (_,"CONSTANT") -> - Some (print_constant indirect_accessor with_values sep (Constant.make1 kn) None) + Some (print_constant with_values sep (Constant.make1 kn) None) | (_,"INDUCTIVE") -> Some (gallina_print_inductive (MutInd.make1 kn) None) | (_,("AUTOHINT"|"GRAMMAR"|"SYNTAXCONSTANT"|"PPSYNTAX"|"TOKEN"|"CLASS"| - "COERCION"|"REQUIRE"|"END-SECTION"|"STRUCTURE")) -> None + "COERCION"|"REQUIRE"|"END-SECTION"|"STRUCTURE")) -> None (* To deal with forgotten cases... *) | (_,s) -> None end | ModuleObject _ -> let (mp,l) = KerName.repr kn in - Some (print_module ~mod_ops with_values (MPdot (mp,l))) + Some (print_module with_values ~mod_ops:Declaremods.mod_ops (MPdot (mp,l))) | ModuleTypeObject _ -> let (mp,l) = KerName.repr kn in - Some (print_modtype ~mod_ops (MPdot (mp,l))) + Some (print_modtype ~mod_ops:Declaremods.mod_ops (MPdot (mp,l))) | _ -> None -let gallina_print_library_entry ~mod_ops indirect_accessor env sigma with_values ent = +let gallina_print_library_entry env sigma with_values ent = let pr_name (sp,_) = Id.print (basename sp) in match ent with | (oname,Lib.Leaf lobj) -> - gallina_print_leaf_entry ~mod_ops indirect_accessor env sigma with_values (oname,lobj) + gallina_print_leaf_entry env sigma with_values (oname,lobj) | (oname,Lib.OpenedSection (dir,_)) -> Some (str " >>>>>>> Section " ++ pr_name oname) | (_,Lib.CompilingLibrary { Nametab.obj_dir; _ }) -> @@ -657,10 +683,10 @@ let gallina_print_library_entry ~mod_ops indirect_accessor env sigma with_values | (oname,Lib.OpenedModule _) -> Some (str " >>>>>>> Module " ++ pr_name oname) -let gallina_print_context ~mod_ops indirect_accessor env sigma with_values = +let gallina_print_context env sigma with_values = let rec prec n = function | h::rest when Option.is_empty n || Option.get n > 0 -> - (match gallina_print_library_entry ~mod_ops indirect_accessor env sigma with_values h with + (match gallina_print_library_entry env sigma with_values h with | None -> prec n rest | Some pp -> prec (Option.map ((+) (-1)) n) rest ++ pp ++ fnl ()) | _ -> mt () @@ -698,8 +724,8 @@ let print_syntactic_def x = !object_pr.print_syntactic_def x let print_module x = !object_pr.print_module x let print_modtype x = !object_pr.print_modtype x let print_named_decl x = !object_pr.print_named_decl x -let print_library_entry ~mod_ops x = !object_pr.print_library_entry ~mod_ops x -let print_context ~mod_ops x = !object_pr.print_context ~mod_ops x +let print_library_entry x = !object_pr.print_library_entry x +let print_context x = !object_pr.print_context x let print_typed_value_in_env x = !object_pr.print_typed_value_in_env x let print_eval x = !object_pr.print_eval x @@ -720,30 +746,32 @@ let print_safe_judgment env sigma j = (*********************) (* *) -let print_full_context ~mod_ops indirect_accessor env sigma = - print_context ~mod_ops indirect_accessor env sigma true None (Lib.contents ()) -let print_full_context_typ ~mod_ops indirect_accessor env sigma = - print_context ~mod_ops indirect_accessor env sigma false None (Lib.contents ()) +let print_full_context env sigma = + print_context env sigma true None (Lib.contents ()) +let print_full_context_typ env sigma = + print_context env sigma false None (Lib.contents ()) -let print_full_pure_context ~mod_ops ~library_accessor env sigma = +let print_full_pure_context env sigma = let rec prec = function | ((_,kn),Lib.Leaf AtomicObject lobj)::rest -> let pp = match object_tag lobj with | "CONSTANT" -> - let con = Global.constant_of_delta_kn kn in - let cb = Global.lookup_constant con in - let typ = cb.const_type in - hov 0 ( - match cb.const_body with - | Undef _ -> - str "Parameter " ++ + let con = Global.constant_of_delta_kn kn in + let cb = Global.lookup_constant con in + let typ = cb.const_type in + hov 0 ( + match cb.const_body with + | Undef _ -> + str "Parameter " ++ print_basename con ++ str " : " ++ cut () ++ pr_ltype_env env sigma typ - | OpaqueDef lc -> - str "Theorem " ++ print_basename con ++ cut () ++ + | OpaqueDef lc -> + str "Theorem " ++ print_basename con ++ cut () ++ str " : " ++ pr_ltype_env env sigma typ ++ str "." ++ fnl () ++ - str "Proof " ++ pr_lconstr_env env sigma (fst (Opaqueproof.force_proof library_accessor (Global.opaque_tables ()) lc)) + str "Proof " ++ pr_lconstr_env env sigma + (fst (Opaqueproof.force_proof Library.indirect_accessor + (Global.opaque_tables ()) lc)) | Def c -> - str "Definition " ++ print_basename con ++ cut () ++ + str "Definition " ++ print_basename con ++ cut () ++ str " : " ++ pr_ltype_env env sigma typ ++ cut () ++ str " := " ++ pr_lconstr_env env sigma (Mod_subst.force_constr c) | Primitive _ -> @@ -751,20 +779,20 @@ let print_full_pure_context ~mod_ops ~library_accessor env sigma = print_basename con ++ str " : " ++ cut () ++ pr_ltype_env env sigma typ) ++ str "." ++ fnl () ++ fnl () | "INDUCTIVE" -> - let mind = Global.mind_of_delta_kn kn in - let mib = Global.lookup_mind mind in + let mind = Global.mind_of_delta_kn kn in + let mib = Global.lookup_mind mind in pr_mutual_inductive_body (Global.env()) mind mib None ++ - str "." ++ fnl () ++ fnl () + str "." ++ fnl () ++ fnl () | _ -> mt () in prec rest ++ pp | ((_,kn),Lib.Leaf ModuleObject _)::rest -> (* TODO: make it reparsable *) let (mp,l) = KerName.repr kn in - prec rest ++ print_module ~mod_ops true (MPdot (mp,l)) ++ str "." ++ fnl () ++ fnl () + prec rest ++ print_module true (MPdot (mp,l)) ++ str "." ++ fnl () ++ fnl () | ((_,kn),Lib.Leaf ModuleTypeObject _)::rest -> (* TODO: make it reparsable *) let (mp,l) = KerName.repr kn in - prec rest ++ print_modtype ~mod_ops (MPdot (mp,l)) ++ str "." ++ fnl () ++ fnl () + prec rest ++ print_modtype (MPdot (mp,l)) ++ str "." ++ fnl () ++ fnl () | _::rest -> prec rest | _ -> mt () in prec (Lib.contents ()) @@ -789,11 +817,11 @@ let read_sec_context qid = let cxt = Lib.contents () in List.rev (get_cxt [] cxt) -let print_sec_context ~mod_ops indirect_accessor env sigma sec = - print_context ~mod_ops indirect_accessor env sigma true None (read_sec_context sec) +let print_sec_context env sigma sec = + print_context env sigma true None (read_sec_context sec) -let print_sec_context_typ ~mod_ops indirect_accessor env sigma sec = - print_context ~mod_ops indirect_accessor env sigma false None (read_sec_context sec) +let print_sec_context_typ env sigma sec = + print_context env sigma false None (read_sec_context sec) let maybe_error_reject_univ_decl na udecl = let open GlobRef in @@ -803,19 +831,19 @@ let maybe_error_reject_univ_decl na udecl = (* TODO Print na somehow *) user_err ~hdr:"reject_univ_decl" (str "This object does not support universe names.") -let print_any_name ~mod_ops indirect_accessor env sigma na udecl = +let print_any_name env sigma na udecl = maybe_error_reject_univ_decl na udecl; let open GlobRef in match na with - | Term (ConstRef sp) -> print_constant_with_infos indirect_accessor sp udecl + | Term (ConstRef sp) -> print_constant_with_infos sp udecl | Term (IndRef (sp,_)) -> print_inductive sp udecl | Term (ConstructRef ((sp,_),_)) -> print_inductive sp udecl | Term (VarRef sp) -> print_section_variable env sigma sp | Syntactic kn -> print_syntactic_def env kn | Dir (Nametab.GlobDirRef.DirModule Nametab.{ obj_dir; obj_mp; _ } ) -> - print_module ~mod_ops (printable_body obj_dir) obj_mp + print_module (printable_body obj_dir) obj_mp | Dir _ -> mt () - | ModuleType mp -> print_modtype ~mod_ops mp + | ModuleType mp -> print_modtype mp | Other (obj, info) -> info.print obj | Undefined qid -> try (* Var locale de but, pas var de section... donc pas d'implicits *) @@ -827,23 +855,23 @@ let print_any_name ~mod_ops indirect_accessor env sigma na udecl = user_err ~hdr:"print_name" (pr_qualid qid ++ spc () ++ str "not a defined object.") -let print_name ~mod_ops indirect_accessor env sigma na udecl = +let print_name env sigma na udecl = match na with | {loc; v=Constrexpr.ByNotation (ntn,sc)} -> - print_any_name ~mod_ops indirect_accessor env sigma + print_any_name env sigma (Term (Notation.interp_notation_as_global_reference ?loc (fun _ -> true) ntn sc)) udecl | {loc; v=Constrexpr.AN ref} -> - print_any_name ~mod_ops indirect_accessor env sigma (locate_any_name ref) udecl + print_any_name env sigma (locate_any_name ref) udecl -let print_opaque_name indirect_accessor env sigma qid = +let print_opaque_name env sigma qid = let open GlobRef in match Nametab.global qid with | ConstRef cst -> let cb = Global.lookup_constant cst in if Declareops.constant_has_body cb then - print_constant_with_infos indirect_accessor cst None + print_constant_with_infos cst None else user_err Pp.(str "Not a defined constant.") | IndRef (sp,_) -> @@ -865,9 +893,9 @@ let print_about_any ?loc env sigma k udecl = pr_infos_list (print_ref false ref udecl :: blankline :: print_polymorphism ref @ - print_name_infos ref @ - (if Pp.ismt rb then [] else [rb]) @ - print_opacity ref @ + print_name_infos ref @ + (if Pp.ismt rb then [] else [rb]) @ + print_opacity ref @ print_bidi_hints ref @ [hov 0 (str "Expands to: " ++ pr_located_qualid k)]) | Syntactic kn -> @@ -891,8 +919,8 @@ let print_about env sigma na udecl = print_about_any ?loc env sigma (locate_any_name ref) udecl (* for debug *) -let inspect ~mod_ops indirect_accessor env sigma depth = - print_context ~mod_ops indirect_accessor env sigma false (Some depth) (Lib.contents ()) +let inspect env sigma depth = + print_context env sigma false (Some depth) (Lib.contents ()) (*************************************************************************) (* Pretty-printing functions coming from classops.ml *) @@ -938,7 +966,7 @@ let print_path_between cls clt = with Not_found -> user_err ~hdr:"index_cl_of_id" (str"No path between " ++ pr_class cls ++ str" and " ++ pr_class clt - ++ str ".") + ++ str ".") in print_path ((i,j),p) diff --git a/printing/prettyp.mli b/vernac/prettyp.mli index c8b361d95b..dc4280f286 100644 --- a/printing/prettyp.mli +++ b/vernac/prettyp.mli @@ -19,48 +19,31 @@ val assumptions_for_print : Name.t list -> Termops.names_context val print_closed_sections : bool ref val print_context - : mod_ops:Printmod.mod_ops - -> Opaqueproof.indirect_accessor - -> env -> Evd.evar_map + : env + -> Evd.evar_map -> bool -> int option -> Lib.library_segment -> Pp.t val print_library_entry - : mod_ops:Printmod.mod_ops - -> Opaqueproof.indirect_accessor - -> env -> Evd.evar_map - -> bool -> (Libobject.object_name * Lib.node) -> Pp.t option -val print_full_context - : mod_ops:Printmod.mod_ops - -> Opaqueproof.indirect_accessor -> env -> Evd.evar_map -> Pp.t -val print_full_context_typ - : mod_ops:Printmod.mod_ops - -> Opaqueproof.indirect_accessor -> env -> Evd.evar_map -> Pp.t - -val print_full_pure_context - : mod_ops:Printmod.mod_ops - -> library_accessor:Opaqueproof.indirect_accessor - -> env + : env -> Evd.evar_map - -> Pp.t + -> bool -> (Libobject.object_name * Lib.node) -> Pp.t option +val print_full_context : env -> Evd.evar_map -> Pp.t +val print_full_context_typ : env -> Evd.evar_map -> Pp.t + +val print_full_pure_context : env -> Evd.evar_map -> Pp.t -val print_sec_context - : mod_ops:Printmod.mod_ops - -> Opaqueproof.indirect_accessor -> env -> Evd.evar_map -> qualid -> Pp.t -val print_sec_context_typ - : mod_ops:Printmod.mod_ops - -> Opaqueproof.indirect_accessor -> env -> Evd.evar_map -> qualid -> Pp.t +val print_sec_context : env -> Evd.evar_map -> qualid -> Pp.t +val print_sec_context_typ : env -> Evd.evar_map -> qualid -> Pp.t val print_judgment : env -> Evd.evar_map -> EConstr.unsafe_judgment -> Pp.t val print_safe_judgment : env -> Evd.evar_map -> Safe_typing.judgment -> Pp.t val print_eval : reduction_function -> env -> Evd.evar_map -> Constrexpr.constr_expr -> EConstr.unsafe_judgment -> Pp.t -val print_name - : mod_ops:Printmod.mod_ops - -> Opaqueproof.indirect_accessor - -> env -> Evd.evar_map -> qualid Constrexpr.or_by_notation - -> UnivNames.univ_name_list option -> Pp.t -val print_opaque_name - : Opaqueproof.indirect_accessor -> env -> Evd.evar_map -> qualid -> Pp.t +val print_name : env -> Evd.evar_map + -> qualid Constrexpr.or_by_notation + -> UnivNames.univ_name_list option + -> Pp.t +val print_opaque_name : env -> Evd.evar_map -> qualid -> Pp.t val print_about : env -> Evd.evar_map -> qualid Constrexpr.or_by_notation -> UnivNames.univ_name_list option -> Pp.t val print_impargs : qualid Constrexpr.or_by_notation -> Pp.t @@ -77,10 +60,7 @@ val print_typeclasses : unit -> Pp.t val print_instances : GlobRef.t -> Pp.t val print_all_instances : unit -> Pp.t -val inspect - : mod_ops:Printmod.mod_ops - -> Opaqueproof.indirect_accessor - -> env -> Evd.evar_map -> int -> Pp.t +val inspect : env -> Evd.evar_map -> int -> Pp.t (** {5 Locate} *) @@ -113,14 +93,14 @@ val print_located_other : string -> qualid -> Pp.t type object_pr = { print_inductive : MutInd.t -> UnivNames.univ_name_list option -> Pp.t; - print_constant_with_infos : Opaqueproof.indirect_accessor -> Constant.t -> UnivNames.univ_name_list option -> Pp.t; + print_constant_with_infos : Constant.t -> UnivNames.univ_name_list option -> Pp.t; print_section_variable : env -> Evd.evar_map -> variable -> Pp.t; print_syntactic_def : env -> KerName.t -> Pp.t; - print_module : mod_ops:Printmod.mod_ops -> bool -> ModPath.t -> Pp.t; - print_modtype : mod_ops:Printmod.mod_ops -> ModPath.t -> Pp.t; + print_module : bool -> ModPath.t -> Pp.t; + print_modtype : ModPath.t -> Pp.t; print_named_decl : env -> Evd.evar_map -> Constr.named_declaration -> Pp.t; - print_library_entry : mod_ops:Printmod.mod_ops -> Opaqueproof.indirect_accessor -> env -> Evd.evar_map -> bool -> (Libobject.object_name * Lib.node) -> Pp.t option; - print_context : mod_ops:Printmod.mod_ops -> Opaqueproof.indirect_accessor -> env -> Evd.evar_map -> bool -> int option -> Lib.library_segment -> Pp.t; + print_library_entry : env -> Evd.evar_map -> bool -> (Libobject.object_name * Lib.node) -> Pp.t option; + print_context : env -> Evd.evar_map -> bool -> int option -> Lib.library_segment -> Pp.t; print_typed_value_in_env : Environ.env -> Evd.evar_map -> EConstr.constr * EConstr.types -> Pp.t; print_eval : Reductionops.reduction_function -> env -> Evd.evar_map -> Constrexpr.constr_expr -> EConstr.unsafe_judgment -> Pp.t; } diff --git a/vernac/vernac.mllib b/vernac/vernac.mllib index 956b56e256..5226c2ba65 100644 --- a/vernac/vernac.mllib +++ b/vernac/vernac.mllib @@ -19,6 +19,7 @@ DeclareObl Canonical RecLemmas Library +Prettyp Lemmas Class Auto_ind_decl @@ -38,6 +39,7 @@ Assumptions Mltop Topfmt Loadpath +ComArguments Vernacentries Vernacstate Vernacinterp diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 684d8a3d90..6dfba02ae9 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -15,7 +15,6 @@ open CErrors open CAst open Util open Names -open Nameops open Tacmach open Constrintern open Prettyp @@ -176,7 +175,7 @@ let print_module qid = let globdir = Nametab.locate_dir qid in match globdir with DirModule Nametab.{ obj_dir; obj_mp; _ } -> - Printmod.print_module (Printmod.printable_body obj_dir) obj_mp + Printmod.print_module ~mod_ops:Declaremods.mod_ops (Printmod.printable_body obj_dir) obj_mp | _ -> raise Not_found with Not_found -> user_err (str"Unknown Module " ++ pr_qualid qid) @@ -184,12 +183,12 @@ let print_module qid = let print_modtype qid = try let kn = Nametab.locate_modtype qid in - Printmod.print_modtype kn + Printmod.print_modtype ~mod_ops:Declaremods.mod_ops kn with Not_found -> (* Is there a module of this name ? If yes we display its type *) try let mp = Nametab.locate_module qid in - Printmod.print_module false mp + Printmod.print_module ~mod_ops:Declaremods.mod_ops false mp with Not_found -> user_err (str"Unknown Module Type or Module " ++ pr_qualid qid) @@ -407,8 +406,10 @@ let err_notfound_library ?from qid = | Some from -> str " with prefix " ++ DirPath.print from ++ str "." in + let bonus = + if !Flags.load_vos_libraries then " (While searching for a .vos file.)" else "" in user_err ?loc:qid.CAst.loc ~hdr:"locate_library" - (strbrk "Unable to locate library " ++ pr_qualid qid ++ prefix) + (strbrk "Unable to locate library " ++ pr_qualid qid ++ prefix ++ str bonus) let print_located_library qid = let open Loadpath in @@ -448,9 +449,6 @@ let vernac_bind_scope ~module_local sc cll = let vernac_open_close_scope ~section_local (b,s) = Notation.open_close_scope (section_local,b,s) -let vernac_arguments_scope ~section_local r scl = - Notation.declare_arguments_scope section_local (smart_global r) scl - let vernac_infix ~atts = let module_local, deprecation = Attributes.(parse Notations.(module_locality ++ deprecation) atts) in Metasyntax.add_infix ~local:module_local deprecation (Global.env()) @@ -655,7 +653,7 @@ let vernac_record ~template udecl cum k poly finite records = let cumulative = should_treat_as_cumulative cum poly in let map ((coe, id), binders, sort, nameopt, cfs) = let const = match nameopt with - | None -> add_prefix "Build_" id.v + | None -> Nameops.add_prefix "Build_" id.v | Some lid -> let () = Dumpglob.dump_definition lid false "constr" in lid.v @@ -834,7 +832,7 @@ let vernac_scheme l = Option.iter (fun lid -> Dumpglob.dump_definition lid false "def") lid; match s with | InductionScheme (_, r, _) - | CaseScheme (_, r, _) + | CaseScheme (_, r, _) | EqualityScheme r -> dump_global r) l; Indschemes.do_scheme l @@ -1213,292 +1211,6 @@ let vernac_syntactic_definition ~atts lid x compat = Dumpglob.dump_definition lid false "syndef"; Metasyntax.add_syntactic_definition ~local:module_local deprecation (Global.env()) lid.v x compat -let cache_bidi_hints (_name, (gr, ohint)) = - match ohint with - | None -> Pretyping.clear_bidirectionality_hint gr - | Some nargs -> Pretyping.add_bidirectionality_hint gr nargs - -let load_bidi_hints _ r = - cache_bidi_hints r - -let subst_bidi_hints (subst, (gr, ohint as orig)) = - let gr' = subst_global_reference subst gr in - if gr == gr' then orig else (gr', ohint) - -let discharge_bidi_hints (_name, (gr, ohint)) = - if isVarRef gr && Lib.is_in_section gr then None - else - let vars = Lib.variable_section_segment_of_reference gr in - let n = List.length vars in - Some (gr, Option.map ((+) n) ohint) - -let inBidiHints = - let open Libobject in - declare_object { (default_object "BIDIRECTIONALITY-HINTS" ) with - load_function = load_bidi_hints; - cache_function = cache_bidi_hints; - classify_function = (fun o -> Substitute o); - subst_function = subst_bidi_hints; - discharge_function = discharge_bidi_hints; - } - - -let warn_arguments_assert = - CWarnings.create ~name:"arguments-assert" ~category:"vernacular" - (fun sr -> - strbrk "This command is just asserting the names of arguments of " ++ - pr_global sr ++ strbrk". If this is what you want add " ++ - strbrk "': assert' to silence the warning. If you want " ++ - strbrk "to clear implicit arguments add ': clear implicits'. " ++ - strbrk "If you want to clear notation scopes add ': clear scopes'") - -(* [nargs_for_red] is the number of arguments required to trigger reduction, - [args] is the main list of arguments statuses, - [more_implicits] is a list of extra lists of implicit statuses *) -let vernac_arguments ~section_local reference args more_implicits nargs_for_red nargs_before_bidi flags = - let env = Global.env () in - let sigma = Evd.from_env env in - let assert_flag = List.mem `Assert flags in - let rename_flag = List.mem `Rename flags in - let clear_scopes_flag = List.mem `ClearScopes flags in - let extra_scopes_flag = List.mem `ExtraScopes flags in - let clear_implicits_flag = List.mem `ClearImplicits flags in - let default_implicits_flag = List.mem `DefaultImplicits flags in - let never_unfold_flag = List.mem `ReductionNeverUnfold flags in - let nomatch_flag = List.mem `ReductionDontExposeCase flags in - let clear_bidi_hint = List.mem `ClearBidiHint flags in - - let err_incompat x y = - user_err Pp.(str ("Options \""^x^"\" and \""^y^"\" are incompatible.")) in - - if assert_flag && rename_flag then - err_incompat "assert" "rename"; - if clear_scopes_flag && extra_scopes_flag then - err_incompat "clear scopes" "extra scopes"; - if clear_implicits_flag && default_implicits_flag then - err_incompat "clear implicits" "default implicits"; - - let sr = smart_global reference in - let inf_names = - let ty, _ = Typeops.type_of_global_in_context env sr in - Impargs.compute_implicits_names env sigma (EConstr.of_constr ty) - in - let prev_names = - try Arguments_renaming.arguments_names sr with Not_found -> inf_names - in - let num_args = List.length inf_names in - assert (Int.equal num_args (List.length prev_names)); - - let names_of args = List.map (fun a -> a.name) args in - - (* Checks *) - - let err_extra_args names = - user_err ~hdr:"vernac_declare_arguments" - (strbrk "Extra arguments: " ++ - prlist_with_sep pr_comma Name.print names ++ str ".") - in - let err_missing_args names = - user_err ~hdr:"vernac_declare_arguments" - (strbrk "The following arguments are not declared: " ++ - prlist_with_sep pr_comma Name.print names ++ str ".") - in - - let rec check_extra_args extra_args = - match extra_args with - | [] -> () - | { notation_scope = None } :: _ -> - user_err Pp.(str"Extra arguments should specify a scope.") - | { notation_scope = Some _ } :: args -> check_extra_args args - in - - let args, scopes = - let scopes = List.map (fun { notation_scope = s } -> s) args in - if List.length args > num_args then - let args, extra_args = List.chop num_args args in - if extra_scopes_flag then - (check_extra_args extra_args; (args, scopes)) - else err_extra_args (names_of extra_args) - else args, scopes - in - - if Option.cata (fun n -> n > num_args) false nargs_for_red then - user_err Pp.(str "The \"/\" modifier should be put before any extra scope."); - - if Option.cata (fun n -> n > num_args) false nargs_before_bidi then - user_err Pp.(str "The \"&\" modifier should be put before any extra scope."); - - let scopes_specified = List.exists Option.has_some scopes in - - if scopes_specified && clear_scopes_flag then - user_err Pp.(str "The \"clear scopes\" flag is incompatible with scope annotations."); - - let names = List.map (fun { name } -> name) args in - let names = names :: List.map (List.map fst) more_implicits in - - let rename_flag_required = ref false in - let example_renaming = ref None in - let save_example_renaming renaming = - rename_flag_required := !rename_flag_required - || not (Name.equal (fst renaming) Anonymous); - if Option.is_empty !example_renaming then - example_renaming := Some renaming - in - - let rec names_union names1 names2 = - match names1, names2 with - | [], [] -> [] - | _ :: _, [] -> names1 - | [], _ :: _ -> names2 - | (Name _ as name) :: names1, Anonymous :: names2 - | Anonymous :: names1, (Name _ as name) :: names2 -> - name :: names_union names1 names2 - | name1 :: names1, name2 :: names2 -> - if Name.equal name1 name2 then - name1 :: names_union names1 names2 - else user_err Pp.(str "Argument lists should agree on the names they provide.") - in - - let names = List.fold_left names_union [] names in - - let rec rename prev_names names = - match prev_names, names with - | [], [] -> [] - | [], _ :: _ -> err_extra_args names - | _ :: _, [] when assert_flag -> - (* Error messages are expressed in terms of original names, not - renamed ones. *) - err_missing_args (List.lastn (List.length prev_names) inf_names) - | _ :: _, [] -> prev_names - | prev :: prev_names, Anonymous :: names -> - prev :: rename prev_names names - | prev :: prev_names, (Name id as name) :: names -> - if not (Name.equal prev name) then save_example_renaming (prev,name); - name :: rename prev_names names - in - - let names = rename prev_names names in - let renaming_specified = Option.has_some !example_renaming in - - if !rename_flag_required && not rename_flag then begin - let msg = - match !example_renaming with - | None -> - strbrk "To rename arguments the \"rename\" flag must be specified." - | Some (o,n) -> - strbrk "Flag \"rename\" expected to rename " ++ Name.print o ++ - strbrk " into " ++ Name.print n ++ str "." - in user_err ~hdr:"vernac_declare_arguments" msg - end; - - let duplicate_names = - List.duplicates Name.equal (List.filter ((!=) Anonymous) names) - in - if not (List.is_empty duplicate_names) then begin - let duplicates = prlist_with_sep pr_comma Name.print duplicate_names in - user_err (strbrk "Some argument names are duplicated: " ++ duplicates) - end; - - let implicits = - List.map (fun { name; implicit_status = i } -> (name,i)) args - in - let implicits = implicits :: more_implicits in - - let implicits = List.map (List.map snd) implicits in - let implicits_specified = match implicits with - | [l] -> List.exists (function Impargs.NotImplicit -> false | _ -> true) l - | _ -> true in - - if implicits_specified && clear_implicits_flag then - user_err Pp.(str "The \"clear implicits\" flag is incompatible with implicit annotations"); - - if implicits_specified && default_implicits_flag then - user_err Pp.(str "The \"default implicits\" flag is incompatible with implicit annotations"); - - let rargs = - Util.List.map_filter (function (n, true) -> Some n | _ -> None) - (Util.List.map_i (fun i { recarg_like = b } -> i, b) 0 args) - in - - let red_behavior = - let open Reductionops.ReductionBehaviour in - match never_unfold_flag, nomatch_flag, rargs, nargs_for_red with - | true, false, [], None -> Some NeverUnfold - | true, true, _, _ -> err_incompat "simpl never" "simpl nomatch" - | true, _, _::_, _ -> err_incompat "simpl never" "!" - | true, _, _, Some _ -> err_incompat "simpl never" "/" - | false, false, [], None -> None - | false, false, _, _ -> Some (UnfoldWhen { nargs = nargs_for_red; - recargs = rargs; - }) - | false, true, _, _ -> Some (UnfoldWhenNoMatch { nargs = nargs_for_red; - recargs = rargs; - }) - in - - - let red_modifiers_specified = Option.has_some red_behavior in - - let bidi_hint_specified = Option.has_some nargs_before_bidi in - - if bidi_hint_specified && clear_bidi_hint then - err_incompat "clear bidirectionality hint" "&"; - - - (* Actions *) - - if renaming_specified then begin - Arguments_renaming.rename_arguments section_local sr names - end; - - if scopes_specified || clear_scopes_flag then begin - let scopes = List.map (Option.map (fun {loc;v=k} -> - try ignore (Notation.find_scope k); k - with UserError _ -> - Notation.find_delimiters_scope ?loc k)) scopes - in - vernac_arguments_scope ~section_local reference scopes - end; - - if implicits_specified || clear_implicits_flag then - Impargs.set_implicits section_local (smart_global reference) implicits; - - if default_implicits_flag then - Impargs.declare_implicits section_local (smart_global reference); - - if red_modifiers_specified then begin - match sr with - | GlobRef.ConstRef _ as c -> - Reductionops.ReductionBehaviour.set - ~local:section_local c (Option.get red_behavior) - - | _ -> user_err - (strbrk "Modifiers of the behavior of the simpl tactic "++ - strbrk "are relevant for constants only.") - end; - - if bidi_hint_specified then begin - let n = Option.get nargs_before_bidi in - if section_local then - Pretyping.add_bidirectionality_hint sr n - else - Lib.add_anonymous_leaf (inBidiHints (sr, Some n)) - end; - - if clear_bidi_hint then begin - if section_local then - Pretyping.clear_bidirectionality_hint sr - else - Lib.add_anonymous_leaf (inBidiHints (sr, None)) - end; - - if not (renaming_specified || - implicits_specified || - scopes_specified || - red_modifiers_specified || - bidi_hint_specified) && (List.is_empty flags) then - warn_arguments_assert sr - let default_env () = { Notation_term.ninterp_var_type = Id.Map.empty; ninterp_rec_vars = Id.Map.empty; @@ -1962,29 +1674,26 @@ let print_about_hyp_globs ~pstate ?loc ref_or_by_not udecl glopt = print_about env sigma ref_or_by_not udecl let vernac_print ~pstate ~atts = - let mod_ops = { Printmod.import_module = Declaremods.import_module - ; process_module_binding = Declaremods.process_module_binding - } in let sigma, env = get_current_or_global_context ~pstate in function | PrintTypingFlags -> pr_typing_flags (Environ.typing_flags (Global.env ())) | PrintTables -> print_tables () - | PrintFullContext-> print_full_context_typ ~mod_ops Library.indirect_accessor env sigma - | PrintSectionContext qid -> print_sec_context_typ ~mod_ops Library.indirect_accessor env sigma qid - | PrintInspect n -> inspect ~mod_ops Library.indirect_accessor env sigma n + | PrintFullContext-> print_full_context_typ env sigma + | PrintSectionContext qid -> print_sec_context_typ env sigma qid + | PrintInspect n -> inspect env sigma n | PrintGrammar ent -> Metasyntax.pr_grammar ent | PrintCustomGrammar ent -> Metasyntax.pr_custom_grammar ent | PrintLoadPath dir -> (* For compatibility ? *) print_loadpath dir | PrintModules -> print_modules () - | PrintModule qid -> print_module ~mod_ops qid - | PrintModuleType qid -> print_modtype ~mod_ops qid + | PrintModule qid -> print_module qid + | PrintModuleType qid -> print_modtype qid | PrintNamespace ns -> print_namespace ~pstate ns | PrintMLLoadPath -> Mltop.print_ml_path () | PrintMLModules -> Mltop.print_ml_modules () | PrintDebugGC -> Mltop.print_gc () | PrintName (qid,udecl) -> dump_global qid; - print_name ~mod_ops Library.indirect_accessor env sigma qid udecl + print_name env sigma qid udecl | PrintGraph -> Prettyp.print_graph () | PrintClasses -> Prettyp.print_classes() | PrintTypeClasses -> Prettyp.print_typeclasses() @@ -2135,11 +1844,13 @@ let vernac_register qid r = if DirPath.equal (dirpath_of_string "kernel") ns then begin if Global.sections_are_opened () then user_err Pp.(str "Registering a kernel type is not allowed in sections"); - let pind = match Id.to_string id with - | "ind_bool" -> CPrimitives.PIT_bool - | "ind_carry" -> CPrimitives.PIT_carry - | "ind_pair" -> CPrimitives.PIT_pair - | "ind_cmp" -> CPrimitives.PIT_cmp + let CPrimitives.PIE pind = match Id.to_string id with + | "ind_bool" -> CPrimitives.(PIE PIT_bool) + | "ind_carry" -> CPrimitives.(PIE PIT_carry) + | "ind_pair" -> CPrimitives.(PIE PIT_pair) + | "ind_cmp" -> CPrimitives.(PIE PIT_cmp) + | "ind_f_cmp" -> CPrimitives.(PIE PIT_f_cmp) + | "ind_f_class" -> CPrimitives.(PIE PIT_f_class) | k -> CErrors.user_err Pp.(str "Register: unknown identifier “" ++ str k ++ str "” in the “kernel” namespace") in match gr with @@ -2453,7 +2164,8 @@ let translate_vernac ~atts v = let open Vernacextend in match v with VtDefault(fun () -> vernac_syntactic_definition ~atts id c b) | VernacArguments (qid, args, more_implicits, nargs, bidi, flags) -> VtDefault(fun () -> - with_section_locality ~atts (vernac_arguments qid args more_implicits nargs bidi flags)) + with_section_locality ~atts + (ComArguments.vernac_arguments qid args more_implicits nargs bidi flags)) | VernacReserve bl -> VtDefault(fun () -> unsupported_attributes atts; diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index b712d7e264..564c55670d 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -257,6 +257,17 @@ type vernac_argument_status = { implicit_status : Impargs.implicit_kind; } +type arguments_modifier = + [ `Assert + | `ClearBidiHint + | `ClearImplicits + | `ClearScopes + | `DefaultImplicits + | `ExtraScopes + | `ReductionDontExposeCase + | `ReductionNeverUnfold + | `Rename ] + type extend_name = (* Name of the vernac entry where the tactic is defined, typically found after the VERNAC EXTEND statement in the source. *) @@ -365,16 +376,16 @@ type nonrec vernac_expr = | VernacCreateHintDb of string * bool | VernacRemoveHints of string list * qualid list | VernacHints of string list * Hints.hints_expr - | VernacSyntacticDefinition of lident * (Id.t list * constr_expr) * + | VernacSyntacticDefinition of + lident * (Id.t list * constr_expr) * onlyparsing_flag - | VernacArguments of qualid or_by_notation * + | VernacArguments of + qualid or_by_notation * vernac_argument_status list (* Main arguments status list *) * - (Name.t * Impargs.implicit_kind) list list (* Extra implicit status lists *) * + (Name.t * Impargs.implicit_kind) list list (* Extra implicit status lists *) * int option (* Number of args to trigger reduction *) * int option (* Number of args before bidirectional typing *) * - [ `ReductionDontExposeCase | `ReductionNeverUnfold | `Rename | - `ExtraScopes | `Assert | `ClearImplicits | `ClearScopes | `ClearBidiHint | - `DefaultImplicits ] list + arguments_modifier list | VernacReserve of simple_binder list | VernacGeneralizable of (lident list) option | VernacSetOpacity of (Conv_oracle.level * qualid or_by_notation list) |