diff options
| author | Matthieu Sozeau | 2014-06-20 15:22:29 +0200 |
|---|---|---|
| committer | Matthieu Sozeau | 2014-06-20 15:22:29 +0200 |
| commit | fb5750e4117a5455f7659fb7eec2b375a83e2e36 (patch) | |
| tree | 4fa790a5328030f459a461a7f46af044d1cb2200 | |
| parent | d6ce38cc3aa469446bad73dea3915ed9443751bd (diff) | |
Fix computation of inductive level in monomorphism + indices-matter mode.
Fixes bug #3346.
| -rw-r--r-- | kernel/indtypes.ml | 16 | ||||
| -rw-r--r-- | test-suite/bugs/closed/3346.v (renamed from test-suite/bugs/opened/3346.v) | 2 | ||||
| -rw-r--r-- | test-suite/bugs/opened/3372.v | 5 |
3 files changed, 9 insertions, 14 deletions
diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index 6c072d2d4d..cc56428fa4 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -288,14 +288,14 @@ let typecheck_inductive env ctx mie = let inds = Array.map (fun ((id,full_arity,sign,expltype,def_level,inf_level),cn,lc,(is_unit,clev)) -> + let infu = + (** Inferred level, with parameters and constructors. *) + match inf_level with + | Some alev -> Universe.sup clev alev + | None -> clev + in let full_polymorphic () = let defu = Term.univ_of_sort def_level in - let infu = - (** Inferred level, with parameters and constructors. *) - match inf_level with - | Some alev -> Universe.sup clev alev - | None -> clev - in let is_natural = check_leq (universes env') infu defu && not (is_type0m_univ defu && not is_unit) @@ -325,14 +325,14 @@ let typecheck_inductive env ctx mie = (* conclusions of the parameters *) (* We enforce [u >= lev] in case [lev] has a strict upper *) (* constraints over [u] *) - let b = check_leq (universes env') clev u in + let b = check_leq (universes env') infu u in if not b then anomaly ~label:"check_inductive" (Pp.str"Incorrect universe " ++ Universe.pr u ++ Pp.str " declared for inductive type, inferred level is " ++ Universe.pr clev) else - TemplateArity (param_ccls params, clev) + TemplateArity (param_ccls params, infu) | _ (* Not an explicit occurrence of Type *) -> full_polymorphic () in diff --git a/test-suite/bugs/opened/3346.v b/test-suite/bugs/closed/3346.v index 8c68565108..638404f2cb 100644 --- a/test-suite/bugs/opened/3346.v +++ b/test-suite/bugs/closed/3346.v @@ -1,4 +1,4 @@ (* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") -*- *) Monomorphic Inductive paths (A : Type) (a : A) : A -> Type := idpath : paths A a a. (* This should fail with -indices-matter *) -Check paths nat O O : Prop. +Fail Check paths nat O O : Prop. diff --git a/test-suite/bugs/opened/3372.v b/test-suite/bugs/opened/3372.v deleted file mode 100644 index 13ce75b84c..0000000000 --- a/test-suite/bugs/opened/3372.v +++ /dev/null @@ -1,5 +0,0 @@ -Set Universe Polymorphism. -Definition hProp : Type := sigT (fun _ : Type => True). -Goal hProp@{Set}. (* Toplevel input, characters 15-32: -Anomaly: Uncaught exception Invalid_argument("Array.iter2", _). -Please report. *) |