Admitted: fix #4818 return initial stmt and univs

2 files changed, 29 insertions, 2 deletions

diff --git a/stm/lemmas.ml b/stm/lemmas.ml
index 5b205e79ef..1ab695a5f2 100644
--- a/stm/lemmas.ml
+++ b/stm/lemmas.ml
@@ -476,9 +476,11 @@ let save_proof ?proof = function
             let ctx = Evd.evar_context_universe_context (fst universes) in
             Admitted(id, k, (const_entry_secctx, pi2 k, (typ, ctx), None), universes)
         | None ->
+            let pftree = Pfedit.get_pftreestate () in
             let id, k, typ = Pfedit.current_proof_statement () in
+            let universes = Proof.initial_euctx pftree in
             (* This will warn if the proof is complete *)
-            let pproofs, universes =
+            let pproofs, _univs =
               Proof_global.return_proof ~allow_partial:true () in
             let sec_vars =
               match  Pfedit.get_used_variables(), pproofs with
@@ -490,7 +492,8 @@ let save_proof ?proof = function
                   Some (Environ.keep_hyps env (Idset.union ids_typ ids_def))
               | _ -> None in
 	    let names = Pfedit.get_universe_binders () in
-            let binders, ctx = Evd.universe_context ?names (Evd.from_ctx universes) in
+            let evd = Evd.from_ctx universes in
+            let binders, ctx = Evd.universe_context ?names evd in
             Admitted(id,k,(sec_vars, pi2 k, (typ, ctx), None),
 		     (universes, Some binders))
       in
diff --git a/test-suite/bugs/closed/4818.v b/test-suite/bugs/closed/4818.v
new file mode 100644
index 0000000000..904abb2287
--- /dev/null
+++ b/test-suite/bugs/closed/4818.v
@@ -0,0 +1,24 @@
+(* -*- mode: coq; coq-prog-args: ("-emacs" "-R" "." "Prob" "-top" "Product") -*- *)
+(* File reduced by coq-bug-finder from original input, then from 391 lines to 77 lines, then from 857 lines to 119 lines, then from 1584 lines to 126 lines, then from 362 lines to 135 lines, then from 149 lines to 135 lines *)
+(* coqc version 8.5pl1 (June 2016) compiled on Jun 9 2016 17:27:17 with OCaml 4.02.3
+   coqtop version 8.5pl1 (June 2016) *)
+Set Universe Polymorphism.
+
+Inductive GCov (I : Type) : Type := | Foo : I -> GCov I.
+
+Section Product.
+
+Variables S IS : Type.
+Variable locS : IS -> True.
+
+Goal GCov (IS * S) -> GCov IS.
+intros X0. induction X0; intros.
+destruct i.
+specialize (locS i).
+clear -locS. 
+destruct locS. Show Universes.
+Admitted.
+
+(*
+Anomaly: Universe Product.5189 undefined. Please report.
+*)