diff options
| -rw-r--r-- | coqpp/coqpp_main.ml | 6 | ||||
| -rwxr-xr-x | dev/ci/ci-hott.sh | 2 | ||||
| -rw-r--r-- | dev/ci/user-overlays/07859-printers.sh | 6 | ||||
| -rw-r--r-- | interp/constrintern.ml | 6 | ||||
| -rw-r--r-- | kernel/nativeconv.ml | 22 | ||||
| -rw-r--r-- | kernel/nativelib.ml | 1 | ||||
| -rw-r--r-- | pretyping/cases.ml | 6 | ||||
| -rw-r--r-- | printing/prettyp.ml | 6 | ||||
| -rw-r--r-- | printing/printer.ml | 16 | ||||
| -rw-r--r-- | printing/printer.mli | 8 | ||||
| -rw-r--r-- | printing/printmod.ml | 4 | ||||
| -rw-r--r-- | test-suite/bugs/closed/2733.v | 15 | ||||
| -rw-r--r-- | test-suite/bugs/closed/8126.v | 13 | ||||
| -rw-r--r-- | test-suite/output/Notations3.out | 6 | ||||
| -rw-r--r-- | test-suite/output/Notations3.v | 11 | ||||
| -rw-r--r-- | vernac/himsg.ml | 8 |
16 files changed, 94 insertions, 42 deletions
diff --git a/coqpp/coqpp_main.ml b/coqpp/coqpp_main.ml index e76a1e9ed8..fd425ef4ff 100644 --- a/coqpp/coqpp_main.ml +++ b/coqpp/coqpp_main.ml @@ -326,10 +326,14 @@ let print_ast fmt ext = end +let declare_plugin fmt name = + fprintf fmt "let %s = \"%s\"@\n" plugin_name name; + fprintf fmt "let _ = Mltop.add_known_module %s@\n" plugin_name + let pr_ast fmt = function | Code s -> fprintf fmt "%s@\n" s.code | Comment s -> fprintf fmt "%s@\n" s -| DeclarePlugin name -> fprintf fmt "let %s = \"%s\"@\n" plugin_name name +| DeclarePlugin name -> declare_plugin fmt name | GramExt gram -> fprintf fmt "%a@\n" GramExt.print_ast gram | VernacExt -> fprintf fmt "VERNACEXT@\n" | TacticExt tac -> fprintf fmt "%a@\n" TacticExt.print_ast tac diff --git a/dev/ci/ci-hott.sh b/dev/ci/ci-hott.sh index 6ded97984e..184b90a50b 100755 --- a/dev/ci/ci-hott.sh +++ b/dev/ci/ci-hott.sh @@ -7,4 +7,4 @@ HoTT_CI_DIR="${CI_BUILD_DIR}"/HoTT git_checkout "${HoTT_CI_BRANCH}" "${HoTT_CI_GITURL}" "${HoTT_CI_DIR}" -( cd "${HoTT_CI_DIR}" && ./autogen.sh && ./configure && make ) +( cd "${HoTT_CI_DIR}" && ./autogen.sh && ./configure && make && make validate ) diff --git a/dev/ci/user-overlays/07859-printers.sh b/dev/ci/user-overlays/07859-printers.sh new file mode 100644 index 0000000000..27f588e214 --- /dev/null +++ b/dev/ci/user-overlays/07859-printers.sh @@ -0,0 +1,6 @@ +#!/bin/sh + +if [ "$CI_PULL_REQUEST" = "7859" ] || [ "$CI_BRANCH" = "rm-univ-broken-printing" ]; then + Equations_CI_BRANCH=fix-printers + Equations_CI_GITURL=https://github.com/SkySkimmer/Coq-Equations +fi diff --git a/interp/constrintern.ml b/interp/constrintern.ml index c87768b190..715823e5d0 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -1891,9 +1891,9 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = intern_applied_reference intern env (Environ.named_context globalenv) lvar us args ref in - (* Rem: GApp(_,f,[]) stands for @f *) - DAst.make ?loc @@ - GApp (f, intern_args env args_scopes (List.map fst args)) + (* Rem: GApp(_,f,[]) stands for @f *) + if args = [] then DAst.make ?loc @@ GApp (f,[]) else + smart_gapp f loc (intern_args env args_scopes (List.map fst args)) | CApp ((isproj,f), args) -> let f,args = match f.CAst.v with diff --git a/kernel/nativeconv.ml b/kernel/nativeconv.ml index e97dbd0d67..931b8bbc86 100644 --- a/kernel/nativeconv.ml +++ b/kernel/nativeconv.ml @@ -135,7 +135,18 @@ and conv_fix env lvl t1 f1 t2 f2 cu = else aux (i+1) (conv_val env CONV flvl fi1 fi2 cu) in aux 0 cu +let warn_no_native_compiler = + let open Pp in + CWarnings.create ~name:"native-compiler-disabled" ~category:"native-compiler" + (fun () -> strbrk "Native compiler is disabled," ++ + strbrk " falling back to VM conversion test.") + let native_conv_gen pb sigma env univs t1 t2 = + if not Coq_config.native_compiler then begin + warn_no_native_compiler (); + Vconv.vm_conv_gen pb env univs t1 t2 + end + else let ml_filename, prefix = get_ml_filename () in let code, upds = mk_conv_code env sigma prefix t1 t2 in match compile ml_filename code ~profile:false with @@ -152,19 +163,8 @@ let native_conv_gen pb sigma env univs t1 t2 = end | _ -> anomaly (Pp.str "Compilation failure.") -let warn_no_native_compiler = - let open Pp in - CWarnings.create ~name:"native-compiler-disabled" ~category:"native-compiler" - (fun () -> strbrk "Native compiler is disabled," ++ - strbrk " falling back to VM conversion test.") - (* Wrapper for [native_conv] above *) let native_conv cv_pb sigma env t1 t2 = - if not Coq_config.native_compiler then begin - warn_no_native_compiler (); - Vconv.vm_conv cv_pb env t1 t2 - end - else let univs = Environ.universes env in let b = if cv_pb = CUMUL then Constr.leq_constr_univs univs t1 t2 diff --git a/kernel/nativelib.ml b/kernel/nativelib.ml index 31ad364911..f784509b6f 100644 --- a/kernel/nativelib.ml +++ b/kernel/nativelib.ml @@ -67,6 +67,7 @@ let warn_native_compiler_failed = CWarnings.create ~name:"native-compiler-failed" ~category:"native-compiler" print let call_compiler ?profile:(profile=false) ml_filename = + let () = assert Coq_config.native_compiler in let load_path = !get_load_paths () in let load_path = List.map (fun dn -> dn / output_dir) load_path in let include_dirs = List.flatten (List.map (fun x -> ["-I"; x]) (include_dirs () @ load_path)) in diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 6a63fb02f8..ad33297f0a 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -373,6 +373,11 @@ let ltac_interp_realnames lvar = function | t, IsInd (ty,ind,realnal) -> t, IsInd (ty,ind,List.map (ltac_interp_name lvar) realnal) | _ as x -> x +let is_patvar pat = + match DAst.get pat with + | PatVar _ -> true + | _ -> false + let coerce_row typing_fun evdref env lvar pats (tomatch,(na,indopt)) = let loc = loc_of_glob_constr tomatch in let tycon,realnames = find_tomatch_tycon evdref env loc indopt in @@ -381,6 +386,7 @@ let coerce_row typing_fun evdref env lvar pats (tomatch,(na,indopt)) = let typ = nf_evar !evdref j.uj_type in lvar := make_return_predicate_ltac_lvar !evdref na tomatch j.uj_val !lvar; let t = + if realnames = None && pats <> [] && List.for_all is_patvar pats then NotInd (None,typ) else try try_find_ind env !evdref typ realnames with Not_found -> unify_tomatch_with_patterns evdref env loc typ pats realnames in diff --git a/printing/prettyp.ml b/printing/prettyp.ml index fd7135b6a6..7258bb9b72 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -98,7 +98,8 @@ let print_ref reduce ref udecl = (Array.to_list (Univ.Instance.to_array inst)) udecl in let sigma = Evd.from_ctx (UState.of_binders bl) in let inst = - if Global.is_polymorphic ref then Printer.pr_universe_instance sigma univs + if Global.is_polymorphic ref + then Printer.pr_universe_instance sigma (Univ.UContext.instance univs) else mt () in hov 0 (pr_global ref ++ inst ++ str " :" ++ spc () ++ pr_letype_env env sigma typ ++ @@ -552,8 +553,7 @@ let print_instance sigma cb = if Declareops.constant_is_polymorphic cb then let univs = Declareops.constant_polymorphic_context cb in let inst = Univ.AUContext.instance univs in - let univs = Univ.UContext.make (inst, Univ.AUContext.instantiate inst univs) in - pr_universe_instance sigma univs + pr_universe_instance sigma inst else mt() let print_constant with_values sep sp udecl = diff --git a/printing/printer.ml b/printing/printer.ml index ba094596ff..a77c1ced56 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -290,11 +290,13 @@ let pr_cumulativity_info sigma cumi = let pr_global_env = pr_global_env let pr_global = pr_global_env Id.Set.empty -let pr_puniverses f env (c,u) = - f env c ++ - (if !Constrextern.print_universes then - str"(*" ++ Univ.Instance.pr UnivNames.pr_with_global_universes u ++ str"*)" - else mt ()) +let pr_universe_instance evd inst = + str"@{" ++ Univ.Instance.pr (Termops.pr_evd_level evd) inst ++ str"}" + +let pr_puniverses f env sigma (c,u) = + if !Constrextern.print_universes + then f env c ++ pr_universe_instance sigma u + else f env c let pr_constant env cst = pr_global_env (Termops.vars_of_env env) (ConstRef cst) let pr_existential_key = Termops.pr_existential_key @@ -1016,10 +1018,6 @@ let pr_polymorphic b = if b then str"Polymorphic " else str"Monomorphic " else mt () -let pr_universe_instance evd ctx = - let inst = Univ.UContext.instance ctx in - str"@{" ++ Univ.Instance.pr (Termops.pr_evd_level evd) inst ++ str"}" - (* print the proof step, possibly with diffs highlighted, *) let print_and_diff oldp newp = match newp with diff --git a/printing/printer.mli b/printing/printer.mli index 948b06f3f6..971241d5f9 100644 --- a/printing/printer.mli +++ b/printing/printer.mli @@ -120,7 +120,7 @@ val pr_sort : evar_map -> Sorts.t -> Pp.t val pr_polymorphic : bool -> Pp.t val pr_cumulative : bool -> bool -> Pp.t -val pr_universe_instance : evar_map -> Univ.UContext.t -> Pp.t +val pr_universe_instance : evar_map -> Univ.Instance.t -> Pp.t val pr_universe_ctx : evar_map -> ?variance:Univ.Variance.t array -> Univ.UContext.t -> Pp.t val pr_universe_ctx_set : evar_map -> Univ.ContextSet.t -> Pp.t @@ -139,9 +139,9 @@ val pr_constructor : env -> constructor -> Pp.t val pr_inductive : env -> inductive -> Pp.t val pr_evaluable_reference : evaluable_global_reference -> Pp.t -val pr_pconstant : env -> pconstant -> Pp.t -val pr_pinductive : env -> pinductive -> Pp.t -val pr_pconstructor : env -> pconstructor -> Pp.t +val pr_pconstant : env -> evar_map -> pconstant -> Pp.t +val pr_pinductive : env -> evar_map -> pinductive -> Pp.t +val pr_pconstructor : env -> evar_map -> pconstructor -> Pp.t (** Contexts *) diff --git a/printing/printmod.ml b/printing/printmod.ml index 3f95dcfb6d..e2d9850bf8 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -103,9 +103,7 @@ let print_one_inductive env sigma mib ((_,i) as ind) = let envpar = push_rel_context params env in let inst = if Declareops.inductive_is_polymorphic mib then - let ctx = Declareops.inductive_polymorphic_context mib in - let ctx = Univ.UContext.make (u, Univ.AUContext.instantiate u ctx) in - Printer.pr_universe_instance sigma ctx + Printer.pr_universe_instance sigma u else mt () in hov 0 ( diff --git a/test-suite/bugs/closed/2733.v b/test-suite/bugs/closed/2733.v index 832de4f913..24dd30b32e 100644 --- a/test-suite/bugs/closed/2733.v +++ b/test-suite/bugs/closed/2733.v @@ -16,6 +16,21 @@ match k,l with |B,l' => Bcons true (Ncons 0 l') end. +(* At some time, the success of trullynul was dependent on the name of + the variables! *) + +Definition trullynul2 k {a} (l : alt_list k a) := +match k,l with + |N,l' => Ncons 0 (Bcons true l') + |B,l' => Bcons true (Ncons 0 l') +end. + +Definition trullynul3 k {z} (l : alt_list k z) := +match k,l with + |N,l' => Ncons 0 (Bcons true l') + |B,l' => Bcons true (Ncons 0 l') +end. + Fixpoint app (P : forall {k k'}, alt_list k k' -> alt_list k k') {t1 t2} (l : alt_list t1 t2) {struct l}: forall {t3}, alt_list t2 t3 -> alt_list t1 t3 := match l with diff --git a/test-suite/bugs/closed/8126.v b/test-suite/bugs/closed/8126.v new file mode 100644 index 0000000000..f52dfc6b47 --- /dev/null +++ b/test-suite/bugs/closed/8126.v @@ -0,0 +1,13 @@ +(* See also output test Notations4.v *) + +Inductive foo := tt. +Bind Scope foo_scope with foo. +Delimit Scope foo_scope with foo. +Notation "'HI'" := tt : foo_scope. +Definition myfoo (x : nat) (y : nat) (z : foo) := y. +Notation myfoo0 := (@myfoo 0). +Notation myfoo01 := (@myfoo0 1). +Check myfoo 0 1 HI. (* prints [myfoo0 1 HI], but should print [myfoo01 HI] *) +Check myfoo0 1 HI. (* prints [myfoo0 1 HI], but should print [myfoo01 HI] *) +Check myfoo01 tt. (* prints [myfoo0 1 HI], but should print [myfoo01 HI] *) +Check myfoo01 HI. (* was failing *) diff --git a/test-suite/output/Notations3.out b/test-suite/output/Notations3.out index 5ab616160a..d32cf67e28 100644 --- a/test-suite/output/Notations3.out +++ b/test-suite/output/Notations3.out @@ -246,3 +246,9 @@ Notation ============================ ##@% ^^^ +myfoo01 tt + : nat +myfoo01 tt + : nat +myfoo01 tt + : nat diff --git a/test-suite/output/Notations3.v b/test-suite/output/Notations3.v index 876aaa3944..180e8d337e 100644 --- a/test-suite/output/Notations3.v +++ b/test-suite/output/Notations3.v @@ -399,3 +399,14 @@ Show. Abort. End Issue7731. + +Module Issue8126. + +Definition myfoo (x : nat) (y : nat) (z : unit) := y. +Notation myfoo0 := (@myfoo 0). +Notation myfoo01 := (@myfoo0 1). +Check myfoo 0 1 tt. (* was printing [myfoo0 1 HI], but should print [myfoo01 HI] *) +Check myfoo0 1 tt. (* was printing [myfoo0 1 HI], but should print [myfoo01 HI] *) +Check myfoo01 tt. (* was printing [myfoo0 1 HI], but should print [myfoo01 HI] *) + +End Issue8126. diff --git a/vernac/himsg.ml b/vernac/himsg.ml index 0a316271e8..b9c47ff475 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -194,12 +194,6 @@ let rec pr_disjunction pr = function | a::l -> pr a ++ str "," ++ spc () ++ pr_disjunction pr l | [] -> assert false -let pr_puniverses f env (c,u) = - f env c ++ - (if Flags.is_universe_polymorphism () && not (Univ.Instance.is_empty u) then - str"(*" ++ Univ.Instance.pr UnivNames.pr_with_global_universes u ++ str"*)" - else mt()) - let explain_elim_arity env sigma ind sorts c pj okinds = let open EConstr in let env = make_all_name_different env sigma in @@ -262,7 +256,7 @@ let explain_ill_formed_branch env sigma c ci actty expty = let pa, pe = pr_explicit env sigma (simp actty) (simp expty) in strbrk "In pattern-matching on term" ++ brk(1,1) ++ pc ++ spc () ++ strbrk "the branch for constructor" ++ spc () ++ - quote (pr_puniverses pr_constructor env ci) ++ + quote (pr_pconstructor env sigma ci) ++ spc () ++ str "has type" ++ brk(1,1) ++ pa ++ spc () ++ str "which should be" ++ brk(1,1) ++ pe ++ str "." |