aboutsummaryrefslogtreecommitdiff
path: root/engine
diff options
context:
space:
mode:
Diffstat (limited to 'engine')
-rw-r--r--engine/eConstr.ml2
-rw-r--r--engine/eConstr.mli2
-rw-r--r--engine/evarutil.ml2
-rw-r--r--engine/evarutil.mli2
-rw-r--r--engine/evd.ml7
-rw-r--r--engine/evd.mli6
-rw-r--r--engine/ftactic.ml2
-rw-r--r--engine/ftactic.mli2
-rw-r--r--engine/geninterp.ml4
-rw-r--r--engine/geninterp.mli4
-rw-r--r--engine/logic_monad.ml2
-rw-r--r--engine/logic_monad.mli12
-rw-r--r--engine/namegen.ml2
-rw-r--r--engine/namegen.mli2
-rw-r--r--engine/proofview.ml13
-rw-r--r--engine/proofview.mli30
-rw-r--r--engine/proofview_monad.ml4
-rw-r--r--engine/proofview_monad.mli6
-rw-r--r--engine/termops.ml9
-rw-r--r--engine/termops.mli39
-rw-r--r--engine/uState.ml13
-rw-r--r--engine/uState.mli11
-rw-r--r--engine/universes.ml121
-rw-r--r--engine/universes.mli22
24 files changed, 108 insertions, 211 deletions
diff --git a/engine/eConstr.ml b/engine/eConstr.ml
index 078f2fc333..7b879a8031 100644
--- a/engine/eConstr.ml
+++ b/engine/eConstr.ml
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
+(* <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 *)
diff --git a/engine/eConstr.mli b/engine/eConstr.mli
index 07a4dc8e23..4dbf6c18a3 100644
--- a/engine/eConstr.mli
+++ b/engine/eConstr.mli
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
+(* <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 *)
diff --git a/engine/evarutil.ml b/engine/evarutil.ml
index 4abfb674ec..339c6a248e 100644
--- a/engine/evarutil.ml
+++ b/engine/evarutil.ml
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
+(* <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 *)
diff --git a/engine/evarutil.mli b/engine/evarutil.mli
index 636472df6e..14173e774d 100644
--- a/engine/evarutil.mli
+++ b/engine/evarutil.mli
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
+(* <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 *)
diff --git a/engine/evd.ml b/engine/evd.ml
index bf1e052b63..cfc9aa6351 100644
--- a/engine/evd.ml
+++ b/engine/evd.ml
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
+(* <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 *)
@@ -780,8 +780,9 @@ let new_sort_variable ?loc ?name rigid d =
let add_global_univ d u =
{ d with universes = UState.add_global_univ d.universes u }
-let make_flexible_variable evd b u =
- { evd with universes = UState.make_flexible_variable evd.universes b u }
+let make_flexible_variable evd ~algebraic u =
+ { evd with universes =
+ UState.make_flexible_variable evd.universes ~algebraic u }
let make_evar_universe_context e l =
let uctx = UState.make (Environ.universes e) in
diff --git a/engine/evd.mli b/engine/evd.mli
index 86755c360b..3f00a3b0b2 100644
--- a/engine/evd.mli
+++ b/engine/evd.mli
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
+(* <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 *)
@@ -522,7 +522,9 @@ val new_sort_variable : ?loc:Loc.t -> ?name:string -> rigid -> evar_map -> evar_
val add_global_univ : evar_map -> Univ.Level.t -> evar_map
val universe_rigidity : evar_map -> Univ.Level.t -> rigid
-val make_flexible_variable : evar_map -> bool -> Univ.universe_level -> evar_map
+val make_flexible_variable : evar_map -> algebraic:bool -> Univ.universe_level -> evar_map
+(** See [UState.make_flexible_variable] *)
+
val is_sort_variable : evar_map -> sorts -> Univ.universe_level option
(** [is_sort_variable evm s] returns [Some u] or [None] if [s] is
not a local sort variable declared in [evm] *)
diff --git a/engine/ftactic.ml b/engine/ftactic.ml
index 68368e38fa..8e4c5f2206 100644
--- a/engine/ftactic.ml
+++ b/engine/ftactic.ml
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
+(* <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 *)
diff --git a/engine/ftactic.mli b/engine/ftactic.mli
index 97bebe9da8..c108c0c2ea 100644
--- a/engine/ftactic.mli
+++ b/engine/ftactic.mli
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
+(* <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 *)
diff --git a/engine/geninterp.ml b/engine/geninterp.ml
index cfca95d3e6..e79e258fbc 100644
--- a/engine/geninterp.ml
+++ b/engine/geninterp.ml
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
+(* <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 *)
@@ -32,7 +32,7 @@ struct
let repr = ValT.repr
let create = ValT.create
- let pr : type a. a typ -> Pp.std_ppcmds = fun t -> Pp.str (repr t)
+ let pr : type a. a typ -> Pp.t = fun t -> Pp.str (repr t)
let typ_list = ValT.create "list"
let typ_opt = ValT.create "option"
diff --git a/engine/geninterp.mli b/engine/geninterp.mli
index b70671a2d9..492e372adb 100644
--- a/engine/geninterp.mli
+++ b/engine/geninterp.mli
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
+(* <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 *)
@@ -30,7 +30,7 @@ sig
val eq : 'a typ -> 'b typ -> ('a, 'b) CSig.eq option
val repr : 'a typ -> string
- val pr : 'a typ -> Pp.std_ppcmds
+ val pr : 'a typ -> Pp.t
val typ_list : t list typ
val typ_opt : t option typ
diff --git a/engine/logic_monad.ml b/engine/logic_monad.ml
index 6e821ea5aa..bf1b3e0e86 100644
--- a/engine/logic_monad.ml
+++ b/engine/logic_monad.ml
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
+(* <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 *)
diff --git a/engine/logic_monad.mli b/engine/logic_monad.mli
index dd122cca0f..8c8f9fe935 100644
--- a/engine/logic_monad.mli
+++ b/engine/logic_monad.mli
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
+(* <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 *)
@@ -57,11 +57,11 @@ module NonLogical : sig
val print_char : char -> unit t
(** Loggers. The buffer is also flushed. *)
- val print_debug : Pp.std_ppcmds -> unit t
- val print_warning : Pp.std_ppcmds -> unit t
- val print_notice : Pp.std_ppcmds -> unit t
- val print_info : Pp.std_ppcmds -> unit t
- val print_error : Pp.std_ppcmds -> unit t
+ val print_debug : Pp.t -> unit t
+ val print_warning : Pp.t -> unit t
+ val print_notice : Pp.t -> unit t
+ val print_info : Pp.t -> unit t
+ val print_error : Pp.t -> unit t
(** [Pervasives.raise]. Except that exceptions are wrapped with
{!Exception}. *)
diff --git a/engine/namegen.ml b/engine/namegen.ml
index 783085654e..a75fe721f7 100644
--- a/engine/namegen.ml
+++ b/engine/namegen.ml
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
+(* <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 *)
diff --git a/engine/namegen.mli b/engine/namegen.mli
index 058b1c228b..14846a9184 100644
--- a/engine/namegen.mli
+++ b/engine/namegen.mli
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
+(* <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 *)
diff --git a/engine/proofview.ml b/engine/proofview.ml
index 39ef65dab1..eef2b83f44 100644
--- a/engine/proofview.ml
+++ b/engine/proofview.ml
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
+(* <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 *)
@@ -332,7 +332,7 @@ exception NoSuchGoals of int
(* This hook returns a string to be appended to the usual message.
Primarily used to add a suggestion about the right bullet to use to
focus the next goal, if applicable. *)
-let nosuchgoals_hook:(int -> std_ppcmds) ref = ref (fun n -> mt ())
+let nosuchgoals_hook:(int -> Pp.t) ref = ref (fun n -> mt ())
let set_nosuchgoals_hook f = nosuchgoals_hook := f
@@ -1072,13 +1072,6 @@ module Goal = struct
end
end
- exception NotExactlyOneSubgoal
- let _ = CErrors.register_handler begin function
- | NotExactlyOneSubgoal ->
- CErrors.user_err (Pp.str"Not exactly one subgoal.")
- | _ -> raise CErrors.Unhandled
- end
-
let enter_one f =
let open Proof in
Comb.get >>= function
@@ -1090,7 +1083,7 @@ module Goal = struct
let (e, info) = CErrors.push e in
tclZERO ~info e
end
- | _ -> tclZERO NotExactlyOneSubgoal
+ | _ -> assert false (* unsatisfied not-exactly-one-goal precondition *)
let goals =
Pv.get >>= fun step ->
diff --git a/engine/proofview.mli b/engine/proofview.mli
index aae25b6f8f..d92d0a7d53 100644
--- a/engine/proofview.mli
+++ b/engine/proofview.mli
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
+(* <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 *)
@@ -25,7 +25,7 @@ type proofview
new nearly identical function everytime. Hence the generic name. *)
(* In this version: returns the list of focused goals together with
the [evar_map] context. *)
-val proofview : proofview -> Goal.goal list * Evd.evar_map
+val proofview : proofview -> Evd.evar list * Evd.evar_map
(** {6 Starting and querying a proof view} *)
@@ -88,7 +88,7 @@ type focus_context
new nearly identical function everytime. Hence the generic name. *)
(* In this version: the goals in the context, as a "zipper" (the first
list is in reversed order). *)
-val focus_context : focus_context -> Goal.goal list * Goal.goal list
+val focus_context : focus_context -> Evd.evar list * Evd.evar list
(** [focus i j] focuses a proofview on the goals from index [i] to
index [j] (inclusive, goals are indexed from [1]). I.e. goals
@@ -148,7 +148,7 @@ type +'a tactic
{!Logic_monad.TacticFailure}*)
val apply : Environ.env -> 'a tactic -> proofview -> 'a
* proofview
- * (bool*Goal.goal list*Goal.goal list)
+ * (bool*Evd.evar list*Evd.evar list)
* Proofview_monad.Info.tree
(** {7 Monadic primitives} *)
@@ -235,7 +235,7 @@ val tclBREAK : (iexn -> iexn option) -> 'a tactic -> 'a tactic
This hook is used to add a suggestion about bullets when
applicable. *)
exception NoSuchGoals of int
-val set_nosuchgoals_hook: (int -> Pp.std_ppcmds) -> unit
+val set_nosuchgoals_hook: (int -> Pp.t) -> unit
val tclFOCUS : int -> int -> 'a tactic -> 'a tactic
@@ -304,12 +304,12 @@ val shelve : unit tactic
(** Shelves the given list of goals, which might include some that are
under focus and some that aren't. All the goals are placed on the
shelf for later use (or being solved by side-effects). *)
-val shelve_goals : Goal.goal list -> unit tactic
+val shelve_goals : Evd.evar list -> unit tactic
(** [unifiable sigma g l] checks whether [g] appears in another
subgoal of [l]. The list [l] may contain [g], but it does not
affect the result. Used by [shelve_unifiable]. *)
-val unifiable : Evd.evar_map -> Goal.goal -> Goal.goal list -> bool
+val unifiable : Evd.evar_map -> Evd.evar -> Evd.evar list -> bool
(** Shelves the unifiable goals under focus, i.e. the goals which
appear in other goals under focus (the unfocused goals are not
@@ -322,15 +322,15 @@ val guard_no_unifiable : Names.Name.t list option tactic
(** [unshelve l p] adds all the goals in [l] at the end of the focused
goals of p *)
-val unshelve : Goal.goal list -> proofview -> proofview
+val unshelve : Evd.evar list -> proofview -> proofview
(** [depends_on g1 g2 sigma] checks if g1 occurs in the type/ctx of g2 *)
-val depends_on : Evd.evar_map -> Goal.goal -> Goal.goal -> bool
+val depends_on : Evd.evar_map -> Evd.evar -> Evd.evar -> bool
(** [with_shelf tac] executes [tac] and returns its result together with
the set of goals shelved by [tac]. The current shelf is unchanged
and the returned list contains only unsolved goals. *)
-val with_shelf : 'a tactic -> (Goal.goal list * 'a) tactic
+val with_shelf : 'a tactic -> (Evd.evar list * 'a) tactic
(** If [n] is positive, [cycle n] puts the [n] first goal last. If [n]
is negative, then it puts the [n] last goals first.*)
@@ -416,14 +416,14 @@ module Unsafe : sig
(** [tclNEWGOALS gls] adds the goals [gls] to the ones currently
being proved, appending them to the list of focused goals. If a
goal is already solved, it is not added. *)
- val tclNEWGOALS : Goal.goal list -> unit tactic
+ val tclNEWGOALS : Evd.evar list -> unit tactic
(** [tclSETGOALS gls] sets goals [gls] as the goals being under focus. If a
goal is already solved, it is not set. *)
- val tclSETGOALS : Goal.goal list -> unit tactic
+ val tclSETGOALS : Evd.evar list -> unit tactic
(** [tclGETGOALS] returns the list of goals under focus. *)
- val tclGETGOALS : Goal.goal list tactic
+ val tclGETGOALS : Evd.evar list tactic
(** Sets the evar universe context. *)
val tclEVARUNIVCONTEXT : Evd.evar_universe_context -> unit tactic
@@ -498,7 +498,7 @@ module Goal : sig
val enter : ([ `LZ ] t -> unit tactic) -> unit tactic
(** Like {!enter}, but assumes exactly one goal under focus, raising *)
- (** an error otherwise. *)
+ (** a fatal error otherwise. *)
val enter_one : ([ `LZ ] t -> 'a tactic) -> 'a tactic
(** Recover the list of current goals under focus, without evar-normalization.
@@ -526,7 +526,7 @@ module Trace : sig
val log : Proofview_monad.lazy_msg -> unit tactic
val name_tactic : Proofview_monad.lazy_msg -> 'a tactic -> 'a tactic
- val pr_info : ?lvl:int -> Proofview_monad.Info.tree -> Pp.std_ppcmds
+ val pr_info : ?lvl:int -> Proofview_monad.Info.tree -> Pp.t
end
diff --git a/engine/proofview_monad.ml b/engine/proofview_monad.ml
index 6f52b3ee90..d0f4712258 100644
--- a/engine/proofview_monad.ml
+++ b/engine/proofview_monad.ml
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
+(* <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 *)
@@ -62,7 +62,7 @@ end
(** We typically label nodes of [Trace.tree] with messages to
print. But we don't want to compute the result. *)
-type lazy_msg = unit -> Pp.std_ppcmds
+type lazy_msg = unit -> Pp.t
let pr_lazy_msg msg = msg ()
(** Info trace. *)
diff --git a/engine/proofview_monad.mli b/engine/proofview_monad.mli
index 637414cce7..e7123218b1 100644
--- a/engine/proofview_monad.mli
+++ b/engine/proofview_monad.mli
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
+(* <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 *)
@@ -43,7 +43,7 @@ end
(** We typically label nodes of [Trace.tree] with messages to
print. But we don't want to compute the result. *)
-type lazy_msg = unit -> Pp.std_ppcmds
+type lazy_msg = unit -> Pp.t
(** Info trace. *)
module Info : sig
@@ -58,7 +58,7 @@ module Info : sig
type state = tag Trace.incr
type tree = tag Trace.forest
- val print : tree -> Pp.std_ppcmds
+ val print : tree -> Pp.t
(** [collapse n t] flattens the first [n] levels of [Tactic] in an
info trace, effectively forgetting about the [n] top level of
diff --git a/engine/termops.ml b/engine/termops.ml
index 3eef71b2d0..2bd0c06d6d 100644
--- a/engine/termops.ml
+++ b/engine/termops.ml
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
+(* <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 *)
@@ -906,7 +906,7 @@ let collect_vars sigma c =
aux Id.Set.empty c
let vars_of_global_reference env gr =
- let c, _ = Universes.unsafe_constr_of_global gr in
+ let c, _ = Global.constr_of_global_in_context env gr in
vars_of_global (Global.env ()) c
(* Tests whether [m] is a subterm of [t]:
@@ -994,12 +994,14 @@ let rec strip_outer_cast sigma c = match EConstr.kind sigma c with
(* flattens application lists throwing casts in-between *)
let collapse_appl sigma c = match EConstr.kind sigma c with
| App (f,cl) ->
+ if EConstr.isCast sigma f then
let rec collapse_rec f cl2 =
match EConstr.kind sigma (strip_outer_cast sigma f) with
| App (g,cl1) -> collapse_rec g (Array.append cl1 cl2)
| _ -> EConstr.mkApp (f,cl2)
in
collapse_rec f cl
+ else c
| _ -> c
(* First utilities for avoiding telescope computation for subst_term *)
@@ -1145,9 +1147,6 @@ let is_template_polymorphic env sigma f =
| Ind (ind, u) ->
if not (EConstr.EInstance.is_empty u) then false
else Environ.template_polymorphic_ind ind env
- | Const (cst, u) ->
- if not (EConstr.EInstance.is_empty u) then false
- else Environ.template_polymorphic_constant cst env
| _ -> false
let base_sort_cmp pb s0 s1 =
diff --git a/engine/termops.mli b/engine/termops.mli
index 58837ba033..2624afd30d 100644
--- a/engine/termops.mli
+++ b/engine/termops.mli
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
+(* <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 *)
@@ -9,16 +9,15 @@
(** This file defines various utilities for term manipulation that are not
needed in the kernel. *)
-open Pp
open Names
open Term
open Environ
open EConstr
(** printers *)
-val print_sort : sorts -> std_ppcmds
-val pr_sort_family : sorts_family -> std_ppcmds
-val pr_fix : ('a -> std_ppcmds) -> ('a, 'a) pfixpoint -> std_ppcmds
+val print_sort : sorts -> Pp.t
+val pr_sort_family : sorts_family -> Pp.t
+val pr_fix : ('a -> Pp.t) -> ('a, 'a) pfixpoint -> Pp.t
(** about contexts *)
val push_rel_assum : Name.t * types -> env -> env
@@ -279,25 +278,25 @@ val on_judgment_type : ('t -> 't) -> ('c, 't) punsafe_judgment -> ('c, 't) puns
open Evd
-val pr_existential_key : evar_map -> evar -> Pp.std_ppcmds
+val pr_existential_key : evar_map -> evar -> Pp.t
val pr_evar_suggested_name : existential_key -> evar_map -> Id.t
-val pr_evar_info : evar_info -> Pp.std_ppcmds
-val pr_evar_constraints : evar_map -> evar_constraint list -> Pp.std_ppcmds
-val pr_evar_map : ?with_univs:bool -> int option -> evar_map -> Pp.std_ppcmds
+val pr_evar_info : evar_info -> Pp.t
+val pr_evar_constraints : evar_map -> evar_constraint list -> Pp.t
+val pr_evar_map : ?with_univs:bool -> int option -> evar_map -> Pp.t
val pr_evar_map_filter : ?with_univs:bool -> (Evar.t -> evar_info -> bool) ->
- evar_map -> Pp.std_ppcmds
-val pr_metaset : Metaset.t -> Pp.std_ppcmds
-val pr_evar_universe_context : evar_universe_context -> Pp.std_ppcmds
-val pr_evd_level : evar_map -> Univ.Level.t -> Pp.std_ppcmds
+ evar_map -> Pp.t
+val pr_metaset : Metaset.t -> Pp.t
+val pr_evar_universe_context : evar_universe_context -> Pp.t
+val pr_evd_level : evar_map -> Univ.Level.t -> Pp.t
(** debug printer: do not use to display terms to the casual user... *)
-val set_print_constr : (env -> Evd.evar_map -> constr -> std_ppcmds) -> unit
-val print_constr : constr -> std_ppcmds
-val print_constr_env : env -> Evd.evar_map -> constr -> std_ppcmds
-val print_named_context : env -> std_ppcmds
-val pr_rel_decl : env -> Context.Rel.Declaration.t -> std_ppcmds
-val print_rel_context : env -> std_ppcmds
-val print_env : env -> std_ppcmds
+val set_print_constr : (env -> Evd.evar_map -> constr -> Pp.t) -> unit
+val print_constr : constr -> Pp.t
+val print_constr_env : env -> Evd.evar_map -> constr -> Pp.t
+val print_named_context : env -> Pp.t
+val pr_rel_decl : env -> Context.Rel.Declaration.t -> Pp.t
+val print_rel_context : env -> Pp.t
+val print_env : env -> Pp.t
diff --git a/engine/uState.ml b/engine/uState.ml
index 0973ca457f..63bd247d56 100644
--- a/engine/uState.ml
+++ b/engine/uState.ml
@@ -384,16 +384,21 @@ let add_global_univ uctx u =
uctx_initial_universes = initial;
uctx_universes = univs }
-let make_flexible_variable ctx b u =
- let {uctx_univ_variables = uvars; uctx_univ_algebraic = avars} = ctx in
+let make_flexible_variable ctx ~algebraic u =
+ let {uctx_local = cstrs; uctx_univ_variables = uvars; uctx_univ_algebraic = avars} = ctx in
let uvars' = Univ.LMap.add u None uvars in
let avars' =
- if b then
+ if algebraic then
let uu = Univ.Universe.make u in
let substu_not_alg u' v =
Option.cata (fun vu -> Univ.Universe.equal uu vu && not (Univ.LSet.mem u' avars)) false v
in
- if not (Univ.LMap.exists substu_not_alg uvars)
+ let has_upper_constraint () =
+ Univ.Constraint.exists
+ (fun (l,d,r) -> d == Univ.Lt && Univ.Level.equal l u)
+ (Univ.ContextSet.constraints cstrs)
+ in
+ if not (Univ.LMap.exists substu_not_alg uvars || has_upper_constraint ())
then Univ.LSet.add u avars else avars
else avars
in
diff --git a/engine/uState.mli b/engine/uState.mli
index 0cdc6277a5..d198fbfbe9 100644
--- a/engine/uState.mli
+++ b/engine/uState.mli
@@ -92,7 +92,14 @@ val emit_side_effects : Safe_typing.private_constants -> t -> t
val new_univ_variable : ?loc:Loc.t -> rigid -> string option -> t -> t * Univ.Level.t
val add_global_univ : t -> Univ.Level.t -> t
-val make_flexible_variable : t -> bool -> Univ.Level.t -> t
+
+(** [make_flexible_variable g algebraic l]
+
+ Turn the variable [l] flexible, and algebraic if [algebraic] is true
+ and [l] can be. That is if there are no strict upper constraints on
+ [l] and and it does not appear in the instance of any non-algebraic
+ universe. Otherwise the variable is just made flexible. *)
+val make_flexible_variable : t -> algebraic:bool -> Univ.Level.t -> t
val is_sort_variable : t -> Sorts.t -> Univ.Level.t option
@@ -116,4 +123,4 @@ val update_sigma_env : t -> Environ.env -> t
(** {5 Pretty-printing} *)
-val pr_uctx_level : t -> Univ.Level.t -> Pp.std_ppcmds
+val pr_uctx_level : t -> Univ.Level.t -> Pp.t
diff --git a/engine/universes.ml b/engine/universes.ml
index bd4d75930c..719af43edf 100644
--- a/engine/universes.ml
+++ b/engine/universes.ml
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
+(* <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 *)
@@ -282,28 +282,27 @@ let new_Type dp = mkType (new_univ dp)
let new_Type_sort dp = Type (new_univ dp)
let fresh_universe_instance ctx =
- Instance.subst_fn (fun _ -> new_univ_level (Global.current_dirpath ()))
- (AUContext.instance ctx)
+ let init _ = new_univ_level (Global.current_dirpath ()) in
+ Instance.of_array (Array.init (AUContext.size ctx) init)
let fresh_instance_from_context ctx =
let inst = fresh_universe_instance ctx in
- let constraints = UContext.constraints (subst_instance_context inst ctx) in
+ let constraints = AUContext.instantiate inst ctx in
inst, constraints
let fresh_instance ctx =
let ctx' = ref LSet.empty in
- let inst =
- Instance.subst_fn (fun v ->
- let u = new_univ_level (Global.current_dirpath ()) in
- ctx' := LSet.add u !ctx'; u)
- (AUContext.instance ctx)
+ let init _ =
+ let u = new_univ_level (Global.current_dirpath ()) in
+ ctx' := LSet.add u !ctx'; u
+ in
+ let inst = Instance.of_array (Array.init (AUContext.size ctx) init)
in !ctx', inst
let existing_instance ctx inst =
let () =
- let a1 = Instance.to_array inst
- and a2 = Instance.to_array (AUContext.instance ctx) in
- let len1 = Array.length a1 and len2 = Array.length a2 in
+ let len1 = Array.length (Instance.to_array inst)
+ and len2 = AUContext.size ctx in
if not (len1 == len2) then
CErrors.user_err ~hdr:"Universes"
(str "Polymorphic constant expected " ++ int len2 ++
@@ -317,12 +316,9 @@ let fresh_instance_from ctx inst =
| Some inst -> existing_instance ctx inst
| None -> fresh_instance ctx
in
- let constraints = UContext.constraints (subst_instance_context inst ctx) in
+ let constraints = AUContext.instantiate inst ctx in
inst, (ctx', constraints)
-let unsafe_instance_from ctx =
- (Univ.AUContext.instance ctx, Univ.instantiate_univ_context ctx)
-
(** Fresh universe polymorphic construction *)
let fresh_constant_instance env c inst =
@@ -359,34 +355,6 @@ let fresh_constructor_instance env (ind,i) inst =
let inst, ctx = fresh_instance_from (ACumulativityInfo.univ_context acumi) inst in
(((ind,i),inst), ctx)
-let unsafe_constant_instance env c =
- let cb = lookup_constant c env in
- match cb.Declarations.const_universes with
- | Declarations.Monomorphic_const _ ->
- ((c,Instance.empty), UContext.empty)
- | Declarations.Polymorphic_const auctx ->
- let inst, ctx = unsafe_instance_from auctx in ((c, inst), ctx)
-
-let unsafe_inductive_instance env ind =
- let mib, mip = Inductive.lookup_mind_specif env ind in
- match mib.Declarations.mind_universes with
- | Declarations.Monomorphic_ind _ -> ((ind,Instance.empty), UContext.empty)
- | Declarations.Polymorphic_ind auctx ->
- let inst, ctx = unsafe_instance_from auctx in ((ind,inst), ctx)
- | Declarations.Cumulative_ind acumi ->
- let inst, ctx = unsafe_instance_from (ACumulativityInfo.univ_context acumi) in
- ((ind,inst), ctx)
-
-let unsafe_constructor_instance env (ind,i) =
- let mib, mip = Inductive.lookup_mind_specif env ind in
- match mib.Declarations.mind_universes with
- | Declarations.Monomorphic_ind _ -> (((ind, i),Instance.empty), UContext.empty)
- | Declarations.Polymorphic_ind auctx ->
- let inst, ctx = unsafe_instance_from auctx in (((ind, i),inst), ctx)
- | Declarations.Cumulative_ind acumi ->
- let inst, ctx = unsafe_instance_from (ACumulativityInfo.univ_context acumi) in
- (((ind, i),inst), ctx)
-
open Globnames
let fresh_global_instance ?names env gr =
@@ -411,19 +379,6 @@ let fresh_inductive_instance env sp =
let fresh_constructor_instance env sp =
fresh_constructor_instance env sp None
-let unsafe_global_instance env gr =
- match gr with
- | VarRef id -> mkVar id, UContext.empty
- | ConstRef sp ->
- let c, ctx = unsafe_constant_instance env sp in
- mkConstU c, ctx
- | ConstructRef sp ->
- let c, ctx = unsafe_constructor_instance env sp in
- mkConstructU c, ctx
- | IndRef sp ->
- let c, ctx = unsafe_inductive_instance env sp in
- mkIndU c, ctx
-
let constr_of_global gr =
let c, ctx = fresh_global_instance (Global.env ()) gr in
if not (Univ.ContextSet.is_empty ctx) then
@@ -438,9 +393,6 @@ let constr_of_global gr =
let constr_of_reference = constr_of_global
-let unsafe_constr_of_global gr =
- unsafe_global_instance (Global.env ()) gr
-
let constr_of_global_univ (gr,u) =
match gr with
| VarRef id -> mkVar id
@@ -467,7 +419,7 @@ let type_of_reference env r =
| VarRef id -> Environ.named_type id env, ContextSet.empty
| ConstRef c ->
let cb = Environ.lookup_constant c env in
- let ty = Typeops.type_of_constant_type env cb.const_type in
+ let ty = cb.const_type in
begin
match cb.const_universes with
| Monomorphic_const _ -> ty, ContextSet.empty
@@ -514,25 +466,6 @@ let type_of_reference env r =
let type_of_global t = type_of_reference (Global.env ()) t
-let unsafe_type_of_reference env r =
- match r with
- | VarRef id -> Environ.named_type id env
- | ConstRef c ->
- let cb = Environ.lookup_constant c env in
- Typeops.type_of_constant_type env cb.const_type
-
- | IndRef ind ->
- let (mib, oib as specif) = Inductive.lookup_mind_specif env ind in
- let (_, inst), _ = unsafe_inductive_instance env ind in
- Inductive.type_of_inductive env (specif, inst)
-
- | ConstructRef (ind, _ as cstr) ->
- let (mib,oib as specif) = Inductive.lookup_mind_specif env (inductive_of_constructor cstr) in
- let (_, inst), _ = unsafe_inductive_instance env ind in
- Inductive.type_of_constructor (cstr,inst) specif
-
-let unsafe_type_of_global t = unsafe_type_of_reference (Global.env ()) t
-
let fresh_sort_in_family env = function
| InProp -> prop_sort, ContextSet.empty
| InSet -> set_sort, ContextSet.empty
@@ -1015,34 +948,6 @@ let normalize_context_set ctx us algs =
(* let normalize_conkey = Profile.declare_profile "normalize_context_set" *)
(* let normalize_context_set a b c = Profile.profile3 normalize_conkey normalize_context_set a b c *)
-let simplify_universe_context (univs,csts) =
- let uf = UF.create () in
- let noneqs =
- Constraint.fold (fun (l,d,r) noneqs ->
- if d == Eq && (LSet.mem l univs || LSet.mem r univs) then
- (UF.union l r uf; noneqs)
- else Constraint.add (l,d,r) noneqs)
- csts Constraint.empty
- in
- let partition = UF.partition uf in
- let flex x = LSet.mem x univs in
- let subst, univs', csts' = List.fold_left (fun (subst, univs, cstrs) s ->
- let canon, (global, rigid, flexible) = choose_canonical univs flex LSet.empty s in
- (* Add equalities for globals which can't be merged anymore. *)
- let cstrs = LSet.fold (fun g cst ->
- Constraint.add (canon, Univ.Eq, g) cst) (LSet.union global rigid)
- cstrs
- in
- let subst = LSet.fold (fun f -> LMap.add f canon)
- flexible subst
- in (subst, LSet.diff univs flexible, cstrs))
- (LMap.empty, univs, noneqs) partition
- in
- (* Noneqs is now in canonical form w.r.t. equality constraints,
- and contains only inequality constraints. *)
- let csts' = subst_univs_level_constraints subst csts' in
- (univs', csts'), subst
-
let is_trivial_leq (l,d,r) =
Univ.Level.is_prop l && (d == Univ.Le || (d == Univ.Lt && Univ.Level.is_set r))
diff --git a/engine/universes.mli b/engine/universes.mli
index 5ce5e4a42a..fe40f82385 100644
--- a/engine/universes.mli
+++ b/engine/universes.mli
@@ -1,6 +1,6 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
+(* <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 *)
@@ -17,7 +17,7 @@ val is_set_minimization : unit -> bool
(** Universes *)
-val pr_with_global_universes : Level.t -> Pp.std_ppcmds
+val pr_with_global_universes : Level.t -> Pp.t
(** Local universe name <-> level mapping *)
@@ -52,7 +52,7 @@ type universe_constraint = universe * universe_constraint_type * universe
module Constraints : sig
include Set.S with type elt = universe_constraint
- val pr : t -> Pp.std_ppcmds
+ val pr : t -> Pp.t
end
type universe_constraints = Constraints.t
@@ -189,35 +189,21 @@ val constr_of_global : Globnames.global_reference -> constr
(** ** DEPRECATED ** synonym of [constr_of_global] *)
val constr_of_reference : Globnames.global_reference -> constr
-(** [unsafe_constr_of_global gr] turns [gr] into a constr, works on polymorphic
- references by taking the original universe instance that is not recorded
- anywhere. The constraints are forgotten as well. DO NOT USE in new code. *)
-val unsafe_constr_of_global : Globnames.global_reference -> constr in_universe_context
-
(** Returns the type of the global reference, by creating a fresh instance of polymorphic
references and computing their instantiated universe context. (side-effect on the
universe counter, use with care). *)
val type_of_global : Globnames.global_reference -> types in_universe_context_set
-(** [unsafe_type_of_global gr] returns [gr]'s type, works on polymorphic
- references by taking the original universe instance that is not recorded
- anywhere. The constraints are forgotten as well.
- USE with care. *)
-val unsafe_type_of_global : Globnames.global_reference -> types
-
(** Full universes substitutions into terms *)
val nf_evars_and_universes_opt_subst : (existential -> constr option) ->
universe_opt_subst -> constr -> constr
-val simplify_universe_context : universe_context_set ->
- universe_context_set * universe_level_subst
-
val refresh_constraints : UGraph.t -> universe_context_set -> universe_context_set * UGraph.t
(** Pretty-printing *)
-val pr_universe_opt_subst : universe_opt_subst -> Pp.std_ppcmds
+val pr_universe_opt_subst : universe_opt_subst -> Pp.t
(** {6 Support for template polymorphism } *)
generated by cgit v1.2.3 (git 2.25.1) at 2026-05-02 08:11:16 +0000