summaryrefslogtreecommitdiff
path: root/kernel
diff options
context:
space:
mode:
authorGravatar Stephane Glondu <steph@glondu.net>2012-01-12 16:04:54 +0100
committerGravatar Stephane Glondu <steph@glondu.net>2012-01-12 16:04:54 +0100
commit39efc41237ec906226a3a53d7396d51173495204 (patch)
tree87cd58d72d43469d2a2a0a127c1060d7c9e0206b /kernel
parent5fe4ac437bed43547b3695664974f492b55cb553 (diff)
parent97fefe1fcca363a1317e066e7f4b99b9c1e9987b (diff)
Remove non-DFSG contentsupstream/8.4_beta+dfsg
Diffstat (limited to 'kernel')
-rw-r--r--kernel/byterun/coq_interp.c21
-rw-r--r--kernel/byterun/coq_memory.c6
-rw-r--r--kernel/byterun/coq_memory.h1
-rw-r--r--kernel/byterun/int64_emul.h2
-rw-r--r--kernel/byterun/int64_native.h2
-rw-r--r--kernel/cbytecodes.ml14
-rw-r--r--kernel/cbytecodes.mli95
-rw-r--r--kernel/cbytegen.ml49
-rw-r--r--kernel/cbytegen.mli13
-rw-r--r--kernel/cemitcodes.ml21
-rw-r--r--kernel/cemitcodes.mli7
-rw-r--r--kernel/closure.ml62
-rw-r--r--kernel/closure.mli72
-rw-r--r--kernel/conv_oracle.ml9
-rw-r--r--kernel/conv_oracle.mli16
-rw-r--r--kernel/cooking.ml36
-rw-r--r--kernel/cooking.mli13
-rw-r--r--kernel/csymtable.ml20
-rw-r--r--kernel/csymtable.mli10
-rw-r--r--kernel/declarations.ml199
-rw-r--r--kernel/declarations.mli179
-rw-r--r--kernel/entries.ml22
-rw-r--r--kernel/entries.mli46
-rw-r--r--kernel/environ.ml31
-rw-r--r--kernel/environ.mli105
-rw-r--r--kernel/esubst.ml10
-rw-r--r--kernel/esubst.mli61
-rw-r--r--kernel/indtypes.ml55
-rw-r--r--kernel/indtypes.mli15
-rw-r--r--kernel/inductive.ml391
-rw-r--r--kernel/inductive.mli51
-rw-r--r--kernel/mod_subst.ml804
-rw-r--r--kernel/mod_subst.mli95
-rw-r--r--kernel/mod_typing.ml303
-rw-r--r--kernel/mod_typing.mli46
-rw-r--r--kernel/modops.ml404
-rw-r--r--kernel/modops.mli94
-rw-r--r--kernel/names.ml277
-rw-r--r--kernel/names.mli108
-rw-r--r--kernel/pre_env.ml9
-rw-r--r--kernel/pre_env.mli16
-rw-r--r--kernel/reduction.ml224
-rw-r--r--kernel/reduction.mli50
-rw-r--r--kernel/retroknowledge.ml9
-rw-r--r--kernel/retroknowledge.mli32
-rw-r--r--kernel/safe_typing.ml578
-rw-r--r--kernel/safe_typing.mli59
-rw-r--r--kernel/sign.ml12
-rw-r--r--kernel/sign.mli36
-rw-r--r--kernel/subtyping.ml168
-rw-r--r--kernel/subtyping.mli6
-rw-r--r--kernel/term.ml727
-rw-r--r--kernel/term.mli390
-rw-r--r--kernel/term_typing.ml84
-rw-r--r--kernel/term_typing.mli14
-rw-r--r--kernel/type_errors.ml13
-rw-r--r--kernel/type_errors.mli19
-rw-r--r--kernel/typeops.ml60
-rw-r--r--kernel/typeops.mli42
-rw-r--r--kernel/univ.ml570
-rw-r--r--kernel/univ.mli68
-rw-r--r--kernel/vconv.ml12
-rw-r--r--kernel/vconv.mli8
-rw-r--r--kernel/vm.ml64
-rw-r--r--kernel/vm.mli43
65 files changed, 3822 insertions, 3256 deletions
diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c
index a0cb4f1a..aab08d89 100644
--- a/kernel/byterun/coq_interp.c
+++ b/kernel/byterun/coq_interp.c
@@ -81,13 +81,6 @@ sp is a local copy of the global variable extern_sp. */
# define print_int(i)
#endif
-/* Wrapper pour caml_modify */
-#ifdef OCAML_307
-#define CAML_MODIFY(a,b) modify(a,b)
-#else
-#define CAML_MODIFY(a,b) caml_modify(a,b)
-#endif
-
/* GC interface */
#define Setup_for_gc { sp -= 2; sp[0] = accu; sp[1] = coq_env; coq_sp = sp; }
#define Restore_after_gc { accu = sp[0]; coq_env = sp[1]; sp += 2; }
@@ -158,7 +151,7 @@ sp is a local copy of the global variable extern_sp. */
#endif
#endif
-/* For signal handling, we highjack some code from the caml runtime */
+/* For signal handling, we hijack some code from the caml runtime */
extern intnat caml_signals_are_pending;
extern intnat caml_pending_signals[];
@@ -671,7 +664,7 @@ value coq_interprete
Field(accu, 0) = sp[0];
*sp = accu;
/* mise a jour du block accumulate */
- CAML_MODIFY(&Field(p[i], 1),*sp);
+ caml_modify(&Field(p[i], 1),*sp);
sp++;
}
pc += nfunc;
@@ -842,7 +835,7 @@ value coq_interprete
Instruct(SETFIELD0){
print_instr("SETFIELD0");
- CAML_MODIFY(&Field(accu, 0),*sp);
+ caml_modify(&Field(accu, 0),*sp);
sp++;
Next;
}
@@ -850,7 +843,7 @@ value coq_interprete
Instruct(SETFIELD1){
int i, j, size, size_aux;
print_instr("SETFIELD1");
- CAML_MODIFY(&Field(accu, 1),*sp);
+ caml_modify(&Field(accu, 1),*sp);
sp++;
Next;
}
@@ -868,9 +861,9 @@ value coq_interprete
*sp = accu;
Alloc_small(accu, 1, ATOM_COFIX_TAG);
Field(accu, 0) = Field(Field(*sp, 1), 0);
- CAML_MODIFY(&Field(*sp, 1), accu);
+ caml_modify(&Field(*sp, 1), accu);
accu = *sp; sp++;
- CAML_MODIFY(&Field(*sp, i), accu);
+ caml_modify(&Field(*sp, i), accu);
}
}
sp++;
@@ -879,7 +872,7 @@ value coq_interprete
Instruct(SETFIELD){
print_instr("SETFIELD");
- CAML_MODIFY(&Field(accu, *pc),*sp);
+ caml_modify(&Field(accu, *pc),*sp);
sp++; pc++;
Next;
}
diff --git a/kernel/byterun/coq_memory.c b/kernel/byterun/coq_memory.c
index 91342108..00f5eb3b 100644
--- a/kernel/byterun/coq_memory.c
+++ b/kernel/byterun/coq_memory.c
@@ -50,12 +50,6 @@ value coq_static_alloc(value size) /* ML */
return (value) coq_stat_alloc((asize_t) Long_val(size));
}
-value coq_static_free(value blk) /* ML */
-{
- coq_stat_free((void *) blk);
- return Val_unit;
-}
-
value accumulate_code(value unit) /* ML */
{
return (value) accumulate;
diff --git a/kernel/byterun/coq_memory.h b/kernel/byterun/coq_memory.h
index c0093a49..79e4d0fe 100644
--- a/kernel/byterun/coq_memory.h
+++ b/kernel/byterun/coq_memory.h
@@ -49,7 +49,6 @@ extern code_t accumulate;
/* functions over global environment */
value coq_static_alloc(value size); /* ML */
-value coq_static_free(value string); /* ML */
value init_coq_vm(value unit); /* ML */
value re_init_coq_vm(value unit); /* ML */
diff --git a/kernel/byterun/int64_emul.h b/kernel/byterun/int64_emul.h
index 0a61ad79..86bee72e 100644
--- a/kernel/byterun/int64_emul.h
+++ b/kernel/byterun/int64_emul.h
@@ -11,8 +11,6 @@
/* */
/***********************************************************************/
-/* $Id: int64_emul.h 10739 2008-04-01 14:45:20Z herbelin $ */
-
/* Software emulation of 64-bit integer arithmetic, for C compilers
that do not support it. */
diff --git a/kernel/byterun/int64_native.h b/kernel/byterun/int64_native.h
index 4fc3c220..8a6a2664 100644
--- a/kernel/byterun/int64_native.h
+++ b/kernel/byterun/int64_native.h
@@ -11,8 +11,6 @@
/* */
/***********************************************************************/
-/* $Id: int64_native.h 10739 2008-04-01 14:45:20Z herbelin $ */
-
/* Wrapper macros around native 64-bit integer arithmetic,
so that it has the same interface as the software emulation
provided in int64_emul.h */
diff --git a/kernel/cbytecodes.ml b/kernel/cbytecodes.ml
index f4d0bb2b..8854f854 100644
--- a/kernel/cbytecodes.ml
+++ b/kernel/cbytecodes.ml
@@ -1,3 +1,17 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* Created by Bruno Barras for Benjamin Grégoire as part of the
+ bytecode-based reduction machine, Oct 2004 *)
+(* Support for native arithmetics by Arnaud Spiwack, May 2007 *)
+
+(* This file defines the type of bytecode instructions *)
+
open Names
open Term
diff --git a/kernel/cbytecodes.mli b/kernel/cbytecodes.mli
index f4dc0b14..c5d483ac 100644
--- a/kernel/cbytecodes.mli
+++ b/kernel/cbytecodes.mli
@@ -1,3 +1,13 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id: cbytecodes.mli 13323 2010-07-24 15:57:30Z herbelin $ *)
+
open Names
open Term
@@ -38,42 +48,43 @@ type instruction =
| Kpush
| Kpop of int
| Kpush_retaddr of Label.t
- | Kapply of int (* number of arguments *)
- | Kappterm of int * int (* number of arguments, slot size *)
- | Kreturn of int (* slot size *)
+ | Kapply of int (** number of arguments *)
+ | Kappterm of int * int (** number of arguments, slot size *)
+ | Kreturn of int (** slot size *)
| Kjump
| Krestart
- | Kgrab of int (* number of arguments *)
- | Kgrabrec of int (* rec arg *)
- | Kclosure of Label.t * int (* label, number of free variables *)
+ | Kgrab of int (** number of arguments *)
+ | Kgrabrec of int (** rec arg *)
+ | Kclosure of Label.t * int (** label, number of free variables *)
| Kclosurerec of int * int * Label.t array * Label.t array
- (* nb fv, init, lbl types, lbl bodies *)
+ (** nb fv, init, lbl types, lbl bodies *)
| Kclosurecofix of int * int * Label.t array * Label.t array
- (* nb fv, init, lbl types, lbl bodies *)
+ (** nb fv, init, lbl types, lbl bodies *)
| Kgetglobal of constant
| Kconst of structured_constant
- | Kmakeblock of int * tag (* size, tag *)
+ | Kmakeblock of int * tag (** size, tag *)
| Kmakeprod
| Kmakeswitchblock of Label.t * Label.t * annot_switch * int
- | Kswitch of Label.t array * Label.t array (* consts,blocks *)
+ | Kswitch of Label.t array * Label.t array (** consts,blocks *)
| Kpushfields of int
| Kfield of int
| Ksetfield of int
| Kstop
| Ksequence of bytecodes * bytecodes
-(* spiwack: instructions concerning integers *)
- | Kbranch of Label.t (* jump to label, is it needed ? *)
- | Kaddint31 (* adds the int31 in the accu
+
+(** spiwack: instructions concerning integers *)
+ | Kbranch of Label.t (** jump to label, is it needed ? *)
+ | Kaddint31 (** adds the int31 in the accu
and the one ontop of the stack *)
- | Kaddcint31 (* makes the sum and keeps the carry *)
- | Kaddcarrycint31 (* sum +1, keeps the carry *)
- | Ksubint31 (* subtraction modulo *)
- | Ksubcint31 (* subtraction, keeps the carry *)
- | Ksubcarrycint31 (* subtraction -1, keeps the carry *)
- | Kmulint31 (* multiplication modulo *)
- | Kmulcint31 (* multiplication, result in two
+ | Kaddcint31 (** makes the sum and keeps the carry *)
+ | Kaddcarrycint31 (** sum +1, keeps the carry *)
+ | Ksubint31 (** subtraction modulo *)
+ | Ksubcint31 (** subtraction, keeps the carry *)
+ | Ksubcarrycint31 (** subtraction -1, keeps the carry *)
+ | Kmulint31 (** multiplication modulo *)
+ | Kmulcint31 (** multiplication, result in two
int31, for exact computation *)
- | Kdiv21int31 (* divides a double size integer
+ | Kdiv21int31 (** divides a double size integer
(represented by an int31 in the
accumulator and one on the top of
the stack) by an int31. The result
@@ -81,23 +92,23 @@ type instruction =
rest.
If the divisor is 0, it returns
0. *)
- | Kdivint31 (* euclidian division (returns a pair
+ | Kdivint31 (** euclidian division (returns a pair
quotient,rest) *)
- | Kaddmuldivint31 (* generic operation for shifting and
+ | Kaddmuldivint31 (** generic operation for shifting and
cycling. Takes 3 int31 i j and s,
and returns x*2^s+y/(2^(31-s) *)
- | Kcompareint31 (* unsigned comparison of int31
+ | Kcompareint31 (** unsigned comparison of int31
cf COMPAREINT31 in
kernel/byterun/coq_interp.c
for more info *)
- | Khead0int31 (* Give the numbers of 0 in head of a in31*)
- | Ktail0int31 (* Give the numbers of 0 in tail of a in31
+ | Khead0int31 (** Give the numbers of 0 in head of a in31*)
+ | Ktail0int31 (** Give the numbers of 0 in tail of a in31
ie low bits *)
- | Kisconst of Label.t (* conditional jump *)
- | Kareconst of int*Label.t (* conditional jump *)
- | Kcompint31 (* dynamic compilation of int31 *)
- | Kdecompint31 (* dynamix decompilation of int31 *)
-(* /spiwack *)
+ | Kisconst of Label.t (** conditional jump *)
+ | Kareconst of int*Label.t (** conditional jump *)
+ | Kcompint31 (** dynamic compilation of int31 *)
+ | Kdecompint31 (** dynamix decompilation of int31
+ /spiwack *)
and bytecodes = instruction list
@@ -107,25 +118,25 @@ type fv_elem = FVnamed of identifier | FVrel of int
type fv = fv_elem array
-(* spiwack: this exception is expected to be raised by function expecting
+(** spiwack: this exception is expected to be raised by function expecting
closed terms. *)
exception NotClosed
(*spiwack: both type have been moved from Cbytegen because I needed then
for the retroknowledge *)
type vm_env = {
- size : int; (* longueur de la liste [n] *)
- fv_rev : fv_elem list (* [fvn; ... ;fv1] *)
+ size : int; (** longueur de la liste [n] *)
+ fv_rev : fv_elem list (** [fvn; ... ;fv1] *)
}
type comp_env = {
- nb_stack : int; (* nbre de variables sur la pile *)
- in_stack : int list; (* position dans la pile *)
- nb_rec : int; (* nbre de fonctions mutuellement *)
- (* recursives = nbr *)
- pos_rec : instruction list; (* instruction d'acces pour les variables *)
- (* de point fix ou de cofix *)
+ nb_stack : int; (** nbre de variables sur la pile *)
+ in_stack : int list; (** position dans la pile *)
+ nb_rec : int; (** nbre de fonctions mutuellement *)
+ (** recursives = nbr *)
+ pos_rec : instruction list; (** instruction d'acces pour les variables *)
+ (** de point fix ou de cofix *)
offset : int;
in_env : vm_env ref
}
@@ -140,7 +151,7 @@ type block =
| Bstrconst of structured_constant
| Bmakeblock of int * block array
| Bconstruct_app of int * int * int * block array
- (* tag , nparams, arity *)
+ (** tag , nparams, arity *)
| Bspecial of (comp_env -> block array -> int -> bytecodes -> bytecodes) * block array
- (* compilation function (see get_vm_constant_dynamic_info in
+ (** compilation function (see get_vm_constant_dynamic_info in
retroknowledge.mli for more info) , argument array *)
diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml
index 0578c7b4..8da06f43 100644
--- a/kernel/cbytegen.ml
+++ b/kernel/cbytegen.ml
@@ -1,3 +1,15 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* Author: Benjamin Grégoire as part of the bytecode-based virtual reduction
+ machine, Oct 2004 *)
+(* Extension: Arnaud Spiwack (support for native arithmetic), May 2005 *)
+
open Util
open Names
open Cbytecodes
@@ -339,7 +351,7 @@ let rec str_const c =
| App(f,args) ->
begin
match kind_of_term f with
- | Construct((kn,j),i) -> (* arnaud: Construct(((kn,j),i) as cstr) -> *)
+ | Construct((kn,j),i) ->
begin
let oib = lookup_mind kn !global_env in
let oip = oib.mind_packets.(j) in
@@ -409,7 +421,7 @@ let rec str_const c =
| _ -> Bconstr c
end
| Ind ind -> Bstrconst (Const_ind ind)
- | Construct ((kn,j),i) -> (*arnaud: Construct ((kn,j),i as cstr) -> *)
+ | Construct ((kn,j),i) ->
begin
(* spiwack: tries first to apply the run-time compilation
behavior of the constructor, as in 2/ above *)
@@ -668,19 +680,6 @@ and compile_str_cst reloc sc sz cont =
(* spiwack : compilation of constants with their arguments.
Makes a special treatment with 31-bit integer addition *)
and compile_const =
-(*arnaud: let code_construct kn cont =
- let f_cont =
- let else_lbl = Label.create () in
- Kareconst(2, else_lbl):: Kacc 0:: Kpop 1::
- Kaddint31:: Kreturn 0:: Klabel else_lbl::
- (* works as comp_app with nargs = 2 and tailcall cont [Kreturn 0]*)
- Kgetglobal (get_allias !global_env kn)::
- Kappterm(2, 2):: [] (* = discard_dead_code [Kreturn 0] *)
- in
- let lbl = Label.create () in
- fun_code := [Ksequence (add_grab 2 lbl f_cont, !fun_code)];
- Kclosure(lbl, 0)::cont
- in *)
fun reloc-> fun kn -> fun args -> fun sz -> fun cont ->
let nargs = Array.length args in
(* spiwack: checks if there is a specific way to compile the constant
@@ -715,18 +714,11 @@ let compile env c =
Format.print_flush(); *)
init_code,!fun_code, Array.of_list fv
-let compile_constant_body env body opaque boxed =
- if opaque then BCconstant
- else match body with
- | None -> BCconstant
- | Some sb ->
+let compile_constant_body env = function
+ | Undef _ | OpaqueDef _ -> BCconstant
+ | Def sb ->
let body = Declarations.force sb in
- if boxed then
- let res = compile env body in
- let to_patch = to_memory res in
- BCdefined(true, to_patch)
- else
- match kind_of_term body with
+ match kind_of_term body with
| Const kn' ->
(* we use the canonical name of the constant*)
let con= constant_of_kn (canonical_con kn') in
@@ -734,8 +726,11 @@ let compile_constant_body env body opaque boxed =
| _ ->
let res = compile env body in
let to_patch = to_memory res in
- BCdefined (false, to_patch)
+ BCdefined to_patch
+
+(* Shortcut of the previous function used during module strengthening *)
+let compile_alias kn = BCallias (constant_of_kn (canonical_con kn))
(* spiwack: additional function which allow different part of compilation of the
31-bit integers *)
diff --git a/kernel/cbytegen.mli b/kernel/cbytegen.mli
index f33fd6cb..d0bfd46c 100644
--- a/kernel/cbytegen.mli
+++ b/kernel/cbytegen.mli
@@ -7,20 +7,21 @@ open Pre_env
val compile : env -> constr -> bytecodes * bytecodes * fv
- (* init, fun, fv *)
+ (** init, fun, fv *)
-val compile_constant_body :
- env -> constr_substituted option -> bool -> bool -> body_code
- (* opaque *) (* boxed *)
+val compile_constant_body : env -> constant_def -> body_code
+(** Shortcut of the previous function used during module strengthening *)
-(* spiwack: this function contains the information needed to perform
+val compile_alias : constant -> body_code
+
+(** spiwack: this function contains the information needed to perform
the static compilation of int31 (trying and obtaining
a 31-bit integer in processor representation at compile time) *)
val compile_structured_int31 : bool -> constr array ->
structured_constant
-(* this function contains the information needed to perform
+(** this function contains the information needed to perform
the dynamic compilation of int31 (trying and obtaining a
31-bit integer in processor representation at runtime when
it failed at compile time *)
diff --git a/kernel/cemitcodes.ml b/kernel/cemitcodes.ml
index 0b4df194..1f00a70e 100644
--- a/kernel/cemitcodes.ml
+++ b/kernel/cemitcodes.ml
@@ -1,3 +1,15 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* Author: Benjamin Grégoire as part of the bytecode-based virtual reduction
+ machine, Oct 2004 *)
+(* Extension: Arnaud Spiwack (support for native arithmetic), May 2005 *)
+
open Names
open Term
open Cbytecodes
@@ -321,12 +333,12 @@ let subst_to_patch s (code,pl,fv) =
code,List.rev_map (subst_patch s) pl,fv
type body_code =
- | BCdefined of bool * to_patch
+ | BCdefined of to_patch
| BCallias of constant
| BCconstant
let subst_body_code s = function
- | BCdefined (b,tp) -> BCdefined (b,subst_to_patch s tp)
+ | BCdefined tp -> BCdefined (subst_to_patch s tp)
| BCallias kn -> BCallias (fst (subst_con s kn))
| BCconstant -> BCconstant
@@ -338,11 +350,6 @@ let force = force subst_body_code
let subst_to_patch_subst = subst_substituted
-let is_boxed tps =
- match force tps with
- | BCdefined(b,_) -> b
- | _ -> false
-
let repr_body_code = repr_substituted
let to_memory (init_code, fun_code, fv) =
diff --git a/kernel/cemitcodes.mli b/kernel/cemitcodes.mli
index 384146d2..287c3930 100644
--- a/kernel/cemitcodes.mli
+++ b/kernel/cemitcodes.mli
@@ -7,6 +7,7 @@ type reloc_info =
| Reloc_getglobal of constant
type patch = reloc_info * int
+
(* A virer *)
val subst_patch : Mod_subst.substitution -> patch -> patch
@@ -23,7 +24,7 @@ type to_patch = emitcodes * (patch list) * fv
val subst_to_patch : Mod_subst.substitution -> to_patch -> to_patch
type body_code =
- | BCdefined of bool*to_patch
+ | BCdefined of to_patch
| BCallias of constant
| BCconstant
@@ -34,12 +35,10 @@ val from_val : body_code -> to_patch_substituted
val force : to_patch_substituted -> body_code
-val is_boxed : to_patch_substituted -> bool
-
val subst_to_patch_subst : Mod_subst.substitution -> to_patch_substituted -> to_patch_substituted
val repr_body_code :
to_patch_substituted -> Mod_subst.substitution list option * body_code
val to_memory : bytecodes * bytecodes * fv -> to_patch
- (* init code, fun code, fv *)
+ (** init code, fun code, fv *)
diff --git a/kernel/closure.ml b/kernel/closure.ml
index bb68835e..143d6eb4 100644
--- a/kernel/closure.ml
+++ b/kernel/closure.ml
@@ -1,12 +1,23 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: closure.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
+(* Created by Bruno Barras with Benjamin Werner's account to implement
+ a call-by-value conversion algorithm and a lazy reduction machine
+ with sharing, Nov 1996 *)
+(* Addition of zeta-reduction (let-in contraction) by Hugo Herbelin, Oct 2000 *)
+(* Call-by-value machine moved to cbv.ml, Mar 01 *)
+(* Additional tools for module subtyping by Jacek Chrzaszcz, Aug 2002 *)
+(* Extension with closure optimization by Bruno Barras, Aug 2003 *)
+(* Support for evar reduction by Bruno Barras, Feb 2009 *)
+(* Miscellaneous other improvements by Bruno Barras, 1997-2009 *)
+
+(* This file implements a lazy reduction for the Calculus of Inductive
+ Constructions *)
open Util
open Pp
@@ -55,6 +66,9 @@ let with_stats c =
let all_opaque = (Idpred.empty, Cpred.empty)
let all_transparent = (Idpred.full, Cpred.full)
+let is_transparent_variable (ids, _) id = Idpred.mem id ids
+let is_transparent_constant (_, csts) cst = Cpred.mem cst csts
+
module type RedFlagsSig = sig
type reds
type red_kind
@@ -70,7 +84,6 @@ module type RedFlagsSig = sig
val red_add_transparent : reds -> transparent_state -> reds
val mkflags : red_kind list -> reds
val red_set : reds -> red_kind -> bool
- val red_get_const : reds -> bool * evaluable_global_reference list
end
module RedFlags = (struct
@@ -145,16 +158,6 @@ module RedFlags = (struct
| DELTA -> (* Used for Rel/Var defined in context *)
incr_cnt red.r_delta delta
- let red_get_const red =
- let p1,p2 = red.r_const in
- let (b1,l1) = Idpred.elements p1 in
- let (b2,l2) = Cpred.elements p2 in
- if b1=b2 then
- let l1' = List.map (fun x -> EvalVarRef x) l1 in
- let l2' = List.map (fun x -> EvalConstRef x) l2 in
- (b1, l1' @ l2')
- else error "unrepresentable pair of predicate"
-
end : RedFlagsSig)
open RedFlags
@@ -511,7 +514,7 @@ let optimise_closure env c =
let (c',(_,s)) = compact_constr (0,[]) c 1 in
let env' =
Array.map (fun i -> clos_rel env i) (Array.of_list s) in
- (subs_cons (env', ESID 0),c')
+ (subs_cons (env', subs_id 0),c')
let mk_lambda env t =
let (env,t) = optimise_closure env t in
@@ -644,7 +647,7 @@ let term_of_fconstr =
| FFix(fx,e) when is_subs_id e & is_lift_id lfts -> mkFix fx
| FCoFix(cfx,e) when is_subs_id e & is_lift_id lfts -> mkCoFix cfx
| _ -> to_constr term_of_fconstr_lift lfts v in
- term_of_fconstr_lift ELID
+ term_of_fconstr_lift el_id
@@ -679,16 +682,6 @@ let fapp_stack (m,stk) = zip m stk
(strip_update_shift, through get_arg). *)
(* optimised for the case where there are no shifts... *)
-let strip_update_shift head stk =
- assert (head.norm <> Red);
- let rec strip_rec h depth = function
- | Zshift(k)::s -> strip_rec (lift_fconstr k h) (depth+k) s
- | Zupdate(m)::s ->
- strip_rec (update m (h.norm,h.term)) depth s
- | stk -> (depth,stk) in
- strip_rec head 0 stk
-
-(* optimised for the case where there are no shifts... *)
let strip_update_shift_app head stk =
assert (head.norm <> Red);
let rec strip_rec rstk h depth = function
@@ -705,15 +698,14 @@ let strip_update_shift_app head stk =
let get_nth_arg head n stk =
assert (head.norm <> Red);
- let rec strip_rec rstk h depth n = function
+ let rec strip_rec rstk h n = function
| Zshift(k) as e :: s ->
- strip_rec (e::rstk) (lift_fconstr k h) (depth+k) n s
+ strip_rec (e::rstk) (lift_fconstr k h) n s
| Zapp args::s' ->
let q = Array.length args in
if n >= q
then
- strip_rec (Zapp args::rstk)
- {norm=h.norm;term=FApp(h,args)} depth (n-q) s'
+ strip_rec (Zapp args::rstk) {norm=h.norm;term=FApp(h,args)} (n-q) s'
else
let bef = Array.sub args 0 n in
let aft = Array.sub args (n+1) (q-n-1) in
@@ -721,9 +713,9 @@ let get_nth_arg head n stk =
List.rev (if n = 0 then rstk else (Zapp bef :: rstk)) in
(Some (stk', args.(n)), append_stack aft s')
| Zupdate(m)::s ->
- strip_rec rstk (update m (h.norm,h.term)) depth n s
+ strip_rec rstk (update m (h.norm,h.term)) n s
| s -> (None, List.rev rstk @ s) in
- strip_rec [] head 0 n stk
+ strip_rec [] head n stk
(* Beta reduction: look for an applied argument in the stack.
Since the encountered update marks are removed, h must be a whnf *)
@@ -746,6 +738,12 @@ let rec get_args n tys f e stk =
get_args (n-na) etys f (subs_cons(l,e)) s
| _ -> (Inr {norm=Cstr;term=FLambda(n,tys,f,e)}, stk)
+(* Eta expansion: add a reference to implicit surrounding lambda at end of stack *)
+let rec eta_expand_stack = function
+ | (Zapp _ | Zfix _ | Zcase _ | Zshift _ | Zupdate _ as e) :: s ->
+ e :: eta_expand_stack s
+ | [] ->
+ [Zshift 1; Zapp [|{norm=Norm; term= FRel 1}|]]
(* Iota reduction: extract the arguments to be passed to the Case
branches *)
@@ -965,7 +963,7 @@ let whd_val info v =
let norm_val info v =
with_stats (lazy (kl info v))
-let inject = mk_clos (ESID 0)
+let inject = mk_clos (subs_id 0)
let whd_stack infos m stk =
let k = kni infos m stk in
diff --git a/kernel/closure.mli b/kernel/closure.mli
index 9cfd9797..f4dc5db3 100644
--- a/kernel/closure.mli
+++ b/kernel/closure.mli
@@ -1,28 +1,25 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: closure.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
open Pp
open Names
open Term
open Environ
open Esubst
-(*i*)
-(* Flags for profiling reductions. *)
+(** Flags for profiling reductions. *)
val stats : bool ref
val share : bool ref
val with_stats: 'a Lazy.t -> 'a
-(*s Delta implies all consts (both global (= by
+(** {6 ... } *)
+(** Delta implies all consts (both global (= by
[kernel_name]) and local (= by [Rel] or [Var])), all evars, and letin's.
Rem: reduction of a Rel/Var bound to a term is Delta, but reduction of
a LetIn expression is Letin reduction *)
@@ -32,12 +29,15 @@ val with_stats: 'a Lazy.t -> 'a
val all_opaque : transparent_state
val all_transparent : transparent_state
-(* Sets of reduction kinds. *)
+val is_transparent_variable : transparent_state -> variable -> bool
+val is_transparent_constant : transparent_state -> constant -> bool
+
+(** Sets of reduction kinds. *)
module type RedFlagsSig = sig
type reds
type red_kind
- (* The different kinds of reduction *)
+ (** The different kinds of reduction *)
val fBETA : red_kind
val fDELTA : red_kind
val fIOTA : red_kind
@@ -45,26 +45,24 @@ module type RedFlagsSig = sig
val fCONST : constant -> red_kind
val fVAR : identifier -> red_kind
- (* No reduction at all *)
+ (** No reduction at all *)
val no_red : reds
- (* Adds a reduction kind to a set *)
+ (** Adds a reduction kind to a set *)
val red_add : reds -> red_kind -> reds
- (* Removes a reduction kind to a set *)
+ (** Removes a reduction kind to a set *)
val red_sub : reds -> red_kind -> reds
- (* Adds a reduction kind to a set *)
+ (** Adds a reduction kind to a set *)
val red_add_transparent : reds -> transparent_state -> reds
- (* Build a reduction set from scratch = iter [red_add] on [no_red] *)
+ (** Build a reduction set from scratch = iter [red_add] on [no_red] *)
val mkflags : red_kind list -> reds
- (* Tests if a reduction kind is set *)
+ (** Tests if a reduction kind is set *)
val red_set : reds -> red_kind -> bool
- (* Gives the constant list *)
- val red_get_const : reds -> bool * evaluable_global_reference list
end
module RedFlags : RedFlagsSig
@@ -89,19 +87,19 @@ val create: ('a infos -> constr -> 'a) -> reds -> env ->
(existential -> constr option) -> 'a infos
val evar_value : 'a infos -> existential -> constr option
-(************************************************************************)
-(*s Lazy reduction. *)
+(***********************************************************************
+ s Lazy reduction. *)
-(* [fconstr] is the type of frozen constr *)
+(** [fconstr] is the type of frozen constr *)
type fconstr
-(* [fconstr] can be accessed by using the function [fterm_of] and by
+(** [fconstr] can be accessed by using the function [fterm_of] and by
matching on type [fterm] *)
type fterm =
| FRel of int
- | FAtom of constr (* Metas and Sorts *)
+ | FAtom of constr (** Metas and Sorts *)
| FCast of fconstr * cast_kind * fconstr
| FFlex of table_key
| FInd of inductive
@@ -118,8 +116,8 @@ type fterm =
| FCLOS of constr * fconstr subs
| FLOCKED
-(************************************************************************)
-(*s A [stack] is a context of arguments, arguments are pushed by
+(***********************************************************************
+ s A [stack] is a context of arguments, arguments are pushed by
[append_stack] one array at a time but popped with [decomp_stack]
one by one *)
@@ -142,13 +140,15 @@ val stack_args_size : stack -> int
val stack_tail : int -> stack -> stack
val stack_nth : stack -> int -> fconstr
val zip_term : (fconstr -> constr) -> constr -> stack -> constr
+val eta_expand_stack : stack -> stack
-(* To lazy reduce a constr, create a [clos_infos] with
+(** To lazy reduce a constr, create a [clos_infos] with
[create_clos_infos], inject the term to reduce with [inject]; then use
a reduction function *)
val inject : constr -> fconstr
-(* mk_atom: prevents a term from being evaluated *)
+
+(** mk_atom: prevents a term from being evaluated *)
val mk_atom : constr -> fconstr
val fterm_of : fconstr -> fterm
@@ -156,33 +156,33 @@ val term_of_fconstr : fconstr -> constr
val destFLambda :
(fconstr subs -> constr -> fconstr) -> fconstr -> name * fconstr * fconstr
-(* Global and local constant cache *)
+(** Global and local constant cache *)
type clos_infos
val create_clos_infos :
?evars:(existential->constr option) -> reds -> env -> clos_infos
-(* Reduction function *)
+(** Reduction function *)
-(* [norm_val] is for strong normalization *)
+(** [norm_val] is for strong normalization *)
val norm_val : clos_infos -> fconstr -> constr
-(* [whd_val] is for weak head normalization *)
+(** [whd_val] is for weak head normalization *)
val whd_val : clos_infos -> fconstr -> constr
-(* [whd_stack] performs weak head normalization in a given stack. It
+(** [whd_stack] performs weak head normalization in a given stack. It
stops whenever a reduction is blocked. *)
val whd_stack :
clos_infos -> fconstr -> stack -> fconstr * stack
-(* Conversion auxiliary functions to do step by step normalisation *)
+(** Conversion auxiliary functions to do step by step normalisation *)
-(* [unfold_reference] unfolds references in a [fconstr] *)
+(** [unfold_reference] unfolds references in a [fconstr] *)
val unfold_reference : clos_infos -> table_key -> fconstr option
val eq_table_key : table_key -> table_key -> bool
-(************************************************************************)
-(*i This is for lazy debug *)
+(***********************************************************************
+ i This is for lazy debug *)
val lift_fconstr : int -> fconstr -> fconstr
val lift_fconstr_vect : int -> fconstr array -> fconstr array
@@ -200,4 +200,4 @@ val kl : clos_infos -> fconstr -> constr
val to_constr : (lift -> fconstr -> constr) -> lift -> fconstr -> constr
val optimise_closure : fconstr subs -> constr -> fconstr subs * constr
-(* End of cbn debug section i*)
+(** End of cbn debug section i*)
diff --git a/kernel/conv_oracle.ml b/kernel/conv_oracle.ml
index 3f6b77b0..92109258 100644
--- a/kernel/conv_oracle.ml
+++ b/kernel/conv_oracle.ml
@@ -1,12 +1,13 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: conv_oracle.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
+(* Created by Bruno Barras as part of the rewriting of the conversion
+ algorithm, Nov 2001 *)
open Names
@@ -55,12 +56,12 @@ let get_transp_state () =
(* Unfold the first constant only if it is "more transparent" than the
second one. In case of tie, expand the second one. *)
-let oracle_order k1 k2 =
+let oracle_order l2r k1 k2 =
match get_strategy k1, get_strategy k2 with
| Expand, _ -> true
| Level n1, Opaque -> true
| Level n1, Level n2 -> n1 < n2
- | _ -> false (* expand k2 *)
+ | _ -> l2r (* use recommended default *)
(* summary operations *)
let init() = (cst_opacity := Cmap.empty; var_opacity := Idmap.empty)
diff --git a/kernel/conv_oracle.mli b/kernel/conv_oracle.mli
index 9272dfe5..09ca4b92 100644
--- a/kernel/conv_oracle.mli
+++ b/kernel/conv_oracle.mli
@@ -1,22 +1,20 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: conv_oracle.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
open Names
-(* Order on section paths for unfolding.
+(** Order on section paths for unfolding.
If [oracle_order kn1 kn2] is true, then unfold kn1 first.
Note: the oracle does not introduce incompleteness, it only
tries to postpone unfolding of "opaque" constants. *)
-val oracle_order : 'a tableKey -> 'a tableKey -> bool
+val oracle_order : bool -> 'a tableKey -> 'a tableKey -> bool
-(* Priority for the expansion of constant in the conversion test.
+(** Priority for the expansion of constant in the conversion test.
* Higher levels means that the expansion is less prioritary.
* (And Expand stands for -oo, and Opaque +oo.)
* The default value (transparent constants) is [Level 0].
@@ -26,14 +24,14 @@ val transparent : level
val get_strategy : 'a tableKey -> level
-(* Sets the level of a constant.
+(** Sets the level of a constant.
* Level of RelKey constant cannot be set. *)
val set_strategy : 'a tableKey -> level -> unit
val get_transp_state : unit -> transparent_state
-(*****************************)
-(* Summary operations *)
+(****************************
+ Summary operations *)
type oracle
val init : unit -> unit
val freeze : unit -> oracle
diff --git a/kernel/cooking.ml b/kernel/cooking.ml
index d35c011a..02330339 100644
--- a/kernel/cooking.ml
+++ b/kernel/cooking.ml
@@ -1,12 +1,17 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: cooking.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
+(* Created by Jean-Christophe Filliâtre out of V6.3 file constants.ml
+ as part of the rebuilding of Coq around a purely functional
+ abstract type-checker, Nov 1999 *)
+
+(* This module implements kernel-level discharching of local
+ declarations over global constants and inductive types *)
open Pp
open Util
@@ -99,7 +104,7 @@ let expmod_constr modlist c =
in
if modlist = empty_modlist then c
- else under_outer_cast nf_betaiota (substrec c)
+ else substrec c
let abstract_constant_type =
List.fold_left (fun c d -> mkNamedProd_wo_LetIn d c)
@@ -112,16 +117,24 @@ type recipe = {
d_abstract : named_context;
d_modlist : work_list }
-let on_body f =
- Option.map (fun c -> Declarations.from_val (f (Declarations.force c)))
+let on_body f = function
+ | Undef inl -> Undef inl
+ | Def cs -> Def (Declarations.from_val (f (Declarations.force cs)))
+ | OpaqueDef lc ->
+ OpaqueDef (Declarations.opaque_from_val (f (Declarations.force_opaque lc)))
+
+let constr_of_def = function
+ | Undef _ -> assert false
+ | Def cs -> Declarations.force cs
+ | OpaqueDef lc -> Declarations.force_opaque lc
let cook_constant env r =
let cb = r.d_from in
let hyps = Sign.map_named_context (expmod_constr r.d_modlist) r.d_abstract in
- let body =
- on_body (fun c ->
- abstract_constant_body (expmod_constr r.d_modlist c) hyps)
- cb.const_body in
+ let body = on_body
+ (fun c -> abstract_constant_body (expmod_constr r.d_modlist c) hyps)
+ cb.const_body
+ in
let typ = match cb.const_type with
| NonPolymorphicType t ->
let typ = abstract_constant_type (expmod_constr r.d_modlist t) hyps in
@@ -129,8 +142,7 @@ let cook_constant env r =
| PolymorphicArity (ctx,s) ->
let t = mkArity (ctx,Type s.poly_level) in
let typ = abstract_constant_type (expmod_constr r.d_modlist t) hyps in
- let j = make_judge (force (Option.get body)) typ in
+ let j = make_judge (constr_of_def body) typ in
Typeops.make_polymorphic_if_constant_for_ind env j
in
- let boxed = Cemitcodes.is_boxed cb.const_body_code in
- (body, typ, cb.const_constraints, cb.const_opaque, boxed,false)
+ (body, typ, cb.const_constraints)
diff --git a/kernel/cooking.mli b/kernel/cooking.mli
index df7e51f2..5f31ff8c 100644
--- a/kernel/cooking.mli
+++ b/kernel/cooking.mli
@@ -1,20 +1,18 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: cooking.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
open Names
open Term
open Declarations
open Environ
open Univ
-(*s Cooking the constants. *)
+(** {6 Cooking the constants. } *)
type work_list = identifier array Cmap.t * identifier array Mindmap.t
@@ -24,11 +22,10 @@ type recipe = {
d_modlist : work_list }
val cook_constant :
- env -> recipe ->
- constr_substituted option * constant_type * constraints * bool * bool
- * bool
+ env -> recipe -> constant_def * constant_type * constraints
+
-(*s Utility functions used in module [Discharge]. *)
+(** {6 Utility functions used in module [Discharge]. } *)
val expmod_constr : work_list -> constr -> constr
diff --git a/kernel/csymtable.ml b/kernel/csymtable.ml
index 2b3d3fac..e8b66d09 100644
--- a/kernel/csymtable.ml
+++ b/kernel/csymtable.ml
@@ -1,3 +1,17 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* Created by Bruno Barras for Benjamin Grégoire as part of the
+ bytecode-based reduction machine, Oct 2004 *)
+(* Bug fix #1419 by Jean-Marc Notin, Mar 2007 *)
+
+(* This file manages the table of global symbols for the bytecode machine *)
+
open Names
open Term
open Vm
@@ -9,7 +23,6 @@ open Cbytegen
external tcode_of_code : emitcodes -> int -> tcode = "coq_tcode_of_code"
-external free_tcode : tcode -> unit = "coq_static_free"
external eval_tcode : tcode -> values array -> values = "coq_eval_tcode"
(*******************)
@@ -114,10 +127,9 @@ let rec slot_for_getglobal env kn =
(* Pp.msgnl(str"not yet evaluated");*)
let pos =
match Cemitcodes.force cb.const_body_code with
- | BCdefined(boxed,(code,pl,fv)) ->
+ | BCdefined(code,pl,fv) ->
let v = eval_to_patch env (code,pl,fv) in
- if boxed then set_global_boxed kn v
- else set_global v
+ set_global v
| BCallias kn' -> slot_for_getglobal env kn'
| BCconstant -> set_global (val_of_constant kn) in
(*Pp.msgnl(str"value stored at: "++int pos);*)
diff --git a/kernel/csymtable.mli b/kernel/csymtable.mli
index 894a33ef..8c1ad98b 100644
--- a/kernel/csymtable.mli
+++ b/kernel/csymtable.mli
@@ -1,3 +1,13 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id: csymtable.mli 13323 2010-07-24 15:57:30Z herbelin $ *)
+
open Names
open Term
open Pre_env
diff --git a/kernel/declarations.ml b/kernel/declarations.ml
index c18e6bb0..1a84b987 100644
--- a/kernel/declarations.ml
+++ b/kernel/declarations.ml
@@ -1,28 +1,35 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: declarations.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
+(* This file is a late renaming in May 2000 of constant.ml which
+ itself was made for V7.0 in Aug 1999 out of a dispatch by
+ Jean-Christophe Filliâtre of Chet Murthy's constants.ml in V5.10.5
+ into cooking.ml, declare.ml and constant.ml, ...; renaming done
+ because the new contents exceeded in extent what the name
+ suggested *)
+(* Cleaning and lightening of the kernel by Bruno Barras, Nov 2001 *)
+(* Declarations for the module systems added by Jacek Chrzaszcz, Aug 2002 *)
+(* Miscellaneous extensions, cleaning or restructurations by Bruno
+ Barras, Hugo Herbelin, Jean-Christophe Filliâtre, Pierre Letouzey *)
+
+(* This module defines the types of global declarations. This includes
+ global constants/axioms, mutual inductive definitions and the
+ module system *)
-(*i*)
open Util
open Names
open Univ
open Term
open Sign
open Mod_subst
-(*i*)
-
-(* This module defines the types of global declarations. This includes
- global constants/axioms and mutual inductive definitions *)
type engagement = ImpredicativeSet
-
(*s Constants (internal representation) (Definition/Axiom) *)
type polymorphic_arity = {
@@ -42,18 +49,61 @@ let force = force subst_mps
let subst_constr_subst = subst_substituted
+(** Opaque proof terms are not loaded immediately, but are there
+ in a lazy form. Forcing this lazy may trigger some unmarshal of
+ the necessary structure. The ['a substituted] type isn't really great
+ here, so we store "manually" a substitution list, the younger one at top.
+*)
+
+type lazy_constr = constr_substituted Lazy.t * substitution list
+
+let force_lazy_constr (c,l) =
+ List.fold_right subst_constr_subst l (Lazy.force c)
+
+let lazy_constr_is_val (c,_) = Lazy.lazy_is_val c
+
+let make_lazy_constr c = (c, [])
+
+let force_opaque lc = force (force_lazy_constr lc)
+
+let opaque_from_val c = (Lazy.lazy_from_val (from_val c), [])
+
+let subst_lazy_constr sub (c,l) = (c,sub::l)
+
+(** Inlining level of parameters at functor applications.
+ None means no inlining *)
+
+type inline = int option
+
+(** A constant can have no body (axiom/parameter), or a
+ transparent body, or an opaque one *)
+
+type constant_def =
+ | Undef of inline
+ | Def of constr_substituted
+ | OpaqueDef of lazy_constr
+
type constant_body = {
const_hyps : section_context; (* New: younger hyp at top *)
- const_body : constr_substituted option;
+ const_body : constant_def;
const_type : constant_type;
const_body_code : Cemitcodes.to_patch_substituted;
- (* const_type_code : Cemitcodes.to_patch; *)
- const_constraints : constraints;
- const_opaque : bool;
- const_inline : bool}
+ const_constraints : constraints }
-(*s Inductive types (internal representation with redundant
- information). *)
+let body_of_constant cb = match cb.const_body with
+ | Undef _ -> None
+ | Def c -> Some c
+ | OpaqueDef lc -> Some (force_lazy_constr lc)
+
+let constant_has_body cb = match cb.const_body with
+ | Undef _ -> false
+ | Def _ | OpaqueDef _ -> true
+
+let is_opaque cb = match cb.const_body with
+ | OpaqueDef _ -> true
+ | Undef _ | Def _ -> false
+
+(* Substitutions of [constant_body] *)
let subst_rel_declaration sub (id,copt,t as x) =
let copt' = Option.smartmap (subst_mps sub) copt in
@@ -62,13 +112,78 @@ let subst_rel_declaration sub (id,copt,t as x) =
let subst_rel_context sub = list_smartmap (subst_rel_declaration sub)
+(* TODO: these substitution functions could avoid duplicating things
+ when the substitution have preserved all the fields *)
+
+let subst_const_type sub arity =
+ if is_empty_subst sub then arity
+ else match arity with
+ | NonPolymorphicType s -> NonPolymorphicType (subst_mps sub s)
+ | PolymorphicArity (ctx,s) -> PolymorphicArity (subst_rel_context sub ctx,s)
+
+let subst_const_def sub = function
+ | Undef inl -> Undef inl
+ | Def c -> Def (subst_constr_subst sub c)
+ | OpaqueDef lc -> OpaqueDef (subst_lazy_constr sub lc)
+
+let subst_const_body sub cb = {
+ const_hyps = (assert (cb.const_hyps=[]); []);
+ const_body = subst_const_def sub cb.const_body;
+ const_type = subst_const_type sub cb.const_type;
+ const_body_code = Cemitcodes.subst_to_patch_subst sub cb.const_body_code;
+ const_constraints = cb.const_constraints}
+
+(* Hash-consing of [constant_body] *)
+
+let hcons_rel_decl ((n,oc,t) as d) =
+ let n' = hcons_name n
+ and oc' = Option.smartmap hcons_constr oc
+ and t' = hcons_types t
+ in if n' == n && oc' == oc && t' == t then d else (n',oc',t')
+
+let hcons_rel_context l = list_smartmap hcons_rel_decl l
+
+let hcons_polyarity ar =
+ { poly_param_levels =
+ list_smartmap (Option.smartmap hcons_univ) ar.poly_param_levels;
+ poly_level = hcons_univ ar.poly_level }
+
+let hcons_const_type = function
+ | NonPolymorphicType t ->
+ NonPolymorphicType (hcons_constr t)
+ | PolymorphicArity (ctx,s) ->
+ PolymorphicArity (hcons_rel_context ctx, hcons_polyarity s)
+
+let hcons_const_def = function
+ | Undef inl -> Undef inl
+ | Def l_constr ->
+ let constr = force l_constr in
+ Def (from_val (hcons_constr constr))
+ | OpaqueDef lc ->
+ if lazy_constr_is_val lc then
+ let constr = force_opaque lc in
+ OpaqueDef (opaque_from_val (hcons_constr constr))
+ else OpaqueDef lc
+
+let hcons_const_body cb =
+ { cb with
+ const_body = hcons_const_def cb.const_body;
+ const_type = hcons_const_type cb.const_type;
+ const_constraints = hcons_constraints cb.const_constraints }
+
+
+(*s Inductive types (internal representation with redundant
+ information). *)
+
type recarg =
| Norec
- | Mrec of int
+ | Mrec of inductive
| Imbr of inductive
let subst_recarg sub r = match r with
- | Norec | Mrec _ -> r
+ | Norec -> r
+ | Mrec (kn,i) -> let kn' = subst_ind sub kn in
+ if kn==kn' then r else Mrec (kn',i)
| Imbr (kn,i) -> let kn' = subst_ind sub kn in
if kn==kn' then r else Imbr (kn',i)
@@ -82,8 +197,14 @@ let mk_paths r recargs =
let dest_recarg p = fst (Rtree.dest_node p)
+(* dest_subterms returns the sizes of each argument of each constructor of
+ an inductive object of size [p]. This should never be done for Norec,
+ because the number of sons does not correspond to the number of
+ constructors.
+ *)
let dest_subterms p =
- let (_,cstrs) = Rtree.dest_node p in
+ let (ra,cstrs) = Rtree.dest_node p in
+ assert (ra<>Norec);
Array.map (fun t -> Array.to_list (snd (Rtree.dest_node t))) cstrs
let recarg_length p j =
@@ -192,24 +313,7 @@ type mutual_inductive_body = {
}
-let subst_arity sub arity =
- if sub = empty_subst then arity
- else match arity with
- | NonPolymorphicType s -> NonPolymorphicType (subst_mps sub s)
- | PolymorphicArity (ctx,s) -> PolymorphicArity (subst_rel_context sub ctx,s)
-
-(* TODO: should be changed to non-coping after Term.subst_mps *)
-let subst_const_body sub cb = {
- const_hyps = (assert (cb.const_hyps=[]); []);
- const_body = Option.map (subst_constr_subst sub) cb.const_body;
- const_type = subst_arity sub cb.const_type;
- const_body_code = Cemitcodes.subst_to_patch_subst sub cb.const_body_code;
- (*const_type_code = Cemitcodes.subst_to_patch sub cb.const_type_code;*)
- const_constraints = cb.const_constraints;
- const_opaque = cb.const_opaque;
- const_inline = cb.const_inline}
-
-let subst_arity sub = function
+let subst_indarity sub = function
| Monomorphic s ->
Monomorphic {
mind_user_arity = subst_mps sub s.mind_user_arity;
@@ -223,7 +327,7 @@ let subst_mind_packet sub mbp =
mind_typename = mbp.mind_typename;
mind_nf_lc = array_smartmap (subst_mps sub) mbp.mind_nf_lc;
mind_arity_ctxt = subst_rel_context sub mbp.mind_arity_ctxt;
- mind_arity = subst_arity sub mbp.mind_arity;
+ mind_arity = subst_indarity sub mbp.mind_arity;
mind_user_lc = array_smartmap (subst_mps sub) mbp.mind_user_lc;
mind_nrealargs = mbp.mind_nrealargs;
mind_nrealargs_ctxt = mbp.mind_nrealargs_ctxt;
@@ -233,7 +337,6 @@ let subst_mind_packet sub mbp =
mind_nb_args = mbp.mind_nb_args;
mind_reloc_tbl = mbp.mind_reloc_tbl }
-
let subst_mind sub mib =
{ mind_record = mib.mind_record ;
mind_finite = mib.mind_finite ;
@@ -246,6 +349,26 @@ let subst_mind sub mib =
mind_packets = array_smartmap (subst_mind_packet sub) mib.mind_packets ;
mind_constraints = mib.mind_constraints }
+let hcons_indarity = function
+ | Monomorphic a ->
+ Monomorphic { mind_user_arity = hcons_constr a.mind_user_arity;
+ mind_sort = hcons_sorts a.mind_sort }
+ | Polymorphic a -> Polymorphic (hcons_polyarity a)
+
+let hcons_mind_packet oib =
+ { oib with
+ mind_typename = hcons_ident oib.mind_typename;
+ mind_arity_ctxt = hcons_rel_context oib.mind_arity_ctxt;
+ mind_arity = hcons_indarity oib.mind_arity;
+ mind_consnames = array_smartmap hcons_ident oib.mind_consnames;
+ mind_user_lc = array_smartmap hcons_types oib.mind_user_lc;
+ mind_nf_lc = array_smartmap hcons_types oib.mind_nf_lc }
+
+let hcons_mind mib =
+ { mib with
+ mind_packets = array_smartmap hcons_mind_packet mib.mind_packets;
+ mind_params_ctxt = hcons_rel_context mib.mind_params_ctxt;
+ mind_constraints = hcons_constraints mib.mind_constraints }
(*s Modules: signature component specifications, module types, and
module declarations *)
diff --git a/kernel/declarations.mli b/kernel/declarations.mli
index db706a0c..5b800ede 100644
--- a/kernel/declarations.mli
+++ b/kernel/declarations.mli
@@ -1,30 +1,25 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: declarations.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
open Names
open Univ
open Term
open Cemitcodes
open Sign
open Mod_subst
-(*i*)
-(* This module defines the internal representation of global
+(** This module defines the internal representation of global
declarations. This includes global constants/axioms, mutual
inductive definitions, modules and module types *)
type engagement = ImpredicativeSet
-(**********************************************************************)
-(*s Representation of constants (Definition/Axiom) *)
+(** {6 Representation of constants (Definition/Axiom) } *)
type polymorphic_arity = {
poly_param_levels : universe option list;
@@ -40,24 +35,58 @@ type constr_substituted
val from_val : constr -> constr_substituted
val force : constr_substituted -> constr
+(** Opaque proof terms are not loaded immediately, but are there
+ in a lazy form. Forcing this lazy may trigger some unmarshal of
+ the necessary structure. *)
+
+type lazy_constr
+
+val subst_lazy_constr : substitution -> lazy_constr -> lazy_constr
+val force_lazy_constr : lazy_constr -> constr_substituted
+val make_lazy_constr : constr_substituted Lazy.t -> lazy_constr
+val lazy_constr_is_val : lazy_constr -> bool
+
+val force_opaque : lazy_constr -> constr
+val opaque_from_val : constr -> lazy_constr
+
+(** Inlining level of parameters at functor applications.
+ None means no inlining *)
+
+type inline = int option
+
+(** A constant can have no body (axiom/parameter), or a
+ transparent body, or an opaque one *)
+
+type constant_def =
+ | Undef of inline
+ | Def of constr_substituted
+ | OpaqueDef of lazy_constr
+
type constant_body = {
- const_hyps : section_context; (* New: younger hyp at top *)
- const_body : constr_substituted option;
+ const_hyps : section_context; (** New: younger hyp at top *)
+ const_body : constant_def;
const_type : constant_type;
const_body_code : to_patch_substituted;
- (*i const_type_code : to_patch;i*)
- const_constraints : constraints;
- const_opaque : bool;
- const_inline : bool}
+ const_constraints : constraints }
+val subst_const_def : substitution -> constant_def -> constant_def
val subst_const_body : substitution -> constant_body -> constant_body
-(**********************************************************************)
-(*s Representation of mutual inductive types in the kernel *)
+(** Is there a actual body in const_body or const_body_opaque ? *)
+
+val constant_has_body : constant_body -> bool
+
+(** Accessing const_body_opaque or const_body *)
+
+val body_of_constant : constant_body -> constr_substituted option
+
+val is_opaque : constant_body -> bool
+
+(** {6 Representation of mutual inductive types in the kernel } *)
type recarg =
| Norec
- | Mrec of int
+ | Mrec of inductive
| Imbr of inductive
val subst_recarg : substitution -> recarg -> recarg
@@ -72,12 +101,12 @@ val recarg_length : wf_paths -> int -> int
val subst_wf_paths : substitution -> wf_paths -> wf_paths
-(*
-\begin{verbatim}
+(**
+{v
Inductive I1 (params) : U1 := c11 : T11 | ... | c1p1 : T1p1
...
with In (params) : Un := cn1 : Tn1 | ... | cnpn : Tnpn
-\end{verbatim}
+v}
*)
type monomorphic_inductive_arity = {
@@ -90,94 +119,72 @@ type inductive_arity =
| Polymorphic of polymorphic_arity
type one_inductive_body = {
+(** {8 Primitive datas } *)
-(* Primitive datas *)
+ mind_typename : identifier; (** Name of the type: [Ii] *)
- (* Name of the type: [Ii] *)
- mind_typename : identifier;
+ mind_arity_ctxt : rel_context; (** Arity context of [Ii] with parameters: [forall params, Ui] *)
- (* Arity context of [Ii] with parameters: [forall params, Ui] *)
- mind_arity_ctxt : rel_context;
+ mind_arity : inductive_arity; (** Arity sort and original user arity if monomorphic *)
- (* Arity sort and original user arity if monomorphic *)
- mind_arity : inductive_arity;
+ mind_consnames : identifier array; (** Names of the constructors: [cij] *)
- (* Names of the constructors: [cij] *)
- mind_consnames : identifier array;
-
- (* Types of the constructors with parameters: [forall params, Tij],
- where the Ik are replaced by de Bruijn index in the context
- I1:forall params, U1 .. In:forall params, Un *)
mind_user_lc : types array;
+ (** Types of the constructors with parameters: [forall params, Tij],
+ where the Ik are replaced by de Bruijn index in the
+ context I1:forall params, U1 .. In:forall params, Un *)
-(* Derived datas *)
+(** {8 Derived datas } *)
- (* Number of expected real arguments of the type (no let, no params) *)
- mind_nrealargs : int;
+ mind_nrealargs : int; (** Number of expected real arguments of the type (no let, no params) *)
- (* Length of realargs context (with let, no params) *)
- mind_nrealargs_ctxt : int;
+ mind_nrealargs_ctxt : int; (** Length of realargs context (with let, no params) *)
- (* List of allowed elimination sorts *)
- mind_kelim : sorts_family list;
+ mind_kelim : sorts_family list; (** List of allowed elimination sorts *)
- (* Head normalized constructor types so that their conclusion is atomic *)
- mind_nf_lc : types array;
+ mind_nf_lc : types array; (** Head normalized constructor types so that their conclusion is atomic *)
- (* Length of the signature of the constructors (with let, w/o params)
- (not used in the kernel) *)
mind_consnrealdecls : int array;
+ (** Length of the signature of the constructors (with let, w/o params)
+ (not used in the kernel) *)
- (* Signature of recursive arguments in the constructors *)
- mind_recargs : wf_paths;
+ mind_recargs : wf_paths; (** Signature of recursive arguments in the constructors *)
-(* Datas for bytecode compilation *)
+(** {8 Datas for bytecode compilation } *)
- (* number of constant constructor *)
- mind_nb_constant : int;
+ mind_nb_constant : int; (** number of constant constructor *)
- (* number of no constant constructor *)
- mind_nb_args : int;
+ mind_nb_args : int; (** number of no constant constructor *)
mind_reloc_tbl : Cbytecodes.reloc_table;
}
type mutual_inductive_body = {
- (* The component of the mutual inductive block *)
- mind_packets : one_inductive_body array;
+ mind_packets : one_inductive_body array; (** The component of the mutual inductive block *)
- (* Whether the inductive type has been declared as a record *)
- mind_record : bool;
+ mind_record : bool; (** Whether the inductive type has been declared as a record *)
- (* Whether the type is inductive or coinductive *)
- mind_finite : bool;
+ mind_finite : bool; (** Whether the type is inductive or coinductive *)
- (* Number of types in the block *)
- mind_ntypes : int;
+ mind_ntypes : int; (** Number of types in the block *)
- (* Section hypotheses on which the block depends *)
- mind_hyps : section_context;
+ mind_hyps : section_context; (** Section hypotheses on which the block depends *)
- (* Number of expected parameters *)
- mind_nparams : int;
+ mind_nparams : int; (** Number of expected parameters *)
- (* Number of recursively uniform (i.e. ordinary) parameters *)
- mind_nparams_rec : int;
+ mind_nparams_rec : int; (** Number of recursively uniform (i.e. ordinary) parameters *)
- (* The context of parameters (includes let-in declaration) *)
- mind_params_ctxt : rel_context;
+ mind_params_ctxt : rel_context; (** The context of parameters (includes let-in declaration) *)
- (* Universes constraints enforced by the inductive declaration *)
- mind_constraints : constraints;
+ mind_constraints : constraints; (** Universes constraints enforced by the inductive declaration *)
}
val subst_mind : substitution -> mutual_inductive_body -> mutual_inductive_body
-(**********************************************************************)
-(*s Modules: signature component specifications, module types, and
- module declarations *)
+(** {6 Modules: signature component specifications, module types, and
+ module declarations } *)
type structure_field_body =
| SFBconst of constant_body
@@ -199,29 +206,39 @@ and with_declaration_body =
| With_definition_body of identifier list * constant_body
and module_body =
- { (*absolute path of the module*)
+ { (** absolute path of the module *)
mod_mp : module_path;
- (* Implementation *)
+ (** Implementation *)
mod_expr : struct_expr_body option;
- (* Signature *)
+ (** Signature *)
mod_type : struct_expr_body;
- (* algebraic structure expression is kept
+ (** algebraic structure expression is kept
if it's relevant for extraction *)
mod_type_alg : struct_expr_body option;
- (* set of all constraint in the module *)
+ (** set of all constraint in the module *)
mod_constraints : constraints;
- (* quotiented set of equivalent constant and inductive name *)
+ (** quotiented set of equivalent constant and inductive name *)
mod_delta : delta_resolver;
mod_retroknowledge : Retroknowledge.action list}
and module_type_body =
{
- (*Path of the module type*)
+ (** Path of the module type *)
typ_mp : module_path;
typ_expr : struct_expr_body;
- (* algebraic structure expression is kept
+ (** algebraic structure expression is kept
if it's relevant for extraction *)
typ_expr_alg : struct_expr_body option ;
typ_constraints : constraints;
- (* quotiented set of equivalent constant and inductive name *)
+ (** quotiented set of equivalent constant and inductive name *)
typ_delta :delta_resolver}
+
+
+(** Hash-consing *)
+
+(** Here, strictly speaking, we don't perform true hash-consing
+ of the structure, but simply hash-cons all inner constr
+ and other known elements *)
+
+val hcons_const_body : constant_body -> constant_body
+val hcons_mind : mutual_inductive_body -> mutual_inductive_body
diff --git a/kernel/entries.ml b/kernel/entries.ml
index 4ca21277..a4485fac 100644
--- a/kernel/entries.ml
+++ b/kernel/entries.ml
@@ -1,13 +1,11 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: entries.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
(*i*)
open Names
open Univ
@@ -58,12 +56,13 @@ type mutual_inductive_entry = {
type definition_entry = {
const_entry_body : constr;
+ const_entry_secctx : section_context option;
const_entry_type : types option;
- const_entry_opaque : bool;
- const_entry_boxed : bool}
+ const_entry_opaque : bool }
+
+type inline = int option (* inlining level, None for no inlining *)
-(* type and the inlining flag *)
-type parameter_entry = types * bool
+type parameter_entry = section_context option * types * inline
type constant_entry =
| DefinitionEntry of definition_entry
@@ -71,14 +70,7 @@ type constant_entry =
(*s Modules *)
-
-type specification_entry =
- SPEconst of constant_entry
- | SPEmind of mutual_inductive_entry
- | SPEmodule of module_entry
- | SPEmodtype of module_struct_entry
-
-and module_struct_entry =
+type module_struct_entry =
MSEident of module_path
| MSEfunctor of mod_bound_id * module_struct_entry * module_struct_entry
| MSEwith of module_struct_entry * with_declaration
diff --git a/kernel/entries.mli b/kernel/entries.mli
index d71b48f6..b726d0ec 100644
--- a/kernel/entries.mli
+++ b/kernel/entries.mli
@@ -1,43 +1,38 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: entries.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
open Names
open Univ
open Term
open Sign
-(*i*)
-(* This module defines the entry types for global declarations. This
+(** This module defines the entry types for global declarations. This
information is entered in the environments. This includes global
constants/axioms, mutual inductive definitions, modules and module
types *)
-(*s Local entries *)
+(** {6 Local entries } *)
type local_entry =
| LocalDef of constr
| LocalAssum of constr
-(*s Declaration of inductive types. *)
+(** {6 Declaration of inductive types. } *)
-(* Assume the following definition in concrete syntax:
-\begin{verbatim}
-Inductive I1 (x1:X1) ... (xn:Xn) : A1 := c11 : T11 | ... | c1n1 : T1n1
+(** Assume the following definition in concrete syntax:
+{v Inductive I1 (x1:X1) ... (xn:Xn) : A1 := c11 : T11 | ... | c1n1 : T1n1
...
-with Ip (x1:X1) ... (xn:Xn) : Ap := cp1 : Tp1 | ... | cpnp : Tpnp.
-\end{verbatim}
-then, in $i^{th}$ block, [mind_entry_params] is [[xn:Xn;...;x1:X1]];
-[mind_entry_arity] is [Ai], defined in context [[[x1:X1;...;xn:Xn]];
+with Ip (x1:X1) ... (xn:Xn) : Ap := cp1 : Tp1 | ... | cpnp : Tpnp. v}
+
+then, in i{^ th} block, [mind_entry_params] is [xn:Xn;...;x1:X1];
+[mind_entry_arity] is [Ai], defined in context [x1:X1;...;xn:Xn];
[mind_entry_lc] is [Ti1;...;Tini], defined in context [[A'1;...;A'p;x1:X1;...;xn:Xn]] where [A'i] is [Ai] generalized over [[x1:X1;...;xn:Xn]].
*)
@@ -53,30 +48,25 @@ type mutual_inductive_entry = {
mind_entry_params : (identifier * local_entry) list;
mind_entry_inds : one_inductive_entry list }
-(*s Constants (Definition/Axiom) *)
+(** {6 Constants (Definition/Axiom) } *)
type definition_entry = {
const_entry_body : constr;
+ const_entry_secctx : section_context option;
const_entry_type : types option;
- const_entry_opaque : bool;
- const_entry_boxed : bool }
+ const_entry_opaque : bool }
+
+type inline = int option (* inlining level, None for no inlining *)
-type parameter_entry = types * bool (*inline flag*)
+type parameter_entry = section_context option * types * inline
type constant_entry =
| DefinitionEntry of definition_entry
| ParameterEntry of parameter_entry
-(*s Modules *)
-
-
-type specification_entry =
- SPEconst of constant_entry
- | SPEmind of mutual_inductive_entry
- | SPEmodule of module_entry
- | SPEmodtype of module_struct_entry
+(** {6 Modules } *)
-and module_struct_entry =
+type module_struct_entry =
MSEident of module_path
| MSEfunctor of mod_bound_id * module_struct_entry * module_struct_entry
| MSEwith of module_struct_entry * with_declaration
diff --git a/kernel/environ.ml b/kernel/environ.ml
index e6fafce9..7a41e62c 100644
--- a/kernel/environ.ml
+++ b/kernel/environ.ml
@@ -1,12 +1,24 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: environ.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
+(* Author: Jean-Christophe Filliâtre as part of the rebuilding of Coq
+ around a purely functional abstract type-checker, Aug 1999 *)
+(* Cleaning and lightening of the kernel by Bruno Barras, Nov 2001 *)
+(* Flag for predicativity of Set by Hugo Herbelin in Oct 2003 *)
+(* Support for virtual machine by Benjamin Grégoire in Oct 2004 *)
+(* Support for retroknowledge by Arnaud Spiwack in May 2007 *)
+(* Support for assumption dependencies by Arnaud Spiwack in May 2007 *)
+
+(* Miscellaneous maintenance by Bruno Barras, Hugo Herbelin, Jean-Marc
+ Notin, Matthieu Sozeau *)
+
+(* This file defines the type of environments on which the
+ type-checker works, together with simple related functions *)
open Util
open Names
@@ -97,7 +109,7 @@ let lookup_named id env = Sign.lookup_named id env.env_named_context
let lookup_named_val id (ctxt,_) = Sign.lookup_named id ctxt
let eq_named_context_val c1 c2 =
- c1 == c2 || named_context_of_val c1 = named_context_of_val c2
+ c1 == c2 || named_context_equal (named_context_of_val c1) (named_context_of_val c2)
(* A local const is evaluable if it is defined *)
@@ -158,10 +170,10 @@ exception NotEvaluableConst of const_evaluation_result
let constant_value env kn =
let cb = lookup_constant kn env in
- if cb.const_opaque then raise (NotEvaluableConst Opaque);
match cb.const_body with
- | Some l_body -> Declarations.force l_body
- | None -> raise (NotEvaluableConst NoBody)
+ | Def l_body -> Declarations.force l_body
+ | OpaqueDef _ -> raise (NotEvaluableConst Opaque)
+ | Undef _ -> raise (NotEvaluableConst NoBody)
let constant_opt_value env cst =
try Some (constant_value env cst)
@@ -183,14 +195,9 @@ let add_mind kn mib env =
{ env with env_globals = new_globals }
(* Universe constraints *)
-let set_universes g env =
- if env.env_stratification.env_universes == g then env
- else
- { env with env_stratification =
- { env.env_stratification with env_universes = g } }
let add_constraints c env =
- if c == Constraint.empty then
+ if is_empty_constraint c then
env
else
let s = env.env_stratification in
diff --git a/kernel/environ.mli b/kernel/environ.mli
index a7795136..42100e4e 100644
--- a/kernel/environ.mli
+++ b/kernel/environ.mli
@@ -1,26 +1,22 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: environ.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
open Names
open Term
open Declarations
open Sign
-(*i*)
-(*s Unsafe environments. We define here a datatype for environments.
+(** Unsafe environments. We define here a datatype for environments.
Since typing is not yet defined, it is not possible to check the
informations added in environments, and that is why we speak here
of ``unsafe'' environments. *)
-(* Environments have the following components:
+(** Environments have the following components:
- a context for de Bruijn variables
- a context for de Bruijn variables vm values
- a context for section variables and goal assumptions
@@ -50,27 +46,27 @@ val named_context_val : env -> named_context_val
val engagement : env -> engagement option
-(* is the local context empty *)
+(** is the local context empty *)
val empty_context : env -> bool
-(************************************************************************)
-(*s Context of de Bruijn variables ([rel_context]) *)
+(** {5 Context of de Bruijn variables ([rel_context]) } *)
+
val nb_rel : env -> int
val push_rel : rel_declaration -> env -> env
val push_rel_context : rel_context -> env -> env
val push_rec_types : rec_declaration -> env -> env
-(* Looks up in the context of local vars referred by indice ([rel_context]) *)
-(* raises [Not_found] if the index points out of the context *)
+(** Looks up in the context of local vars referred by indice ([rel_context])
+ raises [Not_found] if the index points out of the context *)
val lookup_rel : int -> env -> rel_declaration
val evaluable_rel : int -> env -> bool
-(*s Recurrence on [rel_context] *)
+(** {6 Recurrence on [rel_context] } *)
+
val fold_rel_context :
(env -> rel_declaration -> 'a -> 'a) -> env -> init:'a -> 'a
-(************************************************************************)
-(* Context of variables (section variables and goal assumptions) *)
+(** {5 Context of variables (section variables and goal assumptions) } *)
val named_context_of_val : named_context_val -> named_context
val named_vals_of_val : named_context_val -> Pre_env.named_vals
@@ -78,7 +74,7 @@ val val_of_named_context : named_context -> named_context_val
val empty_named_context_val : named_context_val
-(* [map_named_val f ctxt] apply [f] to the body and the type of
+(** [map_named_val f ctxt] apply [f] to the body and the type of
each declarations.
*** /!\ *** [f t] should be convertible with t *)
val map_named_val :
@@ -90,8 +86,8 @@ val push_named_context_val :
-(* Looks up in the context of local vars referred by names ([named_context]) *)
-(* raises [Not_found] if the identifier is not found *)
+(** Looks up in the context of local vars referred by names ([named_context])
+ raises [Not_found] if the identifier is not found *)
val lookup_named : variable -> env -> named_declaration
val lookup_named_val : variable -> named_context_val -> named_declaration
@@ -99,34 +95,36 @@ val evaluable_named : variable -> env -> bool
val named_type : variable -> env -> types
val named_body : variable -> env -> constr option
-(*s Recurrence on [named_context]: older declarations processed first *)
+(** {6 Recurrence on [named_context]: older declarations processed first } *)
val fold_named_context :
(env -> named_declaration -> 'a -> 'a) -> env -> init:'a -> 'a
-(* Recurrence on [named_context] starting from younger decl *)
+(** Recurrence on [named_context] starting from younger decl *)
val fold_named_context_reverse :
('a -> named_declaration -> 'a) -> init:'a -> env -> 'a
-(* This forgets named and rel contexts *)
+(** This forgets named and rel contexts *)
val reset_context : env -> env
-(* This forgets rel context and sets a new named context *)
+
+(** This forgets rel context and sets a new named context *)
val reset_with_named_context : named_context_val -> env -> env
-(************************************************************************)
-(*s Global constants *)
-(*s Add entries to global environment *)
-val add_constant : constant -> constant_body -> env -> env
+(** {5 Global constants }
+ {6 Add entries to global environment } *)
-(* Looks up in the context of global constant names *)
-(* raises [Not_found] if the required path is not found *)
+val add_constant : constant -> constant_body -> env -> env
+(** Looks up in the context of global constant names
+ raises [Not_found] if the required path is not found *)
val lookup_constant : constant -> env -> constant_body
val evaluable_constant : constant -> env -> bool
-(*s [constant_value env c] raises [NotEvaluableConst Opaque] if
+(** {6 ... } *)
+(** [constant_value env c] raises [NotEvaluableConst Opaque] if
[c] is opaque and [NotEvaluableConst NoBody] if it has no
body and [Not_found] if it does not exist in [env] *)
+
type const_evaluation_result = NoBody | Opaque
exception NotEvaluableConst of const_evaluation_result
@@ -134,44 +132,44 @@ val constant_value : env -> constant -> constr
val constant_type : env -> constant -> constant_type
val constant_opt_value : env -> constant -> constr option
-(************************************************************************)
-(*s Inductive types *)
+(** {5 Inductive types } *)
+
val add_mind : mutual_inductive -> mutual_inductive_body -> env -> env
-(* Looks up in the context of global inductive names *)
-(* raises [Not_found] if the required path is not found *)
+(** Looks up in the context of global inductive names
+ raises [Not_found] if the required path is not found *)
val lookup_mind : mutual_inductive -> env -> mutual_inductive_body
-(************************************************************************)
-(*s Modules *)
+(** {5 Modules } *)
+
val add_modtype : module_path -> module_type_body -> env -> env
-(* [shallow_add_module] does not add module components *)
+(** [shallow_add_module] does not add module components *)
val shallow_add_module : module_path -> module_body -> env -> env
val lookup_module : module_path -> env -> module_body
val lookup_modtype : module_path -> env -> module_type_body
-(************************************************************************)
-(*s Universe constraints *)
-val set_universes : Univ.universes -> env -> env
+(** {5 Universe constraints } *)
+
val add_constraints : Univ.constraints -> env -> env
val set_engagement : engagement -> env -> env
-(************************************************************************)
-(* Sets of referred section variables *)
-(* [global_vars_set env c] returns the list of [id]'s occurring either
+(** {6 Sets of referred section variables }
+ [global_vars_set env c] returns the list of [id]'s occurring either
directly as [Var id] in [c] or indirectly as a section variable
dependent in a global reference occurring in [c] *)
+
val global_vars_set : env -> constr -> Idset.t
-(* the constr must be a global reference *)
+
+(** the constr must be a global reference *)
val vars_of_global : env -> constr -> identifier list
val keep_hyps : env -> Idset.t -> section_context
-(************************************************************************)
-(*s Unsafe judgments. We introduce here the pre-type of judgments, which is
+(** {5 Unsafe judgments. }
+ We introduce here the pre-type of judgments, which is
actually only a datatype to store a term with its type and the type of its
type. *)
@@ -188,23 +186,20 @@ type unsafe_type_judgment = {
utj_type : sorts }
-(*s Compilation of global declaration *)
+(** {6 Compilation of global declaration } *)
-val compile_constant_body :
- env -> constr_substituted option -> bool -> bool -> Cemitcodes.body_code
- (* opaque *) (* boxed *)
+val compile_constant_body : env -> constant_def -> Cemitcodes.body_code
exception Hyp_not_found
-(* [apply_to_hyp sign id f] split [sign] into [tail::(id,_,_)::head] and
+(** [apply_to_hyp sign id f] split [sign] into [tail::(id,_,_)::head] and
return [tail::(f head (id,_,_) (rev tail))::head].
the value associated to id should not change *)
-
val apply_to_hyp : named_context_val -> variable ->
(named_context -> named_declaration -> named_context -> named_declaration) ->
named_context_val
-(* [apply_to_hyp_and_dependent_on sign id f g] split [sign] into
+(** [apply_to_hyp_and_dependent_on sign id f g] split [sign] into
[tail::(id,_,_)::head] and
return [(g tail)::(f (id,_,_))::head]. *)
val apply_to_hyp_and_dependent_on : named_context_val -> variable ->
@@ -219,9 +214,10 @@ val insert_after_hyp : named_context_val -> variable ->
val remove_hyps : identifier list -> (named_declaration -> named_declaration) -> (Pre_env.lazy_val -> Pre_env.lazy_val) -> named_context_val -> named_context_val
-(* spiwack: functions manipulating the retroknowledge *)
-open Retroknowledge
+open Retroknowledge
+(** functions manipulating the retroknowledge
+ @author spiwack *)
val retroknowledge : (retroknowledge->'a) -> env -> 'a
val registered : env -> field -> bool
@@ -230,3 +226,4 @@ val unregister : env -> field -> env
val register : env -> field -> Retroknowledge.entry -> env
+
diff --git a/kernel/esubst.ml b/kernel/esubst.ml
index 82d19ec4..cbce04d6 100644
--- a/kernel/esubst.ml
+++ b/kernel/esubst.ml
@@ -1,12 +1,14 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: esubst.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
+(* Created by Bruno Barras for Coq V7.0, Mar 2001 *)
+
+(* Support for explicit substitutions *)
open Util
@@ -21,6 +23,8 @@ type lift =
| ELLFT of int * lift (* ELLFT(n,l) == apply l to de Bruijn > n *)
(* i.e under n binders *)
+let el_id = ELID
+
(* compose a relocation of magnitude n *)
let rec el_shft_rec n = function
| ELSHFT(el,k) -> el_shft_rec (k+n) el
@@ -67,6 +71,8 @@ type 'a subs =
* Needn't be recursive if we always use these functions
*)
+let subs_id i = ESID i
+
let subs_cons(x,s) = if Array.length x = 0 then s else CONS(x,s)
let subs_liftn n = function
diff --git a/kernel/esubst.mli b/kernel/esubst.mli
index 76c0d481..fe978261 100644
--- a/kernel/esubst.mli
+++ b/kernel/esubst.mli
@@ -1,61 +1,66 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: esubst.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
+(** Explicit substitutions *)
-(*s Explicit substitutions of type ['a]. *)
-(* - ESID(n) = %n END bounded identity
- * - CONS([|t1..tn|],S) = (S.t1...tn) parallel substitution
- * (beware of the order: indice 1 is substituted by tn)
- * - SHIFT(n,S) = (^n o S) terms in S are relocated with n vars
- * - LIFT(n,S) = (%n S) stands for ((^n o S).n...1)
+(** {6 Explicit substitutions } *)
+(** Explicit substitutions of type ['a].
+ - ESID(n) = %n END bounded identity
+ - CONS([|t1..tn|],S) = (S.t1...tn) parallel substitution
+ (beware of the order: indice 1 is substituted by tn)
+ - SHIFT(n,S) = (^n o S) terms in S are relocated with n vars
+ - LIFT(n,S) = (%n S) stands for ((^n o S).n...1)
(corresponds to S crossing n binders) *)
-type 'a subs =
+type 'a subs = private
| ESID of int
| CONS of 'a array * 'a subs
| SHIFT of int * 'a subs
| LIFT of int * 'a subs
-(* Derived constructors granting basic invariants *)
+(** Derived constructors granting basic invariants *)
+val subs_id : int -> 'a subs
val subs_cons: 'a array * 'a subs -> 'a subs
val subs_shft: int * 'a subs -> 'a subs
val subs_lift: 'a subs -> 'a subs
val subs_liftn: int -> 'a subs -> 'a subs
-(* [subs_shift_cons(k,s,[|t1..tn|])] builds (^k s).t1..tn *)
+
+(** [subs_shift_cons(k,s,[|t1..tn|])] builds (^k s).t1..tn *)
val subs_shift_cons: int * 'a subs * 'a array -> 'a subs
-(* [expand_rel k subs] expands de Bruijn [k] in the explicit substitution
- * [subs]. The result is either (Inl(lams,v)) when the variable is
- * substituted by value [v] under lams binders (i.e. v *has* to be
- * shifted by lams), or (Inr (k',p)) when the variable k is just relocated
- * as k'; p is None if the variable points inside subs and Some(k) if the
- * variable points k bindings beyond subs (cf argument of ESID).
- *)
+(** [expand_rel k subs] expands de Bruijn [k] in the explicit substitution
+ [subs]. The result is either (Inl(lams,v)) when the variable is
+ substituted by value [v] under lams binders (i.e. v *has* to be
+ shifted by lams), or (Inr (k',p)) when the variable k is just relocated
+ as k'; p is None if the variable points inside subs and Some(k) if the
+ variable points k bindings beyond subs (cf argument of ESID).
+*)
val expand_rel: int -> 'a subs -> (int * 'a, int * int option) Util.union
-(* Tests whether a substitution behaves like the identity *)
+(** Tests whether a substitution behaves like the identity *)
val is_subs_id: 'a subs -> bool
-(* Composition of substitutions: [comp mk_clos s1 s2] computes a
- * substitution equivalent to applying s2 then s1. Argument
- * mk_clos is used when a closure has to be created, i.e. when
- * s1 is applied on an element of s2.
- *)
+(** Composition of substitutions: [comp mk_clos s1 s2] computes a
+ substitution equivalent to applying s2 then s1. Argument
+ mk_clos is used when a closure has to be created, i.e. when
+ s1 is applied on an element of s2.
+*)
val comp : ('a subs * 'a -> 'a) -> 'a subs -> 'a subs -> 'a subs
-(*s Compact representation of explicit relocations. \\
- [ELSHFT(l,n)] == lift of [n], then apply [lift l].
- [ELLFT(n,l)] == apply [l] to de Bruijn > [n] i.e under n binders. *)
-type lift =
+(** {6 Compact representation } *)
+(** Compact representation of explicit relocations
+ - [ELSHFT(l,n)] == lift of [n], then apply [lift l].
+ - [ELLFT(n,l)] == apply [l] to de Bruijn > [n] i.e under n binders. *)
+type lift = private
| ELID
| ELSHFT of lift * int
| ELLFT of int * lift
+val el_id : lift
val el_shft : int -> lift -> lift
val el_liftn : int -> lift -> lift
val el_lift : lift -> lift
diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml
index 9b1ddc31..46e866a0 100644
--- a/kernel/indtypes.ml
+++ b/kernel/indtypes.ml
@@ -1,13 +1,11 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: indtypes.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
open Util
open Names
open Univ
@@ -87,15 +85,6 @@ let mind_check_names mie =
vue since inductive and constructors are not referred to by their
name, but only by the name of the inductive packet and an index. *)
-let mind_check_arities env mie =
- let check_arity id c =
- if not (is_arity env c) then
- raise (InductiveError (NotAnArity id))
- in
- List.iter
- (fun {mind_entry_typename=id; mind_entry_arity=ar} -> check_arity id ar)
- mie.mind_entry_inds
-
(************************************************************************)
(************************************************************************)
@@ -171,7 +160,7 @@ let inductive_levels arities inds =
arity or type constructor; we do not to recompute universes constraints *)
let constraint_list_union =
- List.fold_left Constraint.union Constraint.empty
+ List.fold_left union_constraints empty_constraint
let infer_constructor_packet env_ar_par params lc =
(* type-check the constructors *)
@@ -208,7 +197,7 @@ let typecheck_inductive env mie =
full_arity is used as argument or subject to cast, an
upper universe will be generated *)
let full_arity = it_mkProd_or_LetIn arity.utj_val params in
- let cst = Constraint.union cst cst2 in
+ let cst = union_constraints cst cst2 in
let id = ind.mind_entry_typename in
let env_ar' =
push_rel (Name id, None, full_arity)
@@ -237,7 +226,7 @@ let typecheck_inductive env mie =
infer_constructor_packet env_ar_par params ind.mind_entry_lc in
let consnames = ind.mind_entry_consnames in
let ind' = (arity_data,consnames,info,lc',cstrs_univ) in
- (ind'::inds, Constraint.union cst cst'))
+ (ind'::inds, union_constraints cst cst'))
mie.mind_entry_inds
arity_list
([],cst) in
@@ -246,7 +235,8 @@ let typecheck_inductive env mie =
let arities = Array.of_list arity_list in
let param_ccls = List.fold_left (fun l (_,b,p) ->
if b = None then
- let _,c = dest_prod_assum env p in
+ (* Parameter contributes to polymorphism only if explicit Type *)
+ let c = strip_prod_assum p in
(* Add Type levels to the ordered list of parameters contributing to *)
(* polymorphism unless there is aliasing (i.e. non distinct levels) *)
match kind_of_term c with
@@ -373,6 +363,11 @@ if nmr = 0 then 0 else
| _ -> k)
in find 0 (n-1) (lpar,List.rev hyps)
+let lambda_implicit_lift n a =
+ let implicit_sort = mkType (make_univ (make_dirpath [id_of_string "implicit"], 0)) in
+ let lambda_implicit a = mkLambda (Anonymous, implicit_sort, a) in
+ iterate lambda_implicit n (lift n a)
+
(* This removes global parameters of the inductive types in lc (for
nested inductive types only ) *)
let abstract_mind_lc env ntyps npars lc =
@@ -421,7 +416,7 @@ let array_min nmr a = if nmr = 0 then 0 else
(* The recursive function that checks positivity and builds the list
of recursive arguments *)
-let check_positivity_one (env, _,ntypes,_ as ienv) hyps i nargs lcnames indlc =
+let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcnames indlc =
let lparams = rel_context_length hyps in
let nmr = rel_context_nhyps hyps in
(* Checking the (strict) positivity of a constructor argument type [c] *)
@@ -466,8 +461,9 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps i nargs lcnames indlc =
with Failure _ -> raise (IllFormedInd (LocalNonPos n)) in
(* If the inductive appears in the args (non params) then the
definition is not positive. *)
+
if not (List.for_all (noccur_between n ntypes) auxlargs) then
- failwith_non_pos_list n ntypes auxlargs;
+ failwith_non_pos_list n ntypes auxlargs;
(* We do not deal with imbricated mutual inductive types *)
let auxntyp = mib.mind_ntypes in
if auxntyp <> 1 then raise (IllFormedInd (LocalNonPos n));
@@ -533,11 +529,11 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps i nargs lcnames indlc =
in
let irecargs = Array.map snd irecargs_nmr
and nmr' = array_min nmr irecargs_nmr
- in (nmr', mk_paths (Mrec i) irecargs)
+ in (nmr', mk_paths (Mrec ind) irecargs)
-let check_positivity env_ar params inds =
+let check_positivity kn env_ar params inds =
let ntypes = Array.length inds in
- let rc = Array.mapi (fun j t -> (Mrec j,t)) (Rtree.mk_rec_calls ntypes) in
+ let rc = Array.mapi (fun j t -> (Mrec (kn,j),t)) (Rtree.mk_rec_calls ntypes) in
let lra_ind = List.rev (Array.to_list rc) in
let lparams = rel_context_length params in
let nmr = rel_context_nhyps params in
@@ -546,7 +542,7 @@ let check_positivity env_ar params inds =
list_tabulate (fun _ -> (Norec,mk_norec)) lparams @ lra_ind in
let ienv = (env_ar, 1+lparams, ntypes, ra_env) in
let nargs = rel_context_nhyps sign - nmr in
- check_positivity_one ienv params i nargs lcnames lc
+ check_positivity_one ienv params (kn,i) nargs lcnames lc
in
let irecargs_nmr = Array.mapi check_one inds in
let irecargs = Array.map snd irecargs_nmr
@@ -558,16 +554,6 @@ let check_positivity env_ar params inds =
(************************************************************************)
(* Build the inductive packet *)
-(* Elimination sorts *)
-let is_recursive = Rtree.is_infinite
-(* let rec one_is_rec rvec =
- List.exists (function Mrec(i) -> List.mem i listind
- | Imbr(_,lvec) -> array_exists one_is_rec lvec
- | Norec -> false) rvec
- in
- array_exists one_is_rec
-*)
-
(* Allowed eliminations *)
let all_sorts = [InProp;InSet;InType]
@@ -614,7 +600,6 @@ let build_inductive env env_ar params isrecord isfinite inds nmr recargs cst =
(* Type of constructors in normal form *)
let splayed_lc = Array.map (dest_prod_assum env_ar) lc in
let nf_lc = Array.map (fun (d,b) -> it_mkProd_or_LetIn b d) splayed_lc in
- let nf_lc = if nf_lc = lc then lc else nf_lc in
let consnrealargs =
Array.map (fun (d,_) -> rel_context_length d - rel_context_length params)
splayed_lc in
@@ -677,11 +662,11 @@ let build_inductive env env_ar params isrecord isfinite inds nmr recargs cst =
(************************************************************************)
(************************************************************************)
-let check_inductive env mie =
+let check_inductive env kn mie =
(* First type-check the inductive definition *)
let (env_ar, params, inds, cst) = typecheck_inductive env mie in
(* Then check positivity conditions *)
- let (nmr,recargs) = check_positivity env_ar params inds in
+ let (nmr,recargs) = check_positivity kn env_ar params inds in
(* Build the inductive packets *)
build_inductive env env_ar params mie.mind_entry_record mie.mind_entry_finite
inds nmr recargs cst
diff --git a/kernel/indtypes.mli b/kernel/indtypes.mli
index 71d01568..b37aefe4 100644
--- a/kernel/indtypes.mli
+++ b/kernel/indtypes.mli
@@ -1,14 +1,11 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: indtypes.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
open Names
open Univ
open Term
@@ -16,13 +13,13 @@ open Declarations
open Environ
open Entries
open Typeops
-(*i*)
+(** Inductive type checking and errors *)
-(*s The different kinds of errors that may result of a malformed inductive
+(** The different kinds of errors that may result of a malformed inductive
definition. *)
-(* Errors related to inductive constructions *)
+(** Errors related to inductive constructions *)
type inductive_error =
| NonPos of env * constr * constr
| NotEnoughArgs of env * constr * constr
@@ -37,7 +34,7 @@ type inductive_error =
exception InductiveError of inductive_error
-(*s The following function does checks on inductive declarations. *)
+(** The following function does checks on inductive declarations. *)
val check_inductive :
- env -> mutual_inductive_entry -> mutual_inductive_body
+ env -> mutual_inductive -> mutual_inductive_entry -> mutual_inductive_body
diff --git a/kernel/inductive.ml b/kernel/inductive.ml
index 62a48f07..21f86233 100644
--- a/kernel/inductive.ml
+++ b/kernel/inductive.ml
@@ -1,13 +1,11 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: inductive.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
open Util
open Names
open Univ
@@ -80,8 +78,6 @@ let instantiate_params full t args sign =
if rem_args <> [] then fail();
substl subs ty
-let instantiate_partial_params = instantiate_params false
-
let full_inductive_instantiate mib params sign =
let dummy = prop_sort in
let t = mkArity (sign,dummy) in
@@ -97,10 +93,6 @@ let full_constructor_instantiate ((mind,_),(mib,_),params) =
(* Functions to build standard types related to inductive *)
-
-let number_of_inductives mib = Array.length mib.mind_packets
-let number_of_constructors mip = Array.length mip.mind_consnames
-
(*
Computing the actual sort of an applied or partially applied inductive type:
@@ -241,12 +233,6 @@ let type_of_constructors ind (mib,mip) =
(************************************************************************)
-let error_elim_expln kp ki =
- match kp,ki with
- | (InType | InSet), InProp -> NonInformativeToInformative
- | InType, InSet -> StrongEliminationOnNonSmallType (* if Set impredicative *)
- | _ -> WrongArity
-
(* Type of case predicates *)
let local_rels ctxt =
@@ -298,7 +284,7 @@ exception LocalArity of (sorts_family * sorts_family * arity_error) option
let check_allowed_sort ksort specif =
if not (List.exists ((=) ksort) (elim_sorts specif)) then
let s = inductive_sort_family (snd specif) in
- raise (LocalArity (Some(ksort,s,error_elim_expln ksort s)))
+ raise (LocalArity (Some(ksort,s,error_elim_explain ksort s)))
let is_correct_arity env c pj ind specif params =
let arsign,_ = get_instantiated_arity specif params in
@@ -309,7 +295,7 @@ let is_correct_arity env c pj ind specif params =
let univ =
try conv env a1 a1'
with NotConvertible -> raise (LocalArity None) in
- srec (push_rel (na1,None,a1) env) t ar' (Constraint.union u univ)
+ srec (push_rel (na1,None,a1) env) t ar' (union_constraints u univ)
| Prod (_,a1,a2), [] -> (* whnf of t was not needed here! *)
let ksort = match kind_of_term (whd_betadeltaiota env a2) with
| Sort s -> family_of_sort s
@@ -319,13 +305,13 @@ let is_correct_arity env c pj ind specif params =
try conv env a1 dep_ind
with NotConvertible -> raise (LocalArity None) in
check_allowed_sort ksort specif;
- Constraint.union u univ
+ union_constraints u univ
| _, (_,Some _,_ as d)::ar' ->
srec (push_rel d env) (lift 1 pt') ar' u
| _ ->
raise (LocalArity None)
in
- try srec env pj.uj_type (List.rev arsign) Constraint.empty
+ try srec env pj.uj_type (List.rev arsign) empty_constraint
with LocalArity kinds ->
error_elim_arity env ind (elim_sorts specif) c pj kinds
@@ -374,7 +360,7 @@ let check_case_info env indsp ci =
if
not (eq_ind indsp ci.ci_ind) or
(mib.mind_nparams <> ci.ci_npar) or
- (mip.mind_consnrealdecls <> ci.ci_cstr_nargs)
+ (mip.mind_consnrealdecls <> ci.ci_cstr_ndecls)
then raise (TypeError(env,WrongCaseInfo(indsp,ci)))
(************************************************************************)
@@ -431,10 +417,10 @@ let spec_of_tree t = lazy
else Subterm(Strict,Lazy.force t))
let subterm_spec_glb =
- let glb2 s1 s2 =
- match s1,s2 with
- _, Dead_code -> s1
- | Dead_code, _ -> s2
+ let glb2 s1 s2 =
+ match s1, s2 with
+ s1, Dead_code -> s1
+ | Dead_code, s2 -> s2
| Not_subterm, _ -> Not_subterm
| _, Not_subterm -> Not_subterm
| Subterm (a1,t1), Subterm (a2,t2) ->
@@ -447,27 +433,20 @@ type guard_env =
{ env : env;
(* dB of last fixpoint *)
rel_min : int;
- (* inductive of recarg of each fixpoint *)
- inds : inductive array;
- (* the recarg information of inductive family *)
- recvec : wf_paths array;
(* dB of variables denoting subterms *)
genv : subterm_spec Lazy.t list;
}
-let make_renv env minds recarg (kn,tyi) =
+let make_renv env recarg (kn,tyi) =
let mib = Environ.lookup_mind kn env in
let mind_recvec =
Array.map (fun mip -> mip.mind_recargs) mib.mind_packets in
{ env = env;
rel_min = recarg+2;
- inds = minds;
- recvec = mind_recvec;
genv = [Lazy.lazy_from_val(Subterm(Large,mind_recvec.(tyi)))] }
let push_var renv (x,ty,spec) =
- { renv with
- env = push_rel (x,None,ty) renv.env;
+ { env = push_rel (x,None,ty) renv.env;
rel_min = renv.rel_min+1;
genv = spec:: renv.genv }
@@ -475,76 +454,66 @@ let assign_var_spec renv (i,spec) =
{ renv with genv = list_assign renv.genv (i-1) spec }
let push_var_renv renv (x,ty) =
- push_var renv (x,ty,Lazy.lazy_from_val Not_subterm)
+ push_var renv (x,ty,lazy Not_subterm)
(* Fetch recursive information about a variable p *)
let subterm_var p renv =
try Lazy.force (List.nth renv.genv (p-1))
with Failure _ | Invalid_argument _ -> Not_subterm
-(* Add a variable and mark it as strictly smaller with information [spec]. *)
-let add_subterm renv (x,a,spec) =
- push_var renv (x,a,spec_of_tree spec)
-
let push_ctxt_renv renv ctxt =
let n = rel_context_length ctxt in
- { renv with
- env = push_rel_context ctxt renv.env;
+ { env = push_rel_context ctxt renv.env;
rel_min = renv.rel_min+n;
- genv = iterate (fun ge -> Lazy.lazy_from_val Not_subterm::ge) n renv.genv }
+ genv = iterate (fun ge -> lazy Not_subterm::ge) n renv.genv }
let push_fix_renv renv (_,v,_ as recdef) =
let n = Array.length v in
- { renv with
- env = push_rec_types recdef renv.env;
+ { env = push_rec_types recdef renv.env;
rel_min = renv.rel_min+n;
- genv = iterate (fun ge -> Lazy.lazy_from_val Not_subterm::ge) n renv.genv }
+ genv = iterate (fun ge -> lazy Not_subterm::ge) n renv.genv }
+(* Definition and manipulation of the stack *)
+type stack_element = |SClosure of guard_env*constr |SArg of subterm_spec Lazy.t
-(******************************)
-(* Computing the recursive subterms of a term (propagation of size
- information through Cases). *)
+let push_stack_closures renv l stack =
+ List.fold_right (fun h b -> (SClosure (renv,h))::b) l stack
-(*
- c is a branch of an inductive definition corresponding to the spec
- lrec. mind_recvec is the recursive spec of the inductive
- definition of the decreasing argument n.
-
- case_branches_specif renv lrec lc will pass the lambdas
- of c corresponding to pattern variables and collect possibly new
- subterms variables and returns the bodies of the branches with the
- correct envs and decreasing args.
-*)
+let push_stack_args l stack =
+ List.fold_right (fun h b -> (SArg h)::b) l stack
+
+(******************************)
+(* {6 Computing the recursive subterms of a term (propagation of size
+ information through Cases).} *)
let lookup_subterms env ind =
let (_,mip) = lookup_mind_specif env ind in
mip.mind_recargs
-(*********************************)
-let match_trees t1 t2 =
- let v1 = dest_subterms t1 in
- let v2 = dest_subterms t2 in
- array_for_all2 (fun l1 l2 -> List.length l1 = List.length l2) v1 v2
+let match_inductive ind ra =
+ match ra with
+ | (Mrec i | Imbr i) -> eq_ind ind i
+ | Norec -> false
-(* In {match c as z in ind y_s return P with |C_i x_s => t end}
- [branches_specif renv c_spec ind] returns an array of x_s specs given
- c_spec the spec of c. *)
-let branches_specif renv c_spec ind =
- let (_,mip) = lookup_mind_specif renv.env ind in
+(* In {match c as z in ci y_s return P with |C_i x_s => t end}
+ [branches_specif renv c_spec ci] returns an array of x_s specs knowing
+ c_spec. *)
+let branches_specif renv c_spec ci =
let car =
(* We fetch the regular tree associated to the inductive of the match.
This is just to get the number of constructors (and constructor
arities) that fit the match branches without forcing c_spec.
Note that c_spec might be more precise than [v] below, because of
nested inductive types. *)
+ let (_,mip) = lookup_mind_specif renv.env ci.ci_ind in
let v = dest_subterms mip.mind_recargs in
Array.map List.length v in
Array.mapi
(fun i nca -> (* i+1-th cstructor has arity nca *)
let lvra = lazy
(match Lazy.force c_spec with
- Subterm (_,t) when match_trees mip.mind_recargs t ->
+ Subterm (_,t) when match_inductive ci.ci_ind (dest_recarg t) ->
let vra = Array.of_list (dest_subterms t).(i) in
assert (nca = Array.length vra);
Array.map
@@ -555,106 +524,92 @@ let branches_specif renv c_spec ind =
list_tabulate (fun j -> lazy (Lazy.force lvra).(j)) nca)
car
-
-(* Propagation of size information through Cases: if the matched
- object is a recursive subterm then compute the information
- associated to its own subterms.
- Rq: if branch is not eta-long, then the recursive information
- is not propagated to the missing abstractions *)
-let case_branches_specif renv c_spec ind lbr =
- let vlrec = branches_specif renv c_spec ind in
- let rec push_branch_args renv lrec c =
- match lrec with
- ra::lr ->
- let c' = whd_betadeltaiota renv.env c in
- (match kind_of_term c' with
- Lambda(x,a,b) ->
- let renv' = push_var renv (x,a,ra) in
- push_branch_args renv' lr b
- | _ -> (* branch not in eta-long form: cannot perform rec. calls *)
- (renv,c'))
- | [] -> (renv, c) in
- assert (Array.length vlrec = Array.length lbr);
- array_map2 (push_branch_args renv) vlrec lbr
-
(* [subterm_specif renv t] computes the recursive structure of [t] and
compare its size with the size of the initial recursive argument of
the fixpoint we are checking. [renv] collects such information
about variables.
*)
-let rec subterm_specif renv t =
+let rec subterm_specif renv stack t =
(* maybe reduction is not always necessary! *)
let f,l = decompose_app (whd_betadeltaiota renv.env t) in
- match kind_of_term f with
- | Rel k -> subterm_var k renv
-
- | Case (ci,_,c,lbr) ->
- let lbr_spec = case_subterm_specif renv ci c lbr in
- let stl =
- Array.map (fun (renv',br') -> subterm_specif renv' br')
- lbr_spec in
- subterm_spec_glb stl
-
- | Fix ((recindxs,i),(_,typarray,bodies as recdef)) ->
-(* when proving that the fixpoint f(x)=e is less than n, it is enough
- to prove that e is less than n assuming f is less than n
- furthermore when f is applied to a term which is strictly less than
- n, one may assume that x itself is strictly less than n
-*)
- let (ctxt,clfix) = dest_prod renv.env typarray.(i) in
- let oind =
- let env' = push_rel_context ctxt renv.env in
- try Some(fst(find_inductive env' clfix))
- with Not_found -> None in
- (match oind with
- None -> Not_subterm (* happens if fix is polymorphic *)
- | Some ind ->
- let nbfix = Array.length typarray in
- let recargs = lookup_subterms renv.env ind in
- (* pushing the fixpoints *)
- let renv' = push_fix_renv renv recdef in
- let renv' =
- (* Why Strict here ? To be general, it could also be
- Large... *)
- assign_var_spec renv'
- (nbfix-i, Lazy.lazy_from_val(Subterm(Strict,recargs))) in
- let decrArg = recindxs.(i) in
- let theBody = bodies.(i) in
- let nbOfAbst = decrArg+1 in
- let sign,strippedBody = decompose_lam_n_assum nbOfAbst theBody in
- (* pushing the fix parameters *)
- let renv'' = push_ctxt_renv renv' sign in
- let renv'' =
- if List.length l < nbOfAbst then renv''
- else
- let theDecrArg = List.nth l decrArg in
- let arg_spec = lazy_subterm_specif renv theDecrArg in
- assign_var_spec renv'' (1, arg_spec) in
- subterm_specif renv'' strippedBody)
-
- | Lambda (x,a,b) ->
- assert (l=[]);
- subterm_specif (push_var_renv renv (x,a)) b
-
- (* Metas and evars are considered OK *)
- | (Meta _|Evar _) -> Dead_code
-
- (* Other terms are not subterms *)
- | _ -> Not_subterm
-
-and lazy_subterm_specif renv t =
- lazy (subterm_specif renv t)
-
-and case_subterm_specif renv ci c lbr =
- if Array.length lbr = 0 then [||]
- else
- let c_spec = lazy_subterm_specif renv c in
- case_branches_specif renv c_spec ci.ci_ind lbr
-
+ match kind_of_term f with
+ | Rel k -> subterm_var k renv
+
+ | Case (ci,_,c,lbr) ->
+ let stack' = push_stack_closures renv l stack in
+ let cases_spec = branches_specif renv
+ (lazy_subterm_specif renv [] c) ci in
+ let stl =
+ Array.mapi (fun i br' ->
+ let stack_br = push_stack_args (cases_spec.(i)) stack' in
+ subterm_specif renv stack_br br')
+ lbr in
+ subterm_spec_glb stl
+
+ | Fix ((recindxs,i),(_,typarray,bodies as recdef)) ->
+ (* when proving that the fixpoint f(x)=e is less than n, it is enough
+ to prove that e is less than n assuming f is less than n
+ furthermore when f is applied to a term which is strictly less than
+ n, one may assume that x itself is strictly less than n
+ *)
+ let (ctxt,clfix) = dest_prod renv.env typarray.(i) in
+ let oind =
+ let env' = push_rel_context ctxt renv.env in
+ try Some(fst(find_inductive env' clfix))
+ with Not_found -> None in
+ (match oind with
+ None -> Not_subterm (* happens if fix is polymorphic *)
+ | Some ind ->
+ let nbfix = Array.length typarray in
+ let recargs = lookup_subterms renv.env ind in
+ (* pushing the fixpoints *)
+ let renv' = push_fix_renv renv recdef in
+ let renv' =
+ (* Why Strict here ? To be general, it could also be
+ Large... *)
+ assign_var_spec renv'
+ (nbfix-i, lazy (Subterm(Strict,recargs))) in
+ let decrArg = recindxs.(i) in
+ let theBody = bodies.(i) in
+ let nbOfAbst = decrArg+1 in
+ let sign,strippedBody = decompose_lam_n_assum nbOfAbst theBody in
+ (* pushing the fix parameters *)
+ let stack' = push_stack_closures renv l stack in
+ let renv'' = push_ctxt_renv renv' sign in
+ let renv'' =
+ if List.length stack' < nbOfAbst then renv''
+ else
+ let decrArg = List.nth stack' decrArg in
+ let arg_spec = stack_element_specif decrArg in
+ assign_var_spec renv'' (1, arg_spec) in
+ subterm_specif renv'' [] strippedBody)
+
+ | Lambda (x,a,b) ->
+ assert (l=[]);
+ let spec,stack' = extract_stack renv a stack in
+ subterm_specif (push_var renv (x,a,spec)) stack' b
+
+ (* Metas and evars are considered OK *)
+ | (Meta _|Evar _) -> Dead_code
+
+ (* Other terms are not subterms *)
+ | _ -> Not_subterm
+
+and lazy_subterm_specif renv stack t =
+ lazy (subterm_specif renv stack t)
+
+and stack_element_specif = function
+ |SClosure (h_renv,h) -> lazy_subterm_specif h_renv [] h
+ |SArg x -> x
+
+and extract_stack renv a = function
+ | [] -> Lazy.lazy_from_val Not_subterm , []
+ | h::t -> stack_element_specif h, t
+
(* Check term c can be applied to one of the mutual fixpoints. *)
-let check_is_subterm renv c =
- match subterm_specif renv c with
+let check_is_subterm x =
+ match Lazy.force x with
Subterm (Strict,_) | Dead_code -> true
| _ -> false
@@ -662,7 +617,7 @@ let check_is_subterm renv c =
exception FixGuardError of env * guard_error
-let error_illegal_rec_call renv fx arg =
+let error_illegal_rec_call renv fx (arg_renv,arg) =
let (_,le_vars,lt_vars) =
List.fold_left
(fun (i,le,lt) sbt ->
@@ -672,7 +627,8 @@ let error_illegal_rec_call renv fx arg =
| _ -> (i+1, le ,lt))
(1,[],[]) renv.genv in
raise (FixGuardError (renv.env,
- RecursionOnIllegalTerm(fx,arg,le_vars,lt_vars)))
+ RecursionOnIllegalTerm(fx,(arg_renv.env, arg),
+ le_vars,lt_vars)))
let error_partial_apply renv fx =
raise (FixGuardError (renv.env,NotEnoughArgumentsForFixCall fx))
@@ -683,8 +639,11 @@ let error_partial_apply renv fx =
let check_one_fix renv recpos def =
let nfi = Array.length recpos in
- (* Checks if [t] only make valid recursive calls *)
- let rec check_rec_call renv t =
+ (* Checks if [t] only make valid recursive calls
+ [stack] is the list of constructor's argument specification and
+ arguments than will be applied after reduction.
+ example u in t where we have (match .. with |.. => t end) u *)
+ let rec check_rec_call renv stack t =
(* if [t] does not make recursive calls, it is guarded: *)
if noccur_with_meta renv.rel_min nfi t then ()
else
@@ -694,35 +653,43 @@ let check_one_fix renv recpos def =
(* Test if [p] is a fixpoint (recursive call) *)
if renv.rel_min <= p & p < renv.rel_min+nfi then
begin
- List.iter (check_rec_call renv) l;
+ List.iter (check_rec_call renv []) l;
(* the position of the invoked fixpoint: *)
let glob = renv.rel_min+nfi-1-p in
(* the decreasing arg of the rec call: *)
let np = recpos.(glob) in
- if List.length l <= np then error_partial_apply renv glob
+ let stack' = push_stack_closures renv l stack in
+ if List.length stack' <= np then error_partial_apply renv glob
else
(* Check the decreasing arg is smaller *)
- let z = List.nth l np in
- if not (check_is_subterm renv z) then
- error_illegal_rec_call renv glob z
+ let z = List.nth stack' np in
+ if not (check_is_subterm (stack_element_specif z)) then
+ begin match z with
+ |SClosure (z,z') -> error_illegal_rec_call renv glob (z,z')
+ |SArg _ -> error_partial_apply renv glob
+ end
end
else
begin
match pi2 (lookup_rel p renv.env) with
| None ->
- List.iter (check_rec_call renv) l
+ List.iter (check_rec_call renv []) l
| Some c ->
- try List.iter (check_rec_call renv) l
+ try List.iter (check_rec_call renv []) l
with FixGuardError _ ->
- check_rec_call renv (applist(lift p c,l))
+ check_rec_call renv stack (applist(lift p c,l))
end
-
+
| Case (ci,p,c_0,lrest) ->
- List.iter (check_rec_call renv) (c_0::p::l);
+ List.iter (check_rec_call renv []) (c_0::p::l);
(* compute the recarg information for the arguments of
each branch *)
- let lbr = case_subterm_specif renv ci c_0 lrest in
- Array.iter (fun (renv',br') -> check_rec_call renv' br') lbr
+ let case_spec = branches_specif renv
+ (lazy_subterm_specif renv [] c_0) ci in
+ let stack' = push_stack_closures renv l stack in
+ Array.iteri (fun k br' ->
+ let stack_br = push_stack_args case_spec.(k) stack' in
+ check_rec_call renv stack_br br') lrest
(* Enables to traverse Fixpoint definitions in a more intelligent
way, ie, the rule :
@@ -737,79 +704,79 @@ let check_one_fix renv recpos def =
then f is guarded with respect to S in (g a1 ... am).
Eduardo 7/9/98 *)
| Fix ((recindxs,i),(_,typarray,bodies as recdef)) ->
- List.iter (check_rec_call renv) l;
- Array.iter (check_rec_call renv) typarray;
+ List.iter (check_rec_call renv []) l;
+ Array.iter (check_rec_call renv []) typarray;
let decrArg = recindxs.(i) in
let renv' = push_fix_renv renv recdef in
- if (List.length l < (decrArg+1)) then
- Array.iter (check_rec_call renv') bodies
- else
+ let stack' = push_stack_closures renv l stack in
Array.iteri
(fun j body ->
- if i=j then
- let theDecrArg = List.nth l decrArg in
- let arg_spec = lazy_subterm_specif renv theDecrArg in
- check_nested_fix_body renv' (decrArg+1) arg_spec body
- else check_rec_call renv' body)
+ if i=j && (List.length stack' > decrArg) then
+ let recArg = List.nth stack' decrArg in
+ let arg_sp = stack_element_specif recArg in
+ check_nested_fix_body renv' (decrArg+1) arg_sp body
+ else check_rec_call renv' [] body)
bodies
| Const kn ->
if evaluable_constant kn renv.env then
- try List.iter (check_rec_call renv) l
+ try List.iter (check_rec_call renv []) l
with (FixGuardError _ ) ->
- check_rec_call renv(applist(constant_value renv.env kn, l))
- else List.iter (check_rec_call renv) l
-
- (* The cases below simply check recursively the condition on the
- subterms *)
- | Cast (a,_, b) ->
- List.iter (check_rec_call renv) (a::b::l)
+ let value = (applist(constant_value renv.env kn, l)) in
+ check_rec_call renv stack value
+ else List.iter (check_rec_call renv []) l
| Lambda (x,a,b) ->
- List.iter (check_rec_call renv) (a::l);
- check_rec_call (push_var_renv renv (x,a)) b
+ assert (l = []);
+ check_rec_call renv [] a ;
+ let spec, stack' = extract_stack renv a stack in
+ check_rec_call (push_var renv (x,a,spec)) stack' b
| Prod (x,a,b) ->
- List.iter (check_rec_call renv) (a::l);
- check_rec_call (push_var_renv renv (x,a)) b
+ assert (l = [] && stack = []);
+ check_rec_call renv [] a;
+ check_rec_call (push_var_renv renv (x,a)) [] b
| CoFix (i,(_,typarray,bodies as recdef)) ->
- List.iter (check_rec_call renv) l;
- Array.iter (check_rec_call renv) typarray;
+ List.iter (check_rec_call renv []) l;
+ Array.iter (check_rec_call renv []) typarray;
let renv' = push_fix_renv renv recdef in
- Array.iter (check_rec_call renv') bodies
+ Array.iter (check_rec_call renv' []) bodies
- | (Ind _ | Construct _ | Sort _) ->
- List.iter (check_rec_call renv) l
+ | (Ind _ | Construct _) ->
+ List.iter (check_rec_call renv []) l
| Var id ->
begin
match pi2 (lookup_named id renv.env) with
| None ->
- List.iter (check_rec_call renv) l
+ List.iter (check_rec_call renv []) l
| Some c ->
- try List.iter (check_rec_call renv) l
- with (FixGuardError _) -> check_rec_call renv (applist(c,l))
+ try List.iter (check_rec_call renv []) l
+ with (FixGuardError _) ->
+ check_rec_call renv stack (applist(c,l))
end
+ | Sort _ -> assert (l = [])
+
(* l is not checked because it is considered as the meta's context *)
| (Evar _ | Meta _) -> ()
- | (App _ | LetIn _) -> assert false (* beta zeta reduction *)
+ | (App _ | LetIn _ | Cast _) -> assert false (* beta zeta reduction *)
and check_nested_fix_body renv decr recArgsDecrArg body =
if decr = 0 then
- check_rec_call (assign_var_spec renv (1,recArgsDecrArg)) body
+ check_rec_call (assign_var_spec renv (1,recArgsDecrArg)) [] body
else
match kind_of_term body with
| Lambda (x,a,b) ->
- check_rec_call renv a;
+ check_rec_call renv [] a;
let renv' = push_var_renv renv (x,a) in
- check_nested_fix_body renv' (decr-1) recArgsDecrArg b
+ check_nested_fix_body renv' (decr-1) recArgsDecrArg b
| _ -> anomaly "Not enough abstractions in fix body"
-
+
in
- check_rec_call renv def
+ check_rec_call renv [] def
let judgment_of_fixpoint (_, types, bodies) =
array_map2 (fun typ body -> { uj_val = body ; uj_type = typ }) types bodies
@@ -856,7 +823,7 @@ let check_fix env ((nvect,_),(names,_,bodies as recdef) as fix) =
let (minds, rdef) = inductive_of_mutfix env fix in
for i = 0 to Array.length bodies - 1 do
let (fenv,body) = rdef.(i) in
- let renv = make_renv fenv minds nvect.(i) minds.(i) in
+ let renv = make_renv fenv nvect.(i) minds.(i) in
try check_one_fix renv nvect body
with FixGuardError (fixenv,err) ->
error_ill_formed_rec_body fixenv err names i
diff --git a/kernel/inductive.mli b/kernel/inductive.mli
index 0dac719c..a124647c 100644
--- a/kernel/inductive.mli
+++ b/kernel/inductive.mli
@@ -1,24 +1,20 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: inductive.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
open Names
open Univ
open Term
open Declarations
open Environ
-(*i*)
-(*s Extracting an inductive type from a construction *)
+(** {6 Extracting an inductive type from a construction } *)
-(* [find_m*type env sigma c] coerce [c] to an recursive type (I args).
+(** [find_m*type env sigma c] coerce [c] to an recursive type (I args).
[find_rectype], [find_inductive] and [find_coinductive]
respectively accepts any recursive type, only an inductive type and
only a coinductive type.
@@ -30,32 +26,33 @@ val find_coinductive : env -> types -> inductive * constr list
type mind_specif = mutual_inductive_body * one_inductive_body
-(*s Fetching information in the environment about an inductive type.
+(** {6 ... } *)
+(** Fetching information in the environment about an inductive type.
Raises [Not_found] if the inductive type is not found. *)
val lookup_mind_specif : env -> inductive -> mind_specif
-(*s Functions to build standard types related to inductive *)
+(** {6 Functions to build standard types related to inductive } *)
val ind_subst : mutual_inductive -> mutual_inductive_body -> constr list
val type_of_inductive : env -> mind_specif -> types
val elim_sorts : mind_specif -> sorts_family list
-(* Return type as quoted by the user *)
+(** Return type as quoted by the user *)
val type_of_constructor : constructor -> mind_specif -> types
-(* Return constructor types in normal form *)
+(** Return constructor types in normal form *)
val arities_of_constructors : inductive -> mind_specif -> types array
-(* Return constructor types in user form *)
+(** Return constructor types in user form *)
val type_of_constructors : inductive -> mind_specif -> types array
-(* Transforms inductive specification into types (in nf) *)
+(** Transforms inductive specification into types (in nf) *)
val arities_of_specif : mutual_inductive -> mind_specif -> types array
val inductive_params : mind_specif -> int
-(* [type_case_branches env (I,args) (p:A) c] computes useful types
+(** [type_case_branches env (I,args) (p:A) c] computes useful types
about the following Cases expression:
<p>Cases (c :: (I args)) of b1..bn end
It computes the type of every branch (pattern variables are
@@ -70,20 +67,20 @@ val build_branches_type :
inductive -> mutual_inductive_body * one_inductive_body ->
constr list -> constr -> types array
-(* Return the arity of an inductive type *)
+(** Return the arity of an inductive type *)
val mind_arity : one_inductive_body -> rel_context * sorts_family
val inductive_sort_family : one_inductive_body -> sorts_family
-(* Check a [case_info] actually correspond to a Case expression on the
+(** Check a [case_info] actually correspond to a Case expression on the
given inductive type. *)
val check_case_info : env -> inductive -> case_info -> unit
-(*s Guard conditions for fix and cofix-points. *)
+(** {6 Guard conditions for fix and cofix-points. } *)
val check_fix : env -> fixpoint -> unit
val check_cofix : env -> cofixpoint -> unit
-(*s Support for sort-polymorphic inductive types *)
+(** {6 Support for sort-polymorphic inductive types } *)
(** The "polyprop" optional argument below allows to control
the "Prop-polymorphism". By default, it is allowed.
@@ -102,8 +99,7 @@ val max_inductive_sort : sorts array -> universe
val instantiate_universes : env -> rel_context ->
polymorphic_arity -> types array -> rel_context * sorts
-(***************************************************************)
-(* Debug *)
+(** {6 Debug} *)
type size = Large | Strict
type subterm_spec =
@@ -112,16 +108,13 @@ type subterm_spec =
| Not_subterm
type guard_env =
{ env : env;
- (* dB of last fixpoint *)
+ (** dB of last fixpoint *)
rel_min : int;
- (* inductive of recarg of each fixpoint *)
- inds : inductive array;
- (* the recarg information of inductive family *)
- recvec : wf_paths array;
- (* dB of variables denoting subterms *)
+ (** dB of variables denoting subterms *)
genv : subterm_spec Lazy.t list;
}
-val subterm_specif : guard_env -> constr -> subterm_spec
-val case_branches_specif : guard_env -> subterm_spec Lazy.t -> inductive ->
- constr array -> (guard_env * constr) array
+type stack_element = |SClosure of guard_env*constr |SArg of subterm_spec Lazy.t
+
+val subterm_specif : guard_env -> stack_element list -> constr -> subterm_spec
+
diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml
index ab8b60be..314cc0ee 100644
--- a/kernel/mod_subst.ml
+++ b/kernel/mod_subst.ml
@@ -1,305 +1,249 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: mod_subst.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
+(* Created by Claudio Sacerdoti from contents of term.ml, names.ml and
+ new support for constant inlining in functor application, Nov 2004 *)
+(* Optimizations and bug fixes by Élie Soubiran, from Feb 2008 *)
+
+(* This file provides types and functions for managing name
+ substitution in module constructions *)
open Pp
open Util
open Names
open Term
+(* For Inline, the int is an inlining level, and the constr (if present)
+ is the term into which we should inline *)
type delta_hint =
- Inline of constr option
+ | Inline of int * constr option
| Equiv of kernel_name
- | Prefix_equiv of module_path
-type delta_key =
- KN of kernel_name
- | MP of module_path
+(* NB: earlier constructor Prefix_equiv of module_path
+ is now stored in a separate table, see Deltamap.t below *)
+
+module Deltamap = struct
+ type t = module_path MPmap.t * delta_hint KNmap.t
+ let empty = MPmap.empty, KNmap.empty
+ let add_kn kn hint (mm,km) = (mm,KNmap.add kn hint km)
+ let add_mp mp mp' (mm,km) = (MPmap.add mp mp' mm, km)
+ let find_mp mp map = MPmap.find mp (fst map)
+ let find_kn kn map = KNmap.find kn (snd map)
+ let mem_mp mp map = MPmap.mem mp (fst map)
+ let mem_kn kn map = KNmap.mem kn (snd map)
+ let fold_kn f map i = KNmap.fold f (snd map) i
+ let fold fmp fkn (mm,km) i =
+ MPmap.fold fmp mm (KNmap.fold fkn km i)
+ let join map1 map2 = fold add_mp add_kn map1 map2
+end
+
+type delta_resolver = Deltamap.t
-module Deltamap = Map.Make(struct
- type t = delta_key
- let compare = Pervasives.compare
- end)
+let empty_delta_resolver = Deltamap.empty
-type delta_resolver = delta_hint Deltamap.t
+module MBImap = Map.Make
+ (struct
+ type t = mod_bound_id
+ let compare = Pervasives.compare
+ end)
+
+module Umap = struct
+ type 'a t = 'a MPmap.t * 'a MBImap.t
+ let empty = MPmap.empty, MBImap.empty
+ let is_empty (m1,m2) = MPmap.is_empty m1 && MBImap.is_empty m2
+ let add_mbi mbi x (m1,m2) = (m1,MBImap.add mbi x m2)
+ let add_mp mp x (m1,m2) = (MPmap.add mp x m1, m2)
+ let find_mp mp map = MPmap.find mp (fst map)
+ let find_mbi mbi map = MBImap.find mbi (snd map)
+ let mem_mp mp map = MPmap.mem mp (fst map)
+ let mem_mbi mbi map = MBImap.mem mbi (snd map)
+ let iter_mbi f map = MBImap.iter f (snd map)
+ let fold fmp fmbi (m1,m2) i =
+ MPmap.fold fmp m1 (MBImap.fold fmbi m2 i)
+ let join map1 map2 = fold add_mp add_mbi map1 map2
+end
-let empty_delta_resolver = Deltamap.empty
+type substitution = (module_path * delta_resolver) Umap.t
-type substitution_domain =
- | MBI of mod_bound_id
- | MPI of module_path
+let empty_subst = Umap.empty
-let string_of_subst_domain = function
- | MBI mbid -> debug_string_of_mbid mbid
- | MPI mp -> string_of_mp mp
+let is_empty_subst = Umap.is_empty
-module Umap = Map.Make(struct
- type t = substitution_domain
- let compare = Pervasives.compare
- end)
+(* <debug> *)
-type substitution = (module_path * delta_resolver) Umap.t
-
-let empty_subst = Umap.empty
+let string_of_hint = function
+ | Inline (_,Some _) -> "inline(Some _)"
+ | Inline _ -> "inline()"
+ | Equiv kn -> string_of_kn kn
+
+let debug_string_of_delta resolve =
+ let kn_to_string kn hint s =
+ s^", "^(string_of_kn kn)^"=>"^(string_of_hint hint)
+ in
+ let mp_to_string mp mp' s =
+ s^", "^(string_of_mp mp)^"=>"^(string_of_mp mp')
+ in
+ Deltamap.fold mp_to_string kn_to_string resolve ""
+
+let list_contents sub =
+ let one_pair (mp,reso) = (string_of_mp mp,debug_string_of_delta reso) in
+ let mp_one_pair mp0 p l = (string_of_mp mp0, one_pair p)::l in
+ let mbi_one_pair mbi p l = (debug_string_of_mbid mbi, one_pair p)::l in
+ Umap.fold mp_one_pair mbi_one_pair sub []
+
+let debug_string_of_subst sub =
+ let l = List.map (fun (s1,(s2,s3)) -> s1^"|->"^s2^"["^s3^"]")
+ (list_contents sub)
+ in
+ "{" ^ String.concat "; " l ^ "}"
+
+let debug_pr_delta resolve =
+ str (debug_string_of_delta resolve)
+
+let debug_pr_subst sub =
+ let l = list_contents sub in
+ let f (s1,(s2,s3)) = hov 2 (str s1 ++ spc () ++ str "|-> " ++ str s2 ++
+ spc () ++ str "[" ++ str s3 ++ str "]")
+ in
+ str "{" ++ hov 2 (prlist_with_sep pr_comma f l) ++ str "}"
+(* </debug> *)
-let string_of_subst_domain = function
- | MBI mbid -> debug_string_of_mbid mbid
- | MPI mp -> string_of_mp mp
-
-let add_mbid mbid mp resolve =
- Umap.add (MBI mbid) (mp,resolve)
-let add_mp mp1 mp2 resolve =
- Umap.add (MPI mp1) (mp2,resolve)
+(** Extending a [delta_resolver] *)
+let add_inline_delta_resolver kn (lev,oc) = Deltamap.add_kn kn (Inline (lev,oc))
+
+let add_kn_delta_resolver kn kn' = Deltamap.add_kn kn (Equiv kn')
+
+let add_mp_delta_resolver mp1 mp2 = Deltamap.add_mp mp1 mp2
+
+(** Extending a [substitution *)
+
+let add_mbid mbid mp resolve s = Umap.add_mbi mbid (mp,resolve) s
+let add_mp mp1 mp2 resolve s = Umap.add_mp mp1 (mp2,resolve) s
let map_mbid mbid mp resolve = add_mbid mbid mp resolve empty_subst
let map_mp mp1 mp2 resolve = add_mp mp1 mp2 resolve empty_subst
-let add_inline_delta_resolver con =
- Deltamap.add (KN(user_con con)) (Inline None)
-
-let add_inline_constr_delta_resolver con cstr =
- Deltamap.add (KN(user_con con)) (Inline (Some cstr))
-
-let add_constant_delta_resolver con =
- Deltamap.add (KN(user_con con)) (Equiv (canonical_con con))
-
-let add_mind_delta_resolver mind =
- Deltamap.add (KN(user_mind mind)) (Equiv (canonical_mind mind))
-
-let add_mp_delta_resolver mp1 mp2 =
- Deltamap.add (MP mp1) (Prefix_equiv mp2)
-
-let mp_in_delta mp =
- Deltamap.mem (MP mp)
-
-let con_in_delta con resolver =
-try
- match Deltamap.find (KN(user_con con)) resolver with
- | Inline _ | Prefix_equiv _ -> false
- | Equiv _ -> true
-with
- Not_found -> false
-
-let mind_in_delta mind resolver =
-try
- match Deltamap.find (KN(user_mind mind)) resolver with
- | Inline _ | Prefix_equiv _ -> false
- | Equiv _ -> true
-with
- Not_found -> false
-
-let delta_of_mp resolve mp =
- try
- match Deltamap.find (MP mp) resolve with
- | Prefix_equiv mp1 -> mp1
- | _ -> anomaly "mod_subst: bad association in delta_resolver"
- with
- Not_found -> mp
-
-let delta_of_kn resolve kn =
- try
- match Deltamap.find (KN kn) resolve with
- | Equiv kn1 -> kn1
- | Inline _ -> kn
- | _ -> anomaly
- "mod_subst: bad association in delta_resolver"
- with
- Not_found -> kn
+let mp_in_delta mp = Deltamap.mem_mp mp
-let remove_mp_delta_resolver resolver mp =
- Deltamap.remove (MP mp) resolver
+let kn_in_delta kn resolver =
+ try
+ match Deltamap.find_kn kn resolver with
+ | Equiv _ -> true
+ | Inline _ -> false
+ with Not_found -> false
-exception Inline_kn
+let con_in_delta con resolver = kn_in_delta (user_con con) resolver
+let mind_in_delta mind resolver = kn_in_delta (user_mind mind) resolver
-let rec find_prefix resolve mp =
+let mp_of_delta resolve mp =
+ try Deltamap.find_mp mp resolve with Not_found -> mp
+
+let rec find_prefix resolve mp =
let rec sub_mp = function
- | MPdot(mp,l) as mp_sup ->
- (try
- match Deltamap.find (MP mp_sup) resolve with
- | Prefix_equiv mp1 -> mp1
- | _ -> anomaly
- "mod_subst: bad association in delta_resolver"
- with
- Not_found -> MPdot(sub_mp mp,l))
- | p ->
- match Deltamap.find (MP p) resolve with
- | Prefix_equiv mp1 -> mp1
- | _ -> anomaly
- "mod_subst: bad association in delta_resolver"
+ | MPdot(mp,l) as mp_sup ->
+ (try Deltamap.find_mp mp_sup resolve
+ with Not_found -> MPdot(sub_mp mp,l))
+ | p -> Deltamap.find_mp p resolve
in
- try
- sub_mp mp
- with
- Not_found -> mp
+ try sub_mp mp with Not_found -> mp
-exception Change_equiv_to_inline of constr
+exception Change_equiv_to_inline of (int * constr)
let solve_delta_kn resolve kn =
- try
- match Deltamap.find (KN kn) resolve with
- | Equiv kn1 -> kn1
- | Inline (Some c) ->
- raise (Change_equiv_to_inline c)
- | Inline None -> raise Inline_kn
- | _ -> anomaly
- "mod_subst: bad association in delta_resolver"
- with
- Not_found | Inline_kn ->
- let mp,dir,l = repr_kn kn in
- let new_mp = find_prefix resolve mp in
- if mp == new_mp then
- kn
- else
- make_kn new_mp dir l
-
+ try
+ match Deltamap.find_kn kn resolve with
+ | Equiv kn1 -> kn1
+ | Inline (lev, Some c) -> raise (Change_equiv_to_inline (lev,c))
+ | Inline (_, None) -> raise Not_found
+ with Not_found ->
+ let mp,dir,l = repr_kn kn in
+ let new_mp = find_prefix resolve mp in
+ if mp == new_mp then
+ kn
+ else
+ make_kn new_mp dir l
+
+let kn_of_delta resolve kn =
+ try solve_delta_kn resolve kn
+ with _ -> kn
+
+let constant_of_delta_kn resolve kn =
+ constant_of_kn_equiv kn (kn_of_delta resolve kn)
+
+let gen_of_delta resolve x kn fix_can =
+ try
+ let new_kn = solve_delta_kn resolve kn in
+ if kn == new_kn then x else fix_can new_kn
+ with _ -> x
let constant_of_delta resolve con =
let kn = user_con con in
- try
- let new_kn = solve_delta_kn resolve kn in
- if kn == new_kn then
- con
- else
- constant_of_kn_equiv kn new_kn
- with
- _ -> con
-
+ gen_of_delta resolve con kn (constant_of_kn_equiv kn)
+
let constant_of_delta2 resolve con =
- let kn = canonical_con con in
- let kn1 = user_con con in
- try
- let new_kn = solve_delta_kn resolve kn in
- if kn == new_kn then
- con
- else
- constant_of_kn_equiv kn1 new_kn
- with
- _ -> con
+ let kn, kn' = canonical_con con, user_con con in
+ gen_of_delta resolve con kn (constant_of_kn_equiv kn')
+
+let mind_of_delta_kn resolve kn =
+ mind_of_kn_equiv kn (kn_of_delta resolve kn)
let mind_of_delta resolve mind =
let kn = user_mind mind in
- try
- let new_kn = solve_delta_kn resolve kn in
- if kn == new_kn then
- mind
- else
- mind_of_kn_equiv kn new_kn
- with
- _ -> mind
+ gen_of_delta resolve mind kn (mind_of_kn_equiv kn)
let mind_of_delta2 resolve mind =
- let kn = canonical_mind mind in
- let kn1 = user_mind mind in
- try
- let new_kn = solve_delta_kn resolve kn in
- if kn == new_kn then
- mind
- else
- mind_of_kn_equiv kn1 new_kn
- with
- _ -> mind
-
-
-let inline_of_delta resolver =
- let extract key hint l =
- match key,hint with
- |KN kn, Inline _ -> kn::l
- | _,_ -> l
- in
- Deltamap.fold extract resolver []
+ let kn, kn' = canonical_mind mind, user_mind mind in
+ gen_of_delta resolve mind kn (mind_of_kn_equiv kn')
+
+let inline_of_delta inline resolver =
+ match inline with
+ | None -> []
+ | Some inl_lev ->
+ let extract kn hint l =
+ match hint with
+ | Inline (lev,_) -> if lev <= inl_lev then (lev,kn)::l else l
+ | _ -> l
+ in
+ Deltamap.fold_kn extract resolver []
+
+let find_inline_of_delta kn resolve =
+ match Deltamap.find_kn kn resolve with
+ | Inline (_,o) -> o
+ | _ -> raise Not_found
-exception Not_inline
-
let constant_of_delta_with_inline resolve con =
let kn1,kn2 = canonical_con con,user_con con in
- try
- match Deltamap.find (KN kn2) resolve with
- | Inline None -> None
- | Inline (Some const) -> Some const
- | _ -> raise Not_inline
- with
- Not_found | Not_inline ->
- try match Deltamap.find (KN kn1) resolve with
- | Inline None -> None
- | Inline (Some const) -> Some const
- | _ -> raise Not_inline
- with
- Not_found | Not_inline -> None
-
-let string_of_key = function
- | KN kn -> string_of_kn kn
- | MP mp -> string_of_mp mp
+ try find_inline_of_delta kn2 resolve
+ with Not_found ->
+ try find_inline_of_delta kn1 resolve
+ with Not_found -> None
-let string_of_hint = function
- | Inline _ -> "inline"
- | Equiv kn -> string_of_kn kn
- | Prefix_equiv mp -> string_of_mp mp
-
-let debug_string_of_delta resolve =
- let to_string key hint s =
- s^", "^(string_of_key key)^"=>"^(string_of_hint hint)
- in
- Deltamap.fold to_string resolve ""
-
-let list_contents sub =
- let one_pair uid (mp,reso) l =
- (string_of_subst_domain uid, string_of_mp mp,debug_string_of_delta reso)::l
- in
- Umap.fold one_pair sub []
-
-let debug_string_of_subst sub =
- let l = List.map (fun (s1,s2,s3) -> s1^"|->"^s2^"["^s3^"]")
- (list_contents sub) in
- "{" ^ String.concat "; " l ^ "}"
-
-let debug_pr_delta resolve =
- str (debug_string_of_delta resolve)
-
-let debug_pr_subst sub =
- let l = list_contents sub in
- let f (s1,s2,s3) = hov 2 (str s1 ++ spc () ++ str "|-> " ++ str s2 ++
- spc () ++ str "[" ++ str s3 ++ str "]")
- in
- str "{" ++ hov 2 (prlist_with_sep pr_comma f l) ++ str "}"
-
-
let subst_mp0 sub mp = (* 's like subst *)
let rec aux mp =
match mp with
- | MPfile sid ->
- let mp',resolve = Umap.find (MPI (MPfile sid)) sub in
- mp',resolve
+ | MPfile sid -> Umap.find_mp mp sub
| MPbound bid ->
begin
- try
- let mp',resolve = Umap.find (MBI bid) sub in
- mp',resolve
- with Not_found ->
- let mp',resolve = Umap.find (MPI mp) sub in
- mp',resolve
+ try Umap.find_mbi bid sub
+ with Not_found -> Umap.find_mp mp sub
end
| MPdot (mp1,l) as mp2 ->
begin
- try
- let mp',resolve = Umap.find (MPI mp2) sub in
- mp',resolve
+ try Umap.find_mp mp2 sub
with Not_found ->
let mp1',resolve = aux mp1 in
- MPdot (mp1',l),resolve
+ MPdot (mp1',l),resolve
end
in
- try
- Some (aux mp)
- with Not_found -> None
+ try Some (aux mp) with Not_found -> None
let subst_mp sub mp =
match subst_mp0 sub mp with
@@ -327,107 +271,47 @@ type sideconstantsubst =
| User
| Canonical
-let subst_ind sub mind =
- let kn1,kn2 = user_mind mind,canonical_mind mind in
- let mp1,dir,l = repr_kn kn1 in
- let mp2,_,_ = repr_kn kn2 in
- try
- let side,mind',resolve =
- match subst_mp0 sub mp1,subst_mp0 sub mp2 with
- None,None ->raise No_subst
- | Some (mp',resolve),None -> User,(make_mind_equiv mp' mp2 dir l), resolve
- | None, Some(mp',resolve)-> Canonical,(make_mind_equiv mp1 mp' dir l), resolve
- | Some(mp1',resolve1),Some(mp2',resolve2)->Canonical,
- (make_mind_equiv mp1' mp2' dir l), resolve2
- in
- match side with
- |User ->
- let mind = mind_of_delta resolve mind' in
- mind
- |Canonical ->
- let mind = mind_of_delta2 resolve mind' in
- mind
- with
- No_subst -> mind
-
-let subst_mind0 sub mind =
- let kn1,kn2 = user_mind mind,canonical_mind mind in
- let mp1,dir,l = repr_kn kn1 in
- let mp2,_,_ = repr_kn kn2 in
- try
- let side,mind',resolve =
- match subst_mp0 sub mp1,subst_mp0 sub mp2 with
- None,None ->raise No_subst
- | Some (mp',resolve),None -> User,(make_mind_equiv mp' mp2 dir l), resolve
- | None, Some(mp',resolve)-> Canonical,(make_mind_equiv mp1 mp' dir l), resolve
- | Some(mp1',resolve1),Some(mp2',resolve2)->Canonical,
- (make_mind_equiv mp1' mp2' dir l), resolve2
- in
- match side with
- |User ->
- let mind = mind_of_delta resolve mind' in
- Some mind
- |Canonical ->
- let mind = mind_of_delta2 resolve mind' in
- Some mind
- with
- No_subst -> Some mind
+let gen_subst_mp f sub mp1 mp2 =
+ match subst_mp0 sub mp1, subst_mp0 sub mp2 with
+ | None, None -> raise No_subst
+ | Some (mp',resolve), None -> User, (f mp' mp2), resolve
+ | None, Some (mp',resolve) -> Canonical, (f mp1 mp'), resolve
+ | Some (mp1',_), Some (mp2',resolve2) -> Canonical, (f mp1' mp2'), resolve2
-let subst_con sub con =
- let kn1,kn2 = user_con con,canonical_con con in
+let subst_ind sub mind =
+ let kn1,kn2 = user_mind mind, canonical_mind mind in
let mp1,dir,l = repr_kn kn1 in
let mp2,_,_ = repr_kn kn2 in
- try
- let side,con',resolve =
- match subst_mp0 sub mp1,subst_mp0 sub mp2 with
- None,None ->raise No_subst
- | Some (mp',resolve),None -> User,(make_con_equiv mp' mp2 dir l), resolve
- | None, Some(mp',resolve)-> Canonical,(make_con_equiv mp1 mp' dir l), resolve
- | Some(mp1',resolve1),Some(mp2',resolve2)->Canonical,
- (make_con_equiv mp1' mp2' dir l), resolve2
- in
- match constant_of_delta_with_inline resolve con' with
- None -> begin
- match side with
- |User ->
- let con = constant_of_delta resolve con' in
- con,mkConst con
- |Canonical ->
- let con = constant_of_delta2 resolve con' in
- con,mkConst con
- end
- | Some t ->
- (* In case of inlining, discard the canonical part (cf #2608) *)
- constant_of_kn (user_con con'), t
- with No_subst -> con , mkConst con
-
+ let rebuild_mind mp1 mp2 = make_mind_equiv mp1 mp2 dir l in
+ try
+ let side,mind',resolve = gen_subst_mp rebuild_mind sub mp1 mp2 in
+ match side with
+ | User -> mind_of_delta resolve mind'
+ | Canonical -> mind_of_delta2 resolve mind'
+ with No_subst -> mind
let subst_con0 sub con =
let kn1,kn2 = user_con con,canonical_con con in
let mp1,dir,l = repr_kn kn1 in
let mp2,_,_ = repr_kn kn2 in
- try
- let side,con',resolve =
- match subst_mp0 sub mp1,subst_mp0 sub mp2 with
- None,None ->raise No_subst
- | Some (mp',resolve),None -> User,(make_con_equiv mp' mp2 dir l), resolve
- | None, Some(mp',resolve)-> Canonical,(make_con_equiv mp1 mp' dir l), resolve
- | Some(mp1',resolve1),Some(mp2',resolve2)->Canonical,
- (make_con_equiv mp1' mp2' dir l), resolve2
+ let rebuild_con mp1 mp2 = make_con_equiv mp1 mp2 dir l in
+ let dup con = con, mkConst con in
+ let side,con',resolve = gen_subst_mp rebuild_con sub mp1 mp2 in
+ match constant_of_delta_with_inline resolve con' with
+ | Some t ->
+ (* In case of inlining, discard the canonical part (cf #2608) *)
+ constant_of_kn (user_con con'), t
+ | None ->
+ let con'' = match side with
+ | User -> constant_of_delta resolve con'
+ | Canonical -> constant_of_delta2 resolve con'
in
- match constant_of_delta_with_inline resolve con' with
- None ->begin
- match side with
- |User ->
- let con = constant_of_delta resolve con' in
- Some (mkConst con)
- |Canonical ->
- let con = constant_of_delta2 resolve con' in
- Some (mkConst con)
- end
- | t -> t
- with No_subst -> Some (mkConst con)
-
+ if con'' == con then raise No_subst else dup con''
+
+let subst_con sub con =
+ try subst_con0 sub con
+ with No_subst -> con, mkConst con
+
(* Here the semantics is completely unclear.
What does "Hint Unfold t" means when "t" is a parameter?
Does the user mean "Unfold X.t" or does she mean "Unfold y"
@@ -437,29 +321,22 @@ let subst_evaluable_reference subst = function
| EvalVarRef id -> EvalVarRef id
| EvalConstRef kn -> EvalConstRef (fst (subst_con subst kn))
-
-
let rec map_kn f f' c =
let func = map_kn f f' in
match kind_of_term c with
- | Const kn ->
- (match f' kn with
- None -> c
- | Some const ->const)
+ | Const kn -> (try snd (f' kn) with No_subst -> c)
| Ind (kn,i) ->
- (match f kn with
- None -> c
- | Some kn' ->
- mkInd (kn',i))
+ let kn' = f kn in
+ if kn'==kn then c else mkInd (kn',i)
| Construct ((kn,i),j) ->
- (match f kn with
- None -> c
- | Some kn' ->
- mkConstruct ((kn',i),j))
+ let kn' = f kn in
+ if kn'==kn then c else mkConstruct ((kn',i),j)
| Case (ci,p,ct,l) ->
let ci_ind =
let (kn,i) = ci.ci_ind in
- (match f kn with None -> ci.ci_ind | Some kn' -> kn',i ) in
+ let kn' = f kn in
+ if kn'==kn then ci.ci_ind else kn',i
+ in
let p' = func p in
let ct' = func ct in
let l' = array_smartmap func l in
@@ -510,8 +387,9 @@ let rec map_kn f f' c =
else mkCoFix (ln,(lna,tl',bl'))
| _ -> c
-let subst_mps sub =
- map_kn (subst_mind0 sub) (subst_con0 sub)
+let subst_mps sub c =
+ if is_empty_subst sub then c
+ else map_kn (subst_ind sub) (subst_con0 sub) c
let rec replace_mp_in_mp mpfrom mpto mp =
match mp with
@@ -533,117 +411,76 @@ let rec mp_in_mp mp mp1 =
| _ when mp1 = mp -> true
| MPdot (mp2,l) -> mp_in_mp mp mp2
| _ -> false
-
-let mp_in_key mp key =
- match key with
- | MP mp1 ->
- mp_in_mp mp mp1
- | KN kn ->
- let mp1,dir,l = repr_kn kn in
- mp_in_mp mp mp1
-
+
let subset_prefixed_by mp resolver =
- let prefixmp key hint resolv =
- match hint with
- | Inline _ -> resolv
- | _ ->
- if mp_in_key mp key then
- Deltamap.add key hint resolv
- else
- resolv
+ let mp_prefix mkey mequ rslv =
+ if mp_in_mp mp mkey then Deltamap.add_mp mkey mequ rslv else rslv
+ in
+ let kn_prefix kn hint rslv =
+ match hint with
+ | Inline _ -> rslv
+ | Equiv _ ->
+ if mp_in_mp mp (modpath kn) then Deltamap.add_kn kn hint rslv else rslv
in
- Deltamap.fold prefixmp resolver empty_delta_resolver
+ Deltamap.fold mp_prefix kn_prefix resolver empty_delta_resolver
let subst_dom_delta_resolver subst resolver =
- let apply_subst key hint resolver =
- match key with
- (MP mp) ->
- Deltamap.add (MP (subst_mp subst mp)) hint resolver
- | (KN kn) ->
- Deltamap.add (KN (subst_kn subst kn)) hint resolver
+ let mp_apply_subst mkey mequ rslv =
+ Deltamap.add_mp (subst_mp subst mkey) mequ rslv
+ in
+ let kn_apply_subst kkey hint rslv =
+ Deltamap.add_kn (subst_kn subst kkey) hint rslv
in
- Deltamap.fold apply_subst resolver empty_delta_resolver
+ Deltamap.fold mp_apply_subst kn_apply_subst resolver empty_delta_resolver
-let subst_mp_delta sub mp key=
+let subst_mp_delta sub mp mkey =
match subst_mp0 sub mp with
None -> empty_delta_resolver,mp
- | Some (mp',resolve) ->
+ | Some (mp',resolve) ->
let mp1 = find_prefix resolve mp' in
let resolve1 = subset_prefixed_by mp1 resolve in
- match key with
- MP mpk ->
- (subst_dom_delta_resolver
- (map_mp mp1 mpk empty_delta_resolver) resolve1),mp1
- | _ -> anomaly "Mod_subst: Bad association in resolver"
-
-let subst_codom_delta_resolver subst resolver =
- let apply_subst key hint resolver =
- match hint with
- Prefix_equiv mp ->
- let derived_resolve,mpnew = subst_mp_delta subst mp key in
- Deltamap.fold Deltamap.add derived_resolve
- (Deltamap.add key (Prefix_equiv mpnew) resolver)
- | (Equiv kn) ->
- (try
- Deltamap.add key (Equiv (subst_kn_delta subst kn)) resolver
- with
- Change_equiv_to_inline c ->
- Deltamap.add key (Inline (Some c)) resolver)
- | Inline None ->
- Deltamap.add key hint resolver
- | Inline (Some t) ->
- Deltamap.add key (Inline (Some (subst_mps subst t))) resolver
+ (subst_dom_delta_resolver
+ (map_mp mp1 mkey empty_delta_resolver) resolve1),mp1
+
+let gen_subst_delta_resolver dom subst resolver =
+ let mp_apply_subst mkey mequ rslv =
+ let mkey' = if dom then subst_mp subst mkey else mkey in
+ let rslv',mequ' = subst_mp_delta subst mequ mkey in
+ Deltamap.join rslv' (Deltamap.add_mp mkey' mequ' rslv)
in
- Deltamap.fold apply_subst resolver empty_delta_resolver
-
-let subst_dom_codom_delta_resolver subst resolver =
- let apply_subst key hint resolver =
- match key,hint with
- (MP mp1),Prefix_equiv mp ->
- let key = MP (subst_mp subst mp1) in
- let derived_resolve,mpnew = subst_mp_delta subst mp key in
- Deltamap.fold Deltamap.add derived_resolve
- (Deltamap.add key (Prefix_equiv mpnew) resolver)
- | (KN kn1),(Equiv kn) ->
- let key = KN (subst_kn subst kn1) in
- (try
- Deltamap.add key (Equiv (subst_kn_delta subst kn)) resolver
- with
- Change_equiv_to_inline c ->
- Deltamap.add key (Inline (Some c)) resolver)
- | (KN kn),Inline None ->
- let key = KN (subst_kn subst kn) in
- Deltamap.add key hint resolver
- | (KN kn),Inline (Some t) ->
- let key = KN (subst_kn subst kn) in
- Deltamap.add key (Inline (Some (subst_mps subst t))) resolver
- | _,_ -> anomaly "Mod_subst: Bad association in resolver"
+ let kn_apply_subst kkey hint rslv =
+ let kkey' = if dom then subst_kn subst kkey else kkey in
+ let hint' = match hint with
+ | Equiv kequ ->
+ (try Equiv (subst_kn_delta subst kequ)
+ with Change_equiv_to_inline (lev,c) -> Inline (lev,Some c))
+ | Inline (lev,Some t) -> Inline (lev,Some (subst_mps subst t))
+ | Inline (_,None) -> hint
+ in
+ Deltamap.add_kn kkey' hint' rslv
in
- Deltamap.fold apply_subst resolver empty_delta_resolver
+ Deltamap.fold mp_apply_subst kn_apply_subst resolver empty_delta_resolver
+
+let subst_codom_delta_resolver = gen_subst_delta_resolver false
+let subst_dom_codom_delta_resolver = gen_subst_delta_resolver true
let update_delta_resolver resolver1 resolver2 =
- let apply_res key hint res =
- try
- if Deltamap.mem key resolver2 then
- res else
- match hint with
- Prefix_equiv mp ->
- let new_hint =
- Prefix_equiv (find_prefix resolver2 mp)
- in Deltamap.add key new_hint res
- | Equiv kn ->
- (try
- let new_hint =
- Equiv (solve_delta_kn resolver2 kn)
- in Deltamap.add key new_hint res
- with
- Change_equiv_to_inline c ->
- Deltamap.add key (Inline (Some c)) res)
- | _ -> Deltamap.add key hint res
- with Not_found ->
- Deltamap.add key hint res
- in
- Deltamap.fold apply_res resolver1 empty_delta_resolver
+ let mp_apply_rslv mkey mequ rslv =
+ if Deltamap.mem_mp mkey resolver2 then rslv
+ else Deltamap.add_mp mkey (find_prefix resolver2 mequ) rslv
+ in
+ let kn_apply_rslv kkey hint rslv =
+ if Deltamap.mem_kn kkey resolver2 then rslv
+ else
+ let hint' = match hint with
+ | Equiv kequ ->
+ (try Equiv (solve_delta_kn resolver2 kequ)
+ with Change_equiv_to_inline (lev,c) -> Inline (lev, Some c))
+ | _ -> hint
+ in
+ Deltamap.add_kn kkey hint' rslv
+ in
+ Deltamap.fold mp_apply_rslv kn_apply_rslv resolver1 empty_delta_resolver
let add_delta_resolver resolver1 resolver2 =
if resolver1 == resolver2 then
@@ -651,63 +488,54 @@ let add_delta_resolver resolver1 resolver2 =
else if resolver2 = empty_delta_resolver then
resolver1
else
- Deltamap.fold Deltamap.add (update_delta_resolver resolver1 resolver2)
- resolver2
+ Deltamap.join (update_delta_resolver resolver1 resolver2) resolver2
let substition_prefixed_by k mp subst =
- let prefixmp key (mp_to,reso) sub =
- match key with
- | MPI mpk ->
- if mp_in_mp mp mpk && mp <> mpk then
- let new_key = replace_mp_in_mp mp k mpk in
- Umap.add (MPI new_key) (mp_to,reso) sub
- else
- sub
- | _ -> sub
+ let mp_prefixmp kmp (mp_to,reso) sub =
+ if mp_in_mp mp kmp && mp <> kmp then
+ let new_key = replace_mp_in_mp mp k kmp in
+ Umap.add_mp new_key (mp_to,reso) sub
+ else sub
+ in
+ let mbi_prefixmp mbi _ sub = sub
in
- Umap.fold prefixmp subst empty_subst
+ Umap.fold mp_prefixmp mbi_prefixmp subst empty_subst
-let join (subst1 : substitution) (subst2 : substitution) =
- let apply_subst key (mp,resolve) res =
+let join subst1 subst2 =
+ let apply_subst mpk add (mp,resolve) res =
let mp',resolve' =
match subst_mp0 subst2 mp with
- None -> mp, None
- | Some (mp',resolve') -> mp'
- ,Some resolve' in
- let resolve'' : delta_resolver =
+ | None -> mp, None
+ | Some (mp',resolve') -> mp', Some resolve' in
+ let resolve'' =
match resolve' with
- Some res ->
- add_delta_resolver
+ | Some res ->
+ add_delta_resolver
(subst_dom_codom_delta_resolver subst2 resolve) res
- | None ->
+ | None ->
subst_codom_delta_resolver subst2 resolve
in
- let k = match key with MBI mp -> MPbound mp | MPI mp -> mp in
- let prefixed_subst = substition_prefixed_by k mp subst2 in
- Umap.fold Umap.add prefixed_subst
- (Umap.add key (mp',resolve'') res) in
- let subst = Umap.fold apply_subst subst1 empty_subst in
- (Umap.fold Umap.add subst2 subst)
-
-
-
-let rec occur_in_path uid path =
- match uid,path with
- | MBI bid,MPbound bid' -> bid = bid'
- | _,MPdot (mp1,_) -> occur_in_path uid mp1
+ let prefixed_subst = substition_prefixed_by mpk mp' subst2 in
+ Umap.join prefixed_subst (add (mp',resolve'') res)
+ in
+ let mp_apply_subst mp = apply_subst mp (Umap.add_mp mp) in
+ let mbi_apply_subst mbi = apply_subst (MPbound mbi) (Umap.add_mbi mbi) in
+ let subst = Umap.fold mp_apply_subst mbi_apply_subst subst1 empty_subst in
+ Umap.join subst2 subst
+
+let rec occur_in_path mbi = function
+ | MPbound bid' -> mbi = bid'
+ | MPdot (mp1,_) -> occur_in_path mbi mp1
| _ -> false
-let occur_uid uid sub =
- let check_one uid' (mp,_) =
- if uid = uid' || occur_in_path uid mp then raise Exit
+let occur_mbid mbi sub =
+ let check_one mbi' (mp,_) =
+ if mbi = mbi' || occur_in_path mbi mp then raise Exit
in
- try
- Umap.iter check_one sub;
- false
- with Exit -> true
-
-
-let occur_mbid uid = occur_uid (MBI uid)
+ try
+ Umap.iter_mbi check_one sub;
+ false
+ with Exit -> true
type 'a lazy_subst =
| LSval of 'a
diff --git a/kernel/mod_subst.mli b/kernel/mod_subst.mli
index 9b48b3ea..55d2ff15 100644
--- a/kernel/mod_subst.mli
+++ b/kernel/mod_subst.mli
@@ -1,105 +1,108 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: mod_subst.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*s [Mod_subst] *)
+(** {6 [Mod_subst] } *)
open Names
open Term
-(* A delta_resolver maps name (constant, inductive, module_path)
+(** {6 Delta resolver} *)
+
+(** A delta_resolver maps name (constant, inductive, module_path)
to canonical name *)
type delta_resolver
-type substitution
-
val empty_delta_resolver : delta_resolver
-val add_inline_delta_resolver : constant -> delta_resolver -> delta_resolver
+val add_mp_delta_resolver :
+ module_path -> module_path -> delta_resolver -> delta_resolver
-val add_inline_constr_delta_resolver : constant -> constr -> delta_resolver
- -> delta_resolver
+val add_kn_delta_resolver :
+ kernel_name -> kernel_name -> delta_resolver -> delta_resolver
-val add_constant_delta_resolver : constant -> delta_resolver -> delta_resolver
-
-val add_mind_delta_resolver : mutual_inductive -> delta_resolver -> delta_resolver
-
-val add_mp_delta_resolver : module_path -> module_path -> delta_resolver
- -> delta_resolver
+val add_inline_delta_resolver :
+ kernel_name -> (int * constr option) -> delta_resolver -> delta_resolver
val add_delta_resolver : delta_resolver -> delta_resolver -> delta_resolver
-(* Apply the substitution on the domain of the resolver *)
-val subst_dom_delta_resolver : substitution -> delta_resolver -> delta_resolver
+(** Effect of a [delta_resolver] on kernel name, constant, inductive, etc *)
-(* Apply the substitution on the codomain of the resolver *)
-val subst_codom_delta_resolver : substitution -> delta_resolver -> delta_resolver
-
-val subst_dom_codom_delta_resolver :
- substitution -> delta_resolver -> delta_resolver
-
-(* *_of_delta return the associated name of arg2 in arg1 *)
+val kn_of_delta : delta_resolver -> kernel_name -> kernel_name
+val constant_of_delta_kn : delta_resolver -> kernel_name -> constant
val constant_of_delta : delta_resolver -> constant -> constant
+val mind_of_delta_kn : delta_resolver -> kernel_name -> mutual_inductive
val mind_of_delta : delta_resolver -> mutual_inductive -> mutual_inductive
-val delta_of_mp : delta_resolver -> module_path -> module_path
+val mp_of_delta : delta_resolver -> module_path -> module_path
-(* Extract the set of inlined constant in the resolver *)
-val inline_of_delta : delta_resolver -> kernel_name list
+(** Extract the set of inlined constant in the resolver *)
+val inline_of_delta : int option -> delta_resolver -> (int * kernel_name) list
-(* remove_mp is used for the computation of a resolver induced by Include P *)
-val remove_mp_delta_resolver : delta_resolver -> module_path -> delta_resolver
+(** Does a [delta_resolver] contains a [mp], a constant, an inductive ? *)
-
-(* mem tests *)
val mp_in_delta : module_path -> delta_resolver -> bool
-
val con_in_delta : constant -> delta_resolver -> bool
-
val mind_in_delta : mutual_inductive -> delta_resolver -> bool
-(*substitution*)
+
+(** {6 Substitution} *)
+
+type substitution
val empty_subst : substitution
-(* add_* add [arg2/arg1]{arg3} to the substitution with no
+val is_empty_subst : substitution -> bool
+
+(** add_* add [arg2/arg1]\{arg3\} to the substitution with no
sequential composition *)
val add_mbid :
mod_bound_id -> module_path -> delta_resolver -> substitution -> substitution
val add_mp :
module_path -> module_path -> delta_resolver -> substitution -> substitution
-(* map_* create a new substitution [arg2/arg1]{arg3} *)
+(** map_* create a new substitution [arg2/arg1]\{arg3\} *)
val map_mbid :
mod_bound_id -> module_path -> delta_resolver -> substitution
val map_mp :
module_path -> module_path -> delta_resolver -> substitution
-(* sequential composition:
+(** sequential composition:
[substitute (join sub1 sub2) t = substitute sub2 (substitute sub1 t)]
*)
val join : substitution -> substitution -> substitution
+
+(** Apply the substitution on the domain of the resolver *)
+val subst_dom_delta_resolver : substitution -> delta_resolver -> delta_resolver
+
+(** Apply the substitution on the codomain of the resolver *)
+val subst_codom_delta_resolver :
+ substitution -> delta_resolver -> delta_resolver
+
+val subst_dom_codom_delta_resolver :
+ substitution -> delta_resolver -> delta_resolver
+
+
type 'a substituted
val from_val : 'a -> 'a substituted
val force : (substitution -> 'a -> 'a) -> 'a substituted -> 'a
val subst_substituted : substitution -> 'a substituted -> 'a substituted
-(*i debugging *)
+(**/**)
+(* debugging *)
val debug_string_of_subst : substitution -> string
val debug_pr_subst : substitution -> Pp.std_ppcmds
val debug_string_of_delta : delta_resolver -> string
val debug_pr_delta : delta_resolver -> Pp.std_ppcmds
-(*i*)
+(**/**)
-(* [subst_mp sub mp] guarantees that whenever the result of the
+(** [subst_mp sub mp] guarantees that whenever the result of the
substitution is structutally equal [mp], it is equal by pointers
as well [==] *)
@@ -109,13 +112,13 @@ val subst_mp :
val subst_ind :
substitution -> mutual_inductive -> mutual_inductive
-val subst_kn :
+val subst_kn :
substitution -> kernel_name -> kernel_name
val subst_con :
substitution -> constant -> constant * constr
-(* Here the semantics is completely unclear.
+(** Here the semantics is completely unclear.
What does "Hint Unfold t" means when "t" is a parameter?
Does the user mean "Unfold X.t" or does she mean "Unfold y"
where X.t is later on instantiated with y? I choose the first
@@ -123,14 +126,14 @@ val subst_con :
val subst_evaluable_reference :
substitution -> evaluable_global_reference -> evaluable_global_reference
-(* [replace_mp_in_con mp mp' con] replaces [mp] with [mp'] in [con] *)
+(** [replace_mp_in_con mp mp' con] replaces [mp] with [mp'] in [con] *)
val replace_mp_in_kn : module_path -> module_path -> kernel_name -> kernel_name
-(* [subst_mps sub c] performs the substitution [sub] on all kernel
+(** [subst_mps sub c] performs the substitution [sub] on all kernel
names appearing in [c] *)
val subst_mps : substitution -> constr -> constr
-(* [occur_*id id sub] returns true iff [id] occurs in [sub]
+(** [occur_*id id sub] returns true iff [id] occurs in [sub]
on either side *)
val occur_mbid : mod_bound_id -> substitution -> bool
diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml
index e366bc97..a384c836 100644
--- a/kernel/mod_typing.ml
+++ b/kernel/mod_typing.ml
@@ -1,12 +1,16 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: mod_typing.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
+(* Created by Jacek Chrzaszcz, Aug 2002 as part of the implementation of
+ the Coq module system *)
+
+(* This module provides the main functions for type-checking module
+ declarations *)
open Util
open Names
@@ -25,18 +29,17 @@ let path_of_mexpr = function
| MSEident mp -> mp
| _ -> raise Not_path
+let rec mp_from_mexpr = function
+ | MSEident mp -> mp
+ | MSEapply (expr,_) -> mp_from_mexpr expr
+ | MSEfunctor (_,_,expr) -> mp_from_mexpr expr
+ | MSEwith (expr,_) -> mp_from_mexpr expr
+
let rec list_split_assoc k rev_before = function
| [] -> raise Not_found
| (k',b)::after when k=k' -> rev_before,b,after
| h::tail -> list_split_assoc k (h::rev_before) tail
-let rec list_fold_map2 f e = function
- | [] -> (e,[],[])
- | h::t ->
- let e',h1',h2' = f e h in
- let e'',t1',t2' = list_fold_map2 f e' t in
- e'',h1'::t1',h2'::t2'
-
let discr_resolver env mtb =
match mtb.typ_expr with
SEBstruct _ ->
@@ -81,40 +84,41 @@ and check_with_aux_def env sign with_decl mp equiv =
| With_Definition ([],_) -> assert false
| With_Definition ([id],c) ->
let cb = match spec with
- SFBconst cb -> cb
+ | SFBconst cb -> cb
| _ -> error_not_a_constant l
in
- begin
- match cb.const_body with
- | None ->
- let (j,cst1) = Typeops.infer env' c in
- let typ = Typeops.type_of_constant_type env' cb.const_type in
- let cst2 = Reduction.conv_leq env' j.uj_type typ in
- let cst =
- Constraint.union
- (Constraint.union cb.const_constraints cst1)
- cst2 in
- let body = Some (Declarations.from_val j.uj_val) in
- let cb' = {cb with
- const_body = body;
- const_body_code = Cemitcodes.from_val
- (compile_constant_body env' body false false);
- const_constraints = cst} in
- SEBstruct(before@((l,SFBconst(cb'))::after)),cb',cst
- | Some b ->
- let cst1 = Reduction.conv env' c (Declarations.force b) in
- let cst = Constraint.union cb.const_constraints cst1 in
- let body = Some (Declarations.from_val c) in
- let cb' = {cb with
- const_body = body;
- const_body_code = Cemitcodes.from_val
- (compile_constant_body env' body false false);
- const_constraints = cst} in
- SEBstruct(before@((l,SFBconst(cb'))::after)),cb',cst
- end
+ (* In the spirit of subtyping.check_constant, we accept
+ any implementations of parameters and opaques terms,
+ as long as they have the right type *)
+ let def,cst = match cb.const_body with
+ | Undef _ | OpaqueDef _ ->
+ let (j,cst1) = Typeops.infer env' c in
+ let typ = Typeops.type_of_constant_type env' cb.const_type in
+ let cst2 = Reduction.conv_leq env' j.uj_type typ in
+ let cst =
+ union_constraints
+ (union_constraints cb.const_constraints cst1)
+ cst2
+ in
+ let def = Def (Declarations.from_val j.uj_val) in
+ def,cst
+ | Def cs ->
+ let cst1 = Reduction.conv env' c (Declarations.force cs) in
+ let cst = union_constraints cb.const_constraints cst1 in
+ let def = Def (Declarations.from_val c) in
+ def,cst
+ in
+ let cb' =
+ { cb with
+ const_body = def;
+ const_body_code =
+ Cemitcodes.from_val (compile_constant_body env' def);
+ const_constraints = cst }
+ in
+ SEBstruct(before@((l,SFBconst(cb'))::after)),cb',cst
| With_Definition (_::_,c) ->
let old = match spec with
- SFBmodule msb -> msb
+ | SFBmodule msb -> msb
| _ -> error_not_a_module (string_of_label l)
in
begin
@@ -129,12 +133,12 @@ and check_with_aux_def env sign with_decl mp equiv =
mod_type_alg = None}) in
SEBstruct(before@((l,new_spec)::after)),cb,cst
| Some msb ->
- error_a_generative_module_expected l
+ error_generative_module_expected l
end
| _ -> anomaly "Modtyping:incorrect use of with"
with
- Not_found -> error_no_such_label l
- | Reduction.NotConvertible -> error_with_incorrect l
+ | Not_found -> error_no_such_label l
+ | Reduction.NotConvertible -> error_incorrect_with_constraint l
and check_with_aux_mod env sign with_decl mp equiv =
let sig_b = match sign with
@@ -163,24 +167,24 @@ and check_with_aux_mod env sign with_decl mp equiv =
in
let mb_mp1 = (lookup_module mp1 env) in
let mtb_mp1 =
- module_type_of_module env' None mb_mp1 in
+ module_type_of_module None mb_mp1 in
let cst =
match old.mod_expr with
None ->
begin
- try Constraint.union
+ try union_constraints
(check_subtypes env' mtb_mp1
- (module_type_of_module env' None old))
+ (module_type_of_module None old))
old.mod_constraints
- with Failure _ -> error_with_incorrect (label_of_id id)
+ with Failure _ -> error_incorrect_with_constraint (label_of_id id)
end
| Some (SEBident(mp')) ->
check_modpath_equiv env' mp1 mp';
old.mod_constraints
- | _ -> error_a_generative_module_expected l
+ | _ -> error_generative_module_expected l
+ in
+ let new_mb = strengthen_and_subst_mb mb_mp1 (MPdot(mp,l)) false
in
- let new_mb = strengthen_and_subst_mb mb_mp1
- (MPdot(mp,l)) env false in
let new_spec = SFBmodule {new_mb with
mod_mp = MPdot(mp,l);
mod_expr = Some (SEBident mp1);
@@ -215,14 +219,14 @@ and check_with_aux_mod env sign with_decl mp equiv =
let mpnew = rebuild_mp mp' (List.map label_of_id idl) in
check_modpath_equiv env' mpnew mp;
SEBstruct(before@(l,spec)::after)
- ,equiv,Constraint.empty
+ ,equiv,empty_constraint
| _ ->
- error_a_generative_module_expected l
+ error_generative_module_expected l
end
| _ -> anomaly "Modtyping:incorrect use of with"
with
Not_found -> error_no_such_label l
- | Reduction.NotConvertible -> error_with_incorrect l
+ | Reduction.NotConvertible -> error_incorrect_with_constraint l
and translate_module env mp inl me =
match me.mod_entry_expr, me.mod_entry_type with
@@ -243,14 +247,14 @@ and translate_module env mp inl me =
let sign,alg1,resolver,cst2 =
match me.mod_entry_type with
| None ->
- sign,None,resolver,Constraint.empty
+ sign,None,resolver,empty_constraint
| Some mte ->
let mtb = translate_module_type env mp inl mte in
let cst = check_subtypes env
{typ_mp = mp;
typ_expr = sign;
typ_expr_alg = None;
- typ_constraints = Constraint.empty;
+ typ_constraints = empty_constraint;
typ_delta = resolver;}
mtb
in
@@ -258,9 +262,9 @@ and translate_module env mp inl me =
in
{ mod_mp = mp;
mod_type = sign;
- mod_expr = Some alg_implem;
+ mod_expr = alg_implem;
mod_type_alg = alg1;
- mod_constraints = Univ.Constraint.union cst1 cst2;
+ mod_constraints = Univ.union_constraints cst1 cst2;
mod_delta = resolver;
mod_retroknowledge = []}
(* spiwack: not so sure about that. It may
@@ -268,125 +272,92 @@ and translate_module env mp inl me =
If it does, I don't really know how to
fix the bug.*)
+and translate_apply env inl ftrans mexpr mkalg =
+ let sign,alg,resolver,cst1 = ftrans in
+ let farg_id, farg_b, fbody_b = destr_functor env sign in
+ let mp1 =
+ try path_of_mexpr mexpr
+ with Not_path -> error_application_to_not_path mexpr
+ in
+ let mtb = module_type_of_module None (lookup_module mp1 env) in
+ let cst2 = check_subtypes env mtb farg_b in
+ let mp_delta = discr_resolver env mtb in
+ let mp_delta = inline_delta_resolver env inl mp1 farg_id farg_b mp_delta in
+ let subst = map_mbid farg_id mp1 mp_delta
+ in
+ subst_struct_expr subst fbody_b,
+ mkalg alg mp1 cst2,
+ subst_codom_delta_resolver subst resolver,
+ Univ.union_constraints cst1 cst2
+
+and translate_functor env inl arg_id arg_e trans mkalg =
+ let mtb = translate_module_type env (MPbound arg_id) inl arg_e in
+ let env' = add_module (module_body_of_type (MPbound arg_id) mtb) env in
+ let sign,alg,resolver,cst = trans env'
+ in
+ SEBfunctor (arg_id, mtb, sign),
+ mkalg alg arg_id mtb,
+ resolver,
+ Univ.union_constraints cst mtb.typ_constraints
-and translate_struct_module_entry env mp inl mse = match mse with
+and translate_struct_module_entry env mp inl = function
| MSEident mp1 ->
- let mb = lookup_module mp1 env in
- let mb' = strengthen_and_subst_mb mb mp env false in
- mb'.mod_type, SEBident mp1, mb'.mod_delta,Univ.Constraint.empty
+ let mb = lookup_module mp1 env in
+ let mb' = strengthen_and_subst_mb mb mp false in
+ mb'.mod_type, Some (SEBident mp1), mb'.mod_delta,Univ.empty_constraint
| MSEfunctor (arg_id, arg_e, body_expr) ->
- let mtb = translate_module_type env (MPbound arg_id) inl arg_e in
- let env' = add_module (module_body_of_type (MPbound arg_id) mtb)
- env in
- let sign,alg,resolver,cst =
- translate_struct_module_entry env' mp inl body_expr in
- SEBfunctor (arg_id, mtb, sign),SEBfunctor (arg_id, mtb, alg),resolver,
- Univ.Constraint.union cst mtb.typ_constraints
+ let trans env' = translate_struct_module_entry env' mp inl body_expr in
+ let mkalg a id m = Option.map (fun a -> SEBfunctor (id,m,a)) a in
+ translate_functor env inl arg_id arg_e trans mkalg
| MSEapply (fexpr,mexpr) ->
- let sign,alg,resolver,cst1 =
- translate_struct_module_entry env mp inl fexpr
- in
- let farg_id, farg_b, fbody_b = destr_functor env sign in
- let mtb,mp1 =
- try
- let mp1 = path_of_mexpr mexpr in
- let mtb = module_type_of_module env None (lookup_module mp1 env) in
- mtb,mp1
- with
- | Not_path -> error_application_to_not_path mexpr
- (* place for nondep_supertype *) in
- let cst = check_subtypes env mtb farg_b in
- let mp_delta = discr_resolver env mtb in
- let mp_delta = if not inl then mp_delta else
- complete_inline_delta_resolver env mp1 farg_id farg_b mp_delta
- in
- let subst = map_mbid farg_id mp1 mp_delta in
- (subst_struct_expr subst fbody_b),SEBapply(alg,SEBident mp1,cst),
- (subst_codom_delta_resolver subst resolver),
- Univ.Constraint.union cst1 cst
+ let trans = translate_struct_module_entry env mp inl fexpr in
+ let mkalg a mp c = Option.map (fun a -> SEBapply(a,SEBident mp,c)) a in
+ translate_apply env inl trans mexpr mkalg
| MSEwith(mte, with_decl) ->
- let sign,alg,resolve,cst1 = translate_struct_module_entry env mp inl mte in
- let sign,alg,resolve,cst2 = check_with env sign with_decl (Some alg) mp resolve in
- sign,Option.get alg,resolve,Univ.Constraint.union cst1 cst2
-
-and translate_struct_type_entry env inl mse = match mse with
+ let sign,alg,resolve,cst1 =
+ translate_struct_module_entry env mp inl mte in
+ let sign,alg,resolve,cst2 =
+ check_with env sign with_decl alg mp resolve in
+ sign,alg,resolve,Univ.union_constraints cst1 cst2
+
+and translate_struct_type_entry env inl = function
| MSEident mp1 ->
- let mtb = lookup_modtype mp1 env in
- mtb.typ_expr,
- Some (SEBident mp1),mtb.typ_delta,mp1,Univ.Constraint.empty
+ let mtb = lookup_modtype mp1 env in
+ mtb.typ_expr,Some (SEBident mp1),mtb.typ_delta,Univ.empty_constraint
| MSEfunctor (arg_id, arg_e, body_expr) ->
- let mtb = translate_module_type env (MPbound arg_id) inl arg_e in
- let env' = add_module (module_body_of_type (MPbound arg_id) mtb) env in
- let sign,alg,resolve,mp_from,cst =
- translate_struct_type_entry env' inl body_expr in
- SEBfunctor (arg_id, mtb, sign),None,resolve,mp_from,
- Univ.Constraint.union cst mtb.typ_constraints
+ let trans env' = translate_struct_type_entry env' inl body_expr in
+ translate_functor env inl arg_id arg_e trans (fun _ _ _ -> None)
| MSEapply (fexpr,mexpr) ->
- let sign,alg,resolve,mp_from,cst1 =
- translate_struct_type_entry env inl fexpr
- in
- let farg_id, farg_b, fbody_b = destr_functor env sign in
- let mtb,mp1 =
- try
- let mp1 = path_of_mexpr mexpr in
- let mtb = module_type_of_module env None (lookup_module mp1 env) in
- mtb,mp1
- with
- | Not_path -> error_application_to_not_path mexpr
- (* place for nondep_supertype *) in
- let cst2 = check_subtypes env mtb farg_b in
- let mp_delta = discr_resolver env mtb in
- let mp_delta = if not inl then mp_delta else
- complete_inline_delta_resolver env mp1 farg_id farg_b mp_delta
- in
- let subst = map_mbid farg_id mp1 mp_delta in
- (subst_struct_expr subst fbody_b),None,
- (subst_codom_delta_resolver subst resolve),mp_from,Univ.Constraint.union cst1 cst2
+ let trans = translate_struct_type_entry env inl fexpr in
+ translate_apply env inl trans mexpr (fun _ _ _ -> None)
| MSEwith(mte, with_decl) ->
- let sign,alg,resolve,mp_from,cst = translate_struct_type_entry env inl mte in
- let sign,alg,resolve,cst1 =
- check_with env sign with_decl alg mp_from resolve in
- sign,alg,resolve,mp_from,Univ.Constraint.union cst cst1
+ let sign,alg,resolve,cst1 = translate_struct_type_entry env inl mte in
+ let sign,alg,resolve,cst2 =
+ check_with env sign with_decl alg (mp_from_mexpr mte) resolve
+ in
+ sign,alg,resolve,Univ.union_constraints cst1 cst2
and translate_module_type env mp inl mte =
- let sign,alg,resolve,mp_from,cst = translate_struct_type_entry env inl mte in
- let mtb = subst_modtype_and_resolver
- {typ_mp = mp_from;
- typ_expr = sign;
- typ_expr_alg = None;
- typ_constraints = cst;
- typ_delta = resolve} mp env
- in {mtb with typ_expr_alg = alg}
+ let mp_from = mp_from_mexpr mte in
+ let sign,alg,resolve,cst = translate_struct_type_entry env inl mte in
+ let mtb = subst_modtype_and_resolver
+ {typ_mp = mp_from;
+ typ_expr = sign;
+ typ_expr_alg = None;
+ typ_constraints = cst;
+ typ_delta = resolve} mp
+ in {mtb with typ_expr_alg = alg}
-let rec translate_struct_include_module_entry env mp inl mse = match mse with
+let rec translate_struct_include_module_entry env mp inl = function
| MSEident mp1 ->
- let mb = lookup_module mp1 env in
- let mb' = strengthen_and_subst_mb mb mp env true in
- let mb_typ = clean_bounded_mod_expr mb'.mod_type in
- mb_typ, mb'.mod_delta,Univ.Constraint.empty
+ let mb = lookup_module mp1 env in
+ let mb' = strengthen_and_subst_mb mb mp true in
+ let mb_typ = clean_bounded_mod_expr mb'.mod_type in
+ mb_typ,None,mb'.mod_delta,Univ.empty_constraint
| MSEapply (fexpr,mexpr) ->
- let sign,resolver,cst1 =
- translate_struct_include_module_entry env mp inl fexpr in
- let farg_id, farg_b, fbody_b = destr_functor env sign in
- let mtb,mp1 =
- try
- let mp1 = path_of_mexpr mexpr in
- let mtb = module_type_of_module env None (lookup_module mp1 env) in
- mtb,mp1
- with
- | Not_path -> error_application_to_not_path mexpr
- (* place for nondep_supertype *) in
- let cst = check_subtypes env mtb farg_b in
- let mp_delta = discr_resolver env mtb in
- let mp_delta = if not inl then mp_delta else
- complete_inline_delta_resolver env mp1 farg_id farg_b mp_delta
- in
- let subst = map_mbid farg_id mp1 mp_delta in
- (subst_struct_expr subst fbody_b),
- (subst_codom_delta_resolver subst resolver),
- Univ.Constraint.union cst1 cst
+ let ftrans = translate_struct_include_module_entry env mp inl fexpr in
+ translate_apply env inl ftrans mexpr (fun _ _ _ -> None)
| _ -> error ("You cannot Include a high-order structure.")
-
let rec add_struct_expr_constraints env = function
| SEBident _ -> env
@@ -448,11 +419,11 @@ let rec struct_expr_constraints cst = function
| SEBapply (meb1,meb2,cst1) ->
struct_expr_constraints
- (struct_expr_constraints (Univ.Constraint.union cst1 cst) meb1)
+ (struct_expr_constraints (Univ.union_constraints cst1 cst) meb1)
meb2
| SEBwith(meb,With_definition_body(_,cb))->
struct_expr_constraints
- (Univ.Constraint.union cb.const_constraints cst) meb
+ (Univ.union_constraints cb.const_constraints cst) meb
| SEBwith(meb,With_module_body(_,_))->
struct_expr_constraints cst meb
@@ -468,11 +439,11 @@ and module_constraints cst mb =
| Some meb -> struct_expr_constraints cst meb in
let cst =
struct_expr_constraints cst mb.mod_type in
- Univ.Constraint.union mb.mod_constraints cst
+ Univ.union_constraints mb.mod_constraints cst
and modtype_constraints cst mtb =
- struct_expr_constraints (Univ.Constraint.union mtb.typ_constraints cst) mtb.typ_expr
+ struct_expr_constraints (Univ.union_constraints mtb.typ_constraints cst) mtb.typ_expr
-let struct_expr_constraints = struct_expr_constraints Univ.Constraint.empty
-let module_constraints = module_constraints Univ.Constraint.empty
+let struct_expr_constraints = struct_expr_constraints Univ.empty_constraint
+let module_constraints = module_constraints Univ.empty_constraint
diff --git a/kernel/mod_typing.mli b/kernel/mod_typing.mli
index ec5eb332..0987ca5b 100644
--- a/kernel/mod_typing.mli
+++ b/kernel/mod_typing.mli
@@ -1,36 +1,44 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: mod_typing.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
open Declarations
open Environ
open Entries
open Mod_subst
open Names
-(*i*)
-
-
-val translate_module : env -> module_path -> bool -> module_entry
- -> module_body
-
-val translate_module_type : env -> module_path -> bool -> module_struct_entry ->
- module_type_body
-
-val translate_struct_module_entry : env -> module_path -> bool -> module_struct_entry ->
- struct_expr_body * struct_expr_body * delta_resolver * Univ.constraints
-val translate_struct_type_entry : env -> bool -> module_struct_entry ->
- struct_expr_body * struct_expr_body option * delta_resolver * module_path * Univ.constraints
-val translate_struct_include_module_entry : env -> module_path
- -> bool -> module_struct_entry -> struct_expr_body * delta_resolver * Univ.constraints
+val translate_module :
+ env -> module_path -> inline -> module_entry -> module_body
+
+val translate_module_type :
+ env -> module_path -> inline -> module_struct_entry -> module_type_body
+
+val translate_struct_module_entry :
+ env -> module_path -> inline -> module_struct_entry ->
+ struct_expr_body (* Signature *)
+ * struct_expr_body option (* Algebraic expr, in fact never None *)
+ * delta_resolver
+ * Univ.constraints
+
+val translate_struct_type_entry :
+ env -> inline -> module_struct_entry ->
+ struct_expr_body
+ * struct_expr_body option
+ * delta_resolver
+ * Univ.constraints
+
+val translate_struct_include_module_entry :
+ env -> module_path -> inline -> module_struct_entry ->
+ struct_expr_body
+ * struct_expr_body option (* Algebraic expr, always None *)
+ * delta_resolver
+ * Univ.constraints
val add_modtype_constraints : env -> module_type_body -> env
diff --git a/kernel/modops.ml b/kernel/modops.ml
index f0d579a4..0c2c6bd7 100644
--- a/kernel/modops.ml
+++ b/kernel/modops.ml
@@ -1,14 +1,20 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: modops.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
+(* Created by Jacek Chrzaszcz, Aug 2002 as part of the implementation of
+ the Coq module system *)
+(* Inlining and more liberal use of modules and module types by Claudio
+ Sacerdoti, Nov 2004 *)
+(* New structure-based model of modules and miscellaneous bug fixes by
+ Élie Soubiran, from Feb 2008 *)
+
+(* This file provides with various operations on modules and module types *)
-(*i*)
open Util
open Pp
open Names
@@ -18,80 +24,103 @@ open Declarations
open Environ
open Entries
open Mod_subst
-(*i*)
-
-
-
-let error_existing_label l =
- error ("The label "^string_of_label l^" is already declared.")
-
-let error_declaration_not_path _ = error "Declaration is not a path."
-
-let error_application_to_not_path _ = error "Application to not path."
-
-let error_not_a_functor _ = error "Application of not a functor."
-
-let error_incompatible_modtypes _ _ = error "Incompatible module types."
-
-let error_not_equal _ _ = error "Non equal modules."
-let error_not_match l _ = error ("Signature components for label "^string_of_label l^" do not match.")
-
-let error_no_such_label l = error ("No such label "^string_of_label l^".")
-
-let error_incompatible_labels l l' =
- error ("Opening and closing labels are not the same: "
- ^string_of_label l^" <> "^string_of_label l'^" !")
-
-let error_result_must_be_signature () =
- error "The result module type must be a signature."
+type signature_mismatch_error =
+ | InductiveFieldExpected of mutual_inductive_body
+ | DefinitionFieldExpected
+ | ModuleFieldExpected
+ | ModuleTypeFieldExpected
+ | NotConvertibleInductiveField of identifier
+ | NotConvertibleConstructorField of identifier
+ | NotConvertibleBodyField
+ | NotConvertibleTypeField
+ | NotSameConstructorNamesField
+ | NotSameInductiveNameInBlockField
+ | FiniteInductiveFieldExpected of bool
+ | InductiveNumbersFieldExpected of int
+ | InductiveParamsNumberField of int
+ | RecordFieldExpected of bool
+ | RecordProjectionsExpected of name list
+ | NotEqualInductiveAliases
+ | NoTypeConstraintExpected
+
+type module_typing_error =
+ | SignatureMismatch of label * structure_field_body * signature_mismatch_error
+ | LabelAlreadyDeclared of label
+ | ApplicationToNotPath of module_struct_entry
+ | NotAFunctor of struct_expr_body
+ | IncompatibleModuleTypes of module_type_body * module_type_body
+ | NotEqualModulePaths of module_path * module_path
+ | NoSuchLabel of label
+ | IncompatibleLabels of label * label
+ | SignatureExpected of struct_expr_body
+ | NoModuleToEnd
+ | NoModuleTypeToEnd
+ | NotAModule of string
+ | NotAModuleType of string
+ | NotAConstant of label
+ | IncorrectWithConstraint of label
+ | GenerativeModuleExpected of label
+ | NonEmptyLocalContect of label option
+ | LabelMissing of label * string
+
+exception ModuleTypingError of module_typing_error
+
+let error_existing_label l =
+ raise (ModuleTypingError (LabelAlreadyDeclared l))
+
+let error_application_to_not_path mexpr =
+ raise (ModuleTypingError (ApplicationToNotPath mexpr))
+
+let error_not_a_functor mtb =
+ raise (ModuleTypingError (NotAFunctor mtb))
+
+let error_incompatible_modtypes mexpr1 mexpr2 =
+ raise (ModuleTypingError (IncompatibleModuleTypes (mexpr1,mexpr2)))
+
+let error_not_equal_modpaths mp1 mp2 =
+ raise (ModuleTypingError (NotEqualModulePaths (mp1,mp2)))
+
+let error_signature_mismatch l spec why =
+ raise (ModuleTypingError (SignatureMismatch (l,spec,why)))
+
+let error_no_such_label l =
+ raise (ModuleTypingError (NoSuchLabel l))
+
+let error_incompatible_labels l l' =
+ raise (ModuleTypingError (IncompatibleLabels (l,l')))
let error_signature_expected mtb =
- error "Signature expected."
+ raise (ModuleTypingError (SignatureExpected mtb))
-let error_no_module_to_end _ =
- error "No open module to end."
+let error_no_module_to_end _ =
+ raise (ModuleTypingError NoModuleToEnd)
let error_no_modtype_to_end _ =
- error "No open module type to end."
-
-let error_not_a_modtype_loc loc s =
- user_err_loc (loc,"",str ("\""^s^"\" is not a module type."))
-
-let error_not_a_module_loc loc s =
- user_err_loc (loc,"",str ("\""^s^"\" is not a module."))
+ raise (ModuleTypingError NoModuleTypeToEnd)
-let error_not_a_module_or_modtype_loc loc s =
- user_err_loc (loc,"",str ("\""^s^"\" is not a module or module type."))
+let error_not_a_modtype s =
+ raise (ModuleTypingError (NotAModuleType s))
-let error_not_a_module s = error_not_a_module_loc dummy_loc s
+let error_not_a_module s =
+ raise (ModuleTypingError (NotAModule s))
-let error_not_a_constant l =
- error ("\""^(string_of_label l)^"\" is not a constant.")
+let error_not_a_constant l =
+ raise (ModuleTypingError (NotAConstant l))
-let error_with_incorrect l =
- error ("Incorrect constraint for label \""^(string_of_label l)^"\".")
+let error_incorrect_with_constraint l =
+ raise (ModuleTypingError (IncorrectWithConstraint l))
-let error_a_generative_module_expected l =
- error ("The module " ^ string_of_label l ^ " is not generative. Only " ^
- "component of generative modules can be changed using the \"with\" " ^
- "construct.")
-
-let error_local_context lo =
- match lo with
- None ->
- error ("The local context is not empty.")
- | (Some l) ->
- error ("The local context of the component "^
- (string_of_label l)^" is not empty.")
+let error_generative_module_expected l =
+ raise (ModuleTypingError (GenerativeModuleExpected l))
+let error_non_empty_local_context lo =
+ raise (ModuleTypingError (NonEmptyLocalContect lo))
let error_no_such_label_sub l l1 =
- error ("The field "^(string_of_label l)^" is missing in "^l1^".")
-
-let error_with_in_module _ = error "The syntax \"with\" is not allowed for modules."
+ raise (ModuleTypingError (LabelMissing (l,l1)))
-let error_application_to_module_type _ = error "Module application to a module type."
+(************************)
let destr_functor env mtb =
match mtb with
@@ -116,9 +145,9 @@ let check_modpath_equiv env mp1 mp2 =
if mp1=mp2 then () else
let mb1=lookup_module mp1 env in
let mb2=lookup_module mp2 env in
- if (delta_of_mp mb1.mod_delta mp1)=(delta_of_mp mb2.mod_delta mp2)
+ if (mp_of_delta mb1.mod_delta mp1)=(mp_of_delta mb2.mod_delta mp2)
then ()
- else error_not_equal mp1 mp2
+ else error_not_equal_modpaths mp1 mp2
let rec subst_with_body sub = function
| With_module_body(id,mp) ->
@@ -235,18 +264,13 @@ let add_retroknowledge mp =
let rec add_signature mp sign resolver env =
let add_one env (l,elem) =
let kn = make_kn mp empty_dirpath l in
- let con = constant_of_kn kn in
- let mind = mind_of_kn kn in
- match elem with
- | SFBconst cb ->
- let con = constant_of_delta resolver con in
- Environ.add_constant con cb env
- | SFBmind mib ->
- let mind = mind_of_delta resolver mind in
- Environ.add_mind mind mib env
- | SFBmodule mb -> add_module mb env
- (* adds components as well *)
- | SFBmodtype mtb -> Environ.add_modtype mtb.typ_mp mtb env
+ match elem with
+ | SFBconst cb ->
+ Environ.add_constant (constant_of_delta_kn resolver kn) cb env
+ | SFBmind mib ->
+ Environ.add_mind (mind_of_delta_kn resolver kn) mib env
+ | SFBmodule mb -> add_module mb env (* adds components as well *)
+ | SFBmodtype mtb -> Environ.add_modtype mtb.typ_mp mtb env
in
List.fold_left add_one env sign
@@ -260,100 +284,83 @@ and add_module mb env =
| SEBfunctor _ -> env
| _ -> anomaly "Modops:the evaluation of the structure failed "
-let strengthen_const env mp_from l cb resolver =
- match cb.const_opaque, cb.const_body with
- | false, Some _ -> cb
- | true, Some _
- | _, None ->
- let con = make_con mp_from empty_dirpath l in
- let con = constant_of_delta resolver con in
- let const = mkConst con in
- let const_subs = Some (Declarations.from_val const) in
- {cb with
- const_body = const_subs;
- const_opaque = false;
- const_body_code = Cemitcodes.from_val
- (compile_constant_body env const_subs false false)
- }
-
-
-let rec strengthen_mod env mp_from mp_to mb =
+let strengthen_const mp_from l cb resolver =
+ match cb.const_body with
+ | Def _ -> cb
+ | _ ->
+ let kn = make_kn mp_from empty_dirpath l in
+ let con = constant_of_delta_kn resolver kn in
+ { cb with
+ const_body = Def (Declarations.from_val (mkConst con));
+ const_body_code = Cemitcodes.from_val (Cbytegen.compile_alias con)
+ }
+
+let rec strengthen_mod mp_from mp_to mb =
if mp_in_delta mb.mod_mp mb.mod_delta then
- mb
+ mb
else
match mb.mod_type with
- | SEBstruct (sign) ->
- let resolve_out,sign_out =
- strengthen_sig env mp_from sign mp_to mb.mod_delta in
+ | SEBstruct (sign) ->
+ let resolve_out,sign_out =
+ strengthen_sig mp_from sign mp_to mb.mod_delta in
{ mb with
mod_expr = Some (SEBident mp_to);
mod_type = SEBstruct(sign_out);
mod_type_alg = mb.mod_type_alg;
mod_constraints = mb.mod_constraints;
- mod_delta = add_mp_delta_resolver mp_from mp_to
+ mod_delta = add_mp_delta_resolver mp_from mp_to
(add_delta_resolver mb.mod_delta resolve_out);
mod_retroknowledge = mb.mod_retroknowledge}
| SEBfunctor _ -> mb
| _ -> anomaly "Modops:the evaluation of the structure failed "
-
-and strengthen_sig env mp_from sign mp_to resolver =
+
+and strengthen_sig mp_from sign mp_to resolver =
match sign with
| [] -> empty_delta_resolver,[]
| (l,SFBconst cb) :: rest ->
- let item' =
- l,SFBconst (strengthen_const env mp_from l cb resolver) in
- let resolve_out,rest' =
- strengthen_sig env mp_from rest mp_to resolver in
- resolve_out,item'::rest'
+ let item' = l,SFBconst (strengthen_const mp_from l cb resolver) in
+ let resolve_out,rest' = strengthen_sig mp_from rest mp_to resolver in
+ resolve_out,item'::rest'
| (_,SFBmind _ as item):: rest ->
- let resolve_out,rest' =
- strengthen_sig env mp_from rest mp_to resolver in
- resolve_out,item::rest'
+ let resolve_out,rest' = strengthen_sig mp_from rest mp_to resolver in
+ resolve_out,item::rest'
| (l,SFBmodule mb) :: rest ->
let mp_from' = MPdot (mp_from,l) in
- let mp_to' = MPdot(mp_to,l) in
- let mb_out =
- strengthen_mod env mp_from' mp_to' mb in
+ let mp_to' = MPdot(mp_to,l) in
+ let mb_out = strengthen_mod mp_from' mp_to' mb in
let item' = l,SFBmodule (mb_out) in
- let env' = add_module mb_out env in
- let resolve_out,rest' =
- strengthen_sig env' mp_from rest mp_to resolver in
- add_delta_resolver resolve_out mb.mod_delta,
- item':: rest'
- | (l,SFBmodtype mty as item) :: rest ->
- let env' = add_modtype
- (MPdot(mp_from,l)) mty env
- in
- let resolve_out,rest' =
- strengthen_sig env' mp_from rest mp_to resolver in
- resolve_out,item::rest'
-
-let strengthen env mtb mp =
+ let resolve_out,rest' = strengthen_sig mp_from rest mp_to resolver in
+ add_delta_resolver resolve_out mb.mod_delta, item':: rest'
+ | (l,SFBmodtype mty as item) :: rest ->
+ let resolve_out,rest' = strengthen_sig mp_from rest mp_to resolver in
+ resolve_out,item::rest'
+
+let strengthen mtb mp =
if mp_in_delta mtb.typ_mp mtb.typ_delta then
(* in this case mtb has already been strengthened*)
- mtb
+ mtb
else
match mtb.typ_expr with
- | SEBstruct (sign) ->
+ | SEBstruct (sign) ->
let resolve_out,sign_out =
- strengthen_sig env mtb.typ_mp sign mp mtb.typ_delta in
+ strengthen_sig mtb.typ_mp sign mp mtb.typ_delta in
{mtb with
typ_expr = SEBstruct(sign_out);
typ_delta = add_delta_resolver mtb.typ_delta
(add_mp_delta_resolver mtb.typ_mp mp resolve_out)}
| SEBfunctor _ -> mtb
| _ -> anomaly "Modops:the evaluation of the structure failed "
-
-let module_type_of_module env mp mb =
+
+let module_type_of_module mp mb =
match mp with
Some mp ->
- strengthen env {
+ strengthen {
typ_mp = mp;
typ_expr = mb.mod_type;
typ_expr_alg = None;
typ_constraints = mb.mod_constraints;
typ_delta = mb.mod_delta} mp
-
+
| None ->
{typ_mp = mb.mod_mp;
typ_expr = mb.mod_type;
@@ -361,34 +368,29 @@ let module_type_of_module env mp mb =
typ_constraints = mb.mod_constraints;
typ_delta = mb.mod_delta}
-let complete_inline_delta_resolver env mp mbid mtb delta =
- let constants = inline_of_delta mtb.typ_delta in
+let inline_delta_resolver env inl mp mbid mtb delta =
+ let constants = inline_of_delta inl mtb.typ_delta in
let rec make_inline delta = function
| [] -> delta
- | kn::r ->
+ | (lev,kn)::r ->
let kn = replace_mp_in_kn (MPbound mbid) mp kn in
- let con = constant_of_kn kn in
- let con' = constant_of_delta delta con in
- try
- let constant = lookup_constant con' env in
- if (not constant.Declarations.const_opaque) then
- let constr = Option.map Declarations.force
- constant.Declarations.const_body in
- if constr = None then
- (make_inline delta r)
- else
- add_inline_constr_delta_resolver con (Option.get constr)
- (make_inline delta r)
- else
- (make_inline delta r)
- with
- Not_found -> error_no_such_label_sub (con_label con)
- (string_of_mp (con_modpath con))
+ let con = constant_of_delta_kn delta kn in
+ try
+ let constant = lookup_constant con env in
+ let l = make_inline delta r in
+ match constant.const_body with
+ | Undef _ | OpaqueDef _ -> l
+ | Def body ->
+ let constr = Declarations.force body in
+ add_inline_delta_resolver kn (lev, Some constr) l
+ with Not_found ->
+ error_no_such_label_sub (con_label con)
+ (string_of_mp (con_modpath con))
in
- make_inline delta constants
+ make_inline delta constants
let rec strengthen_and_subst_mod
- mb subst env mp_from mp_to env resolver =
+ mb subst mp_from mp_to resolver =
match mb.mod_type with
SEBstruct(str) ->
let mb_is_an_alias = mp_in_delta mb.mod_mp mb.mod_delta in
@@ -397,7 +399,7 @@ let rec strengthen_and_subst_mod
(fun resolver subst-> subst_dom_delta_resolver subst resolver) mb
else
let resolver,new_sig =
- strengthen_and_subst_struct str subst env
+ strengthen_and_subst_struct str subst
mp_from mp_from mp_to false false mb.mod_delta
in
{mb with
@@ -413,42 +415,48 @@ let rec strengthen_and_subst_mod
| _ -> anomaly "Modops:the evaluation of the structure failed "
and strengthen_and_subst_struct
- str subst env mp_alias mp_from mp_to alias incl resolver =
+ str subst mp_alias mp_from mp_to alias incl resolver =
match str with
| [] -> empty_delta_resolver,[]
| (l,SFBconst cb) :: rest ->
- let item' = if alias then
+ let item' = if alias then
+ (* case alias no strengthening needed*)
l,SFBconst (subst_const_body subst cb)
else
- l,SFBconst (strengthen_const env mp_from l
+ l,SFBconst (strengthen_const mp_from l
(subst_const_body subst cb) resolver)
in
- let con = make_con mp_from empty_dirpath l in
let resolve_out,rest' =
- strengthen_and_subst_struct rest subst env
+ strengthen_and_subst_struct rest subst
mp_alias mp_from mp_to alias incl resolver in
- if incl then
- let old_name = constant_of_delta resolver con in
- (add_constant_delta_resolver
- (constant_of_kn_equiv (make_kn mp_to empty_dirpath l)
- (canonical_con old_name))
- resolve_out),
- item'::rest'
- else
- resolve_out,item'::rest'
+ if incl then
+ (* If we are performing an inclusion we need to add
+ the fact that the constant mp_to.l is \Delta-equivalent
+ to resolver(mp_from.l) *)
+ let kn_from = make_kn mp_from empty_dirpath l in
+ let kn_to = make_kn mp_to empty_dirpath l in
+ let old_name = kn_of_delta resolver kn_from in
+ (add_kn_delta_resolver kn_to old_name resolve_out),
+ item'::rest'
+ else
+ (*In this case the fact that the constant mp_to.l is
+ \Delta-equivalent to resolver(mp_from.l) is already known
+ because resolve_out contains mp_to maps to resolver(mp_from)*)
+ resolve_out,item'::rest'
| (l,SFBmind mib) :: rest ->
+ (*Same as constant*)
let item' = l,SFBmind (subst_mind subst mib) in
- let mind = make_mind mp_from empty_dirpath l in
let resolve_out,rest' =
- strengthen_and_subst_struct rest subst env
+ strengthen_and_subst_struct rest subst
mp_alias mp_from mp_to alias incl resolver in
- if incl then
- let old_name = mind_of_delta resolver mind in
- (add_mind_delta_resolver
- (mind_of_kn_equiv (make_kn mp_to empty_dirpath l) (canonical_mind old_name)) resolve_out),
- item'::rest'
- else
- resolve_out,item'::rest'
+ if incl then
+ let kn_from = make_kn mp_from empty_dirpath l in
+ let kn_to = make_kn mp_to empty_dirpath l in
+ let old_name = kn_of_delta resolver kn_from in
+ (add_kn_delta_resolver kn_to old_name resolve_out),
+ item'::rest'
+ else
+ resolve_out,item'::rest'
| (l,SFBmodule mb) :: rest ->
let mp_from' = MPdot (mp_from,l) in
let mp_to' = MPdot(mp_to,l) in
@@ -457,15 +465,20 @@ and strengthen_and_subst_struct
(fun resolver subst -> subst_dom_delta_resolver subst resolver) mb
else
strengthen_and_subst_mod
- mb subst env mp_from' mp_to' env resolver
+ mb subst mp_from' mp_to' resolver
in
let item' = l,SFBmodule (mb_out) in
- let env' = add_module mb_out env in
- let resolve_out,rest' =
- strengthen_and_subst_struct rest subst env'
+ let resolve_out,rest' =
+ strengthen_and_subst_struct rest subst
mp_alias mp_from mp_to alias incl resolver in
- if is_functor mb_out.mod_type then (add_mp_delta_resolver
- mp_to' mp_to' resolve_out),item':: rest' else
+ (* if mb is a functor we should not derive new equivalences
+ on names, hence we add the fact that the functor can only
+ be equivalent to itself. If we adopt an applicative
+ semantic for functor this should be changed.*)
+ if is_functor mb_out.mod_type then
+ (add_mp_delta_resolver
+ mp_to' mp_to' resolve_out),item':: rest'
+ else
add_delta_resolver resolve_out mb_out.mod_delta,
item':: rest'
| (l,SFBmodtype mty) :: rest ->
@@ -474,27 +487,30 @@ and strengthen_and_subst_struct
let subst' = add_mp mp_from' mp_to' empty_delta_resolver subst in
let mty = subst_modtype subst'
(fun resolver subst -> subst_dom_codom_delta_resolver subst' resolver) mty in
- let env' = add_modtype mp_from' mty env in
- let resolve_out,rest' = strengthen_and_subst_struct rest subst env'
+ let resolve_out,rest' = strengthen_and_subst_struct rest subst
mp_alias mp_from mp_to alias incl resolver in
(add_mp_delta_resolver
mp_to' mp_to' resolve_out),(l,SFBmodtype mty)::rest'
-let strengthen_and_subst_mb mb mp env include_b =
+
+(* Let P be a module path when we write "Module M:=P." or "Module M. Include P. End M."
+ we need to perform two operations to compute the body of M. The first one is applying
+ the substitution {P <- M} on the type of P and the second one is strenghtening. *)
+let strengthen_and_subst_mb mb mp include_b =
match mb.mod_type with
SEBstruct str ->
let mb_is_an_alias = mp_in_delta mb.mod_mp mb.mod_delta in
- (*if mb is an alias then the strengthening is useless
+ (*if mb.mod_mp is an alias then the strengthening is useless
(i.e. it is already done)*)
- let mp_alias = delta_of_mp mb.mod_delta mb.mod_mp in
+ let mp_alias = mp_of_delta mb.mod_delta mb.mod_mp in
let subst_resolver = map_mp mb.mod_mp mp empty_delta_resolver in
let new_resolver =
add_mp_delta_resolver mp mp_alias
- (subst_dom_delta_resolver subst_resolver mb.mod_delta) in
+ (subst_dom_delta_resolver subst_resolver mb.mod_delta) in
let subst = map_mp mb.mod_mp mp new_resolver in
let resolver_out,new_sig =
- strengthen_and_subst_struct str subst env
- mp_alias mb.mod_mp mp mb_is_an_alias include_b mb.mod_delta
+ strengthen_and_subst_struct str subst
+ mp_alias mb.mod_mp mp mb_is_an_alias include_b mb.mod_delta
in
{mb with
mod_mp = mp;
@@ -509,7 +525,7 @@ let strengthen_and_subst_mb mb mp env include_b =
| _ -> anomaly "Modops:the evaluation of the structure failed "
-let subst_modtype_and_resolver mtb mp env =
+let subst_modtype_and_resolver mtb mp =
let subst = (map_mp mtb.typ_mp mp empty_delta_resolver) in
let new_delta = subst_dom_codom_delta_resolver subst mtb.typ_delta in
let full_subst = (map_mp mtb.typ_mp mp new_delta) in
diff --git a/kernel/modops.mli b/kernel/modops.mli
index 37f4e8e0..b9c36d5a 100644
--- a/kernel/modops.mli
+++ b/kernel/modops.mli
@@ -1,14 +1,11 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: modops.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
open Util
open Names
open Univ
@@ -16,14 +13,13 @@ open Environ
open Declarations
open Entries
open Mod_subst
-(*i*)
-(* Various operations on modules and module types *)
+(** Various operations on modules and module types *)
val module_body_of_type : module_path -> module_type_body -> module_body
-val module_type_of_module : env -> module_path option -> module_body ->
+val module_type_of_module : module_path option -> module_body ->
module_type_body
val destr_functor :
@@ -36,71 +32,95 @@ val subst_signature : substitution -> structure_body -> structure_body
val add_signature :
module_path -> structure_body -> delta_resolver -> env -> env
-(* adds a module and its components, but not the constraints *)
+(** adds a module and its components, but not the constraints *)
val add_module : module_body -> env -> env
val check_modpath_equiv : env -> module_path -> module_path -> unit
-val strengthen : env -> module_type_body -> module_path -> module_type_body
+val strengthen : module_type_body -> module_path -> module_type_body
-val complete_inline_delta_resolver :
- env -> module_path -> mod_bound_id -> module_type_body ->
+val inline_delta_resolver :
+ env -> inline -> module_path -> mod_bound_id -> module_type_body ->
delta_resolver -> delta_resolver
-val strengthen_and_subst_mb : module_body -> module_path -> env -> bool
- -> module_body
+val strengthen_and_subst_mb : module_body -> module_path -> bool -> module_body
-val subst_modtype_and_resolver : module_type_body -> module_path -> env ->
+val subst_modtype_and_resolver : module_type_body -> module_path ->
module_type_body
val clean_bounded_mod_expr : struct_expr_body -> struct_expr_body
-val error_existing_label : label -> 'a
+(** Errors *)
+
+type signature_mismatch_error =
+ | InductiveFieldExpected of mutual_inductive_body
+ | DefinitionFieldExpected
+ | ModuleFieldExpected
+ | ModuleTypeFieldExpected
+ | NotConvertibleInductiveField of identifier
+ | NotConvertibleConstructorField of identifier
+ | NotConvertibleBodyField
+ | NotConvertibleTypeField
+ | NotSameConstructorNamesField
+ | NotSameInductiveNameInBlockField
+ | FiniteInductiveFieldExpected of bool
+ | InductiveNumbersFieldExpected of int
+ | InductiveParamsNumberField of int
+ | RecordFieldExpected of bool
+ | RecordProjectionsExpected of name list
+ | NotEqualInductiveAliases
+ | NoTypeConstraintExpected
+
+type module_typing_error =
+ | SignatureMismatch of label * structure_field_body * signature_mismatch_error
+ | LabelAlreadyDeclared of label
+ | ApplicationToNotPath of module_struct_entry
+ | NotAFunctor of struct_expr_body
+ | IncompatibleModuleTypes of module_type_body * module_type_body
+ | NotEqualModulePaths of module_path * module_path
+ | NoSuchLabel of label
+ | IncompatibleLabels of label * label
+ | SignatureExpected of struct_expr_body
+ | NoModuleToEnd
+ | NoModuleTypeToEnd
+ | NotAModule of string
+ | NotAModuleType of string
+ | NotAConstant of label
+ | IncorrectWithConstraint of label
+ | GenerativeModuleExpected of label
+ | NonEmptyLocalContect of label option
+ | LabelMissing of label * string
+
+exception ModuleTypingError of module_typing_error
-val error_declaration_not_path : module_struct_entry -> 'a
+val error_existing_label : label -> 'a
val error_application_to_not_path : module_struct_entry -> 'a
-val error_not_a_functor : module_struct_entry -> 'a
-
val error_incompatible_modtypes :
module_type_body -> module_type_body -> 'a
-val error_not_equal : module_path -> module_path -> 'a
-
-val error_not_match : label -> structure_field_body -> 'a
+val error_signature_mismatch :
+ label -> structure_field_body -> signature_mismatch_error -> 'a
val error_incompatible_labels : label -> label -> 'a
val error_no_such_label : label -> 'a
-val error_result_must_be_signature : unit -> 'a
-
val error_signature_expected : struct_expr_body -> 'a
val error_no_module_to_end : unit -> 'a
val error_no_modtype_to_end : unit -> 'a
-val error_not_a_modtype_loc : loc -> string -> 'a
-
-val error_not_a_module_loc : loc -> string -> 'a
-
-val error_not_a_module_or_modtype_loc : loc -> string -> 'a
-
val error_not_a_module : string -> 'a
val error_not_a_constant : label -> 'a
-val error_with_incorrect : label -> 'a
+val error_incorrect_with_constraint : label -> 'a
-val error_a_generative_module_expected : label -> 'a
+val error_generative_module_expected : label -> 'a
-val error_local_context : label option -> 'a
+val error_non_empty_local_context : label option -> 'a
val error_no_such_label_sub : label->string->'a
-
-val error_with_in_module : unit -> 'a
-
-val error_application_to_module_type : unit -> 'a
-
diff --git a/kernel/names.ml b/kernel/names.ml
index 642f5562..ae8ad093 100644
--- a/kernel/names.ml
+++ b/kernel/names.ml
@@ -1,35 +1,34 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: names.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
+(* File created around Apr 1994 for CiC V5.10.5 by Chet Murthy collecting
+ parts of file initial.ml from CoC V4.8, Dec 1988, by Gérard Huet,
+ Thierry Coquand and Christine Paulin *)
+(* Hash-consing by Bruno Barras in Feb 1998 *)
+(* Extra functions for splitting/generation of identifiers by Hugo Herbelin *)
+(* Restructuration by Jacek Chrzaszcz as part of the implementation of
+ the module system, Aug 2002 *)
+(* Abstraction over the type of constant for module inlining by Claudio
+ Sacerdoti, Nov 2004 *)
+(* Miscellaneous features or improvements by Hugo Herbelin,
+ Élie Soubiran, ... *)
open Pp
open Util
-(*s Identifiers *)
+(** {6 Identifiers } *)
type identifier = string
-let id_ord = Pervasives.compare
-
let id_of_string s = check_ident_soft s; String.copy s
-
let string_of_id id = String.copy id
-(* Hash-consing of identifier *)
-module Hident = Hashcons.Make(
- struct
- type t = string
- type u = string -> string
- let hash_sub hstr id = hstr id
- let equal id1 id2 = id1 == id2
- let hash = Hashtbl.hash
- end)
+let id_ord = Pervasives.compare
module IdOrdered =
struct
@@ -38,15 +37,27 @@ module IdOrdered =
end
module Idset = Set.Make(IdOrdered)
-module Idmap = Map.Make(IdOrdered)
+module Idmap =
+struct
+ include Map.Make(IdOrdered)
+ exception Finded
+ let exists f m =
+ try iter (fun a b -> if f a b then raise Finded) m ; false
+ with |Finded -> true
+ let singleton k v = add k v empty
+end
module Idpred = Predicate.Make(IdOrdered)
-(* Names *)
+(** {6 Various types based on identifiers } *)
type name = Name of identifier | Anonymous
+type variable = identifier
-(* Dirpaths are lists of module identifiers. The actual representation
- is reversed to optimise sharing: Coq.A.B is ["B";"A";"Coq"] *)
+(** {6 Directory paths = section names paths } *)
+
+(** Dirpaths are lists of module identifiers.
+ The actual representation is reversed to optimise sharing:
+ Coq.A.B is ["B";"A";"Coq"] *)
type module_ident = identifier
type dir_path = module_ident list
@@ -58,14 +69,17 @@ let repr_dirpath x = x
let empty_dirpath = []
+(** Printing of directory paths as ["coq_root.module.submodule"] *)
+
let string_of_dirpath = function
| [] -> "<>"
| sl -> String.concat "." (List.map string_of_id (List.rev sl))
+(** {6 Unique names for bound modules } *)
let u_number = ref 0
-type uniq_ident = int * string * dir_path
-let make_uid dir s = incr u_number;(!u_number,String.copy s,dir)
+type uniq_ident = int * identifier * dir_path
+let make_uid dir s = incr u_number;(!u_number,s,dir)
let debug_string_of_uid (i,s,p) =
"<"(*^string_of_dirpath p ^"#"^*) ^ s ^"#"^ string_of_int i^">"
let string_of_uid (i,s,p) =
@@ -76,30 +90,31 @@ module Umap = Map.Make(struct
let compare = Pervasives.compare
end)
-type label = string
-
type mod_bound_id = uniq_ident
let make_mbid = make_uid
let repr_mbid (n, id, dp) = (n, id, dp)
let debug_string_of_mbid = debug_string_of_uid
let string_of_mbid = string_of_uid
let id_of_mbid (_,s,_) = s
-let label_of_mbid (_,s,_) = s
+(** {6 Names of structure elements } *)
-let mk_label l = l
-let string_of_label = string_of_id
+type label = identifier
+let mk_label = id_of_string
+let string_of_label = string_of_id
+let pr_label l = str (string_of_label l)
let id_of_label l = l
let label_of_id id = id
module Labset = Idset
module Labmap = Idmap
+(** {6 The module part of the kernel name } *)
+
type module_path =
| MPfile of dir_path
| MPbound of mod_bound_id
- (* | MPapp of module_path * module_path *)
| MPdot of module_path * label
let rec check_bound_mp = function
@@ -110,12 +125,9 @@ let rec check_bound_mp = function
let rec string_of_mp = function
| MPfile sl -> string_of_dirpath sl
| MPbound uid -> string_of_uid uid
- (* | MPapp (mp1,mp2) ->
- "("^string_of_mp mp ^ " " ^
- string_of_mp mp^")"*)
| MPdot (mp,l) -> string_of_mp mp ^ "." ^ string_of_label l
-(* we compare labels first if both are MPdots *)
+(** we compare labels first if both are MPdots *)
let rec mp_ord mp1 mp2 = match (mp1,mp2) with
MPdot(mp1,l1), MPdot(mp2,l2) ->
let c = Pervasives.compare l1 l2 in
@@ -133,7 +145,12 @@ end
module MPset = Set.Make(MPord)
module MPmap = Map.Make(MPord)
-(* Kernel names *)
+let default_module_name = "If you see this, it's a bug"
+
+let initial_dir = make_dirpath [default_module_name]
+let initial_path = MPfile initial_dir
+
+(** {6 Kernel names } *)
type kernel_name = module_path * dir_path * label
@@ -147,11 +164,12 @@ let label kn =
let _,_,l = repr_kn kn in l
let string_of_kn (mp,dir,l) =
- string_of_mp mp ^ "#" ^ string_of_dirpath dir ^ "#" ^ string_of_label l
+ let str_dir = if dir = [] then "." else "#" ^ string_of_dirpath dir ^ "#"
+ in
+ string_of_mp mp ^ str_dir ^ string_of_label l
let pr_kn kn = str (string_of_kn kn)
-
let kn_ord kn1 kn2 =
let mp1,dir1,l1 = kn1 in
let mp2,dir2,l2 = kn2 in
@@ -165,87 +183,84 @@ let kn_ord kn1 kn2 =
else
MPord.compare mp1 mp2
-(* a constant name is a kernel name couple (kn1,kn2)
+module KNord = struct
+ type t = kernel_name
+ let compare = kn_ord
+end
+
+module KNmap = Map.Make(KNord)
+module KNpred = Predicate.Make(KNord)
+module KNset = Set.Make(KNord)
+
+(** {6 Constant names } *)
+
+(** a constant name is a kernel name couple (kn1,kn2)
where kn1 corresponds to the name used at toplevel
- (i.e. what the user see)
- and kn2 corresponds to the canonical kernel name
- i.e. in the environment we have
+ (i.e. what the user see)
+ and kn2 corresponds to the canonical kernel name
+ i.e. in the environment we have
kn1 \rhd_{\delta}^* kn2 \rhd_{\delta} t *)
type constant = kernel_name*kernel_name
-(* For the environment we distinguish constants by their
- user part*)
+let constant_of_kn kn = (kn,kn)
+let constant_of_kn_equiv kn1 kn2 = (kn1,kn2)
+let make_con mp dir l = constant_of_kn (mp,dir,l)
+let make_con_equiv mp1 mp2 dir l = ((mp1,dir,l),(mp2,dir,l))
+let canonical_con con = snd con
+let user_con con = fst con
+let repr_con con = fst con
+
+let eq_constant (_,kn1) (_,kn2) = kn1=kn2
+
+let con_label con = label (fst con)
+let con_modpath con = modpath (fst con)
+
+let string_of_con con = string_of_kn (fst con)
+let pr_con con = str (string_of_con con)
+let debug_string_of_con con =
+ "(" ^ string_of_kn (fst con) ^ "," ^ string_of_kn (snd con) ^ ")"
+let debug_pr_con con = str (debug_string_of_con con)
+
+let con_with_label ((mp1,dp1,l1),(mp2,dp2,l2) as con) lbl =
+ if lbl = l1 && lbl = l2 then con
+ else ((mp1,dp1,lbl),(mp2,dp2,lbl))
+
+(** For the environment we distinguish constants by their user part*)
module User_ord = struct
type t = kernel_name*kernel_name
let compare x y= kn_ord (fst x) (fst y)
end
-(* For other uses (ex: non-logical things) it is enough
- to deal with the canonical part *)
+(** For other uses (ex: non-logical things) it is enough
+ to deal with the canonical part *)
module Canonical_ord = struct
type t = kernel_name*kernel_name
let compare x y= kn_ord (snd x) (snd y)
end
-
-module KNord = struct
- type t = kernel_name
- let compare =kn_ord
-end
-
-module KNmap = Map.Make(KNord)
-module KNpred = Predicate.Make(KNord)
-module KNset = Set.Make(KNord)
-
module Cmap = Map.Make(Canonical_ord)
module Cmap_env = Map.Make(User_ord)
module Cpred = Predicate.Make(Canonical_ord)
module Cset = Set.Make(Canonical_ord)
module Cset_env = Set.Make(User_ord)
-module Mindmap = Map.Make(Canonical_ord)
-module Mindset = Set.Make(Canonical_ord)
-module Mindmap_env = Map.Make(User_ord)
-
-let default_module_name = "If you see this, it's a bug"
-let initial_dir = make_dirpath [default_module_name]
-let initial_path = MPfile initial_dir
+(** {6 Names of mutual inductive types } *)
-type variable = identifier
+(** The same thing is done for mutual inductive names
+ it replaces also the old mind_equiv field of mutual
+ inductive types *)
+(** Beware: first inductive has index 0 *)
+(** Beware: first constructor has index 1 *)
-(* The same thing is done for mutual inductive names
- it replaces also the old mind_equiv field of mutual
- inductive types*)
type mutual_inductive = kernel_name*kernel_name
type inductive = mutual_inductive * int
type constructor = inductive * int
-let constant_of_kn kn = (kn,kn)
-let constant_of_kn_equiv kn1 kn2 = (kn1,kn2)
-let make_con mp dir l = constant_of_kn (mp,dir,l)
-let make_con_equiv mp1 mp2 dir l = ((mp1,dir,l),(mp2,dir,l))
-let canonical_con con = snd con
-let user_con con = fst con
-let repr_con con = fst con
-let string_of_con con = string_of_kn (fst con)
-let con_label con = label (fst con)
-let pr_con con = pr_kn (fst con)
-let debug_pr_con con = str "("++ pr_kn (fst con) ++ str ","++ pr_kn (snd con)++ str ")"
-let eq_constant (_,kn1) (_,kn2) = kn1=kn2
-let debug_string_of_con con = string_of_kn (fst con)^"'"^string_of_kn (snd con)
-
-let con_with_label ((mp1,dp1,l1),(mp2,dp2,l2) as con) lbl =
- if lbl = l1 && lbl = l2 then con
- else ((mp1,dp1,lbl),(mp2,dp2,lbl))
-
-let con_modpath con = modpath (fst con)
-
let mind_modpath mind = modpath (fst mind)
let ind_modpath ind = mind_modpath (fst ind)
let constr_modpath c = ind_modpath (fst c)
-
let mind_of_kn kn = (kn,kn)
let mind_of_kn_equiv kn1 kn2 = (kn1,kn2)
let make_mind mp dir l = ((mp,dir,l),(mp,dir,l))
@@ -253,12 +268,15 @@ let make_mind_equiv mp1 mp2 dir l = ((mp1,dir,l),(mp2,dir,l))
let canonical_mind mind = snd mind
let user_mind mind = fst mind
let repr_mind mind = fst mind
-let string_of_mind mind = string_of_kn (fst mind)
let mind_label mind= label (fst mind)
-let pr_mind mind = pr_kn (fst mind)
-let debug_pr_mind mind = str "("++ pr_kn (fst mind) ++ str ","++ pr_kn (snd mind)++ str ")"
+
let eq_mind (_,kn1) (_,kn2) = kn1=kn2
-let debug_string_of_mind mind = string_of_kn (fst mind)^"'"^string_of_kn (snd mind)
+
+let string_of_mind mind = string_of_kn (fst mind)
+let pr_mind mind = str (string_of_mind mind)
+let debug_string_of_mind mind =
+ "(" ^ string_of_kn (fst mind) ^ "," ^ string_of_kn (snd mind) ^ ")"
+let debug_pr_mind con = str (debug_string_of_mind con)
let ith_mutual_inductive (kn,_) i = (kn,i)
let ith_constructor_of_inductive ind i = (ind,i)
@@ -267,6 +285,10 @@ let index_of_constructor (ind,i) = i
let eq_ind (kn1,i1) (kn2,i2) = i1=i2&&eq_mind kn1 kn2
let eq_constructor (kn1,i1) (kn2,i2) = i1=i2&&eq_ind kn1 kn2
+module Mindmap = Map.Make(Canonical_ord)
+module Mindset = Set.Make(Canonical_ord)
+module Mindmap_env = Map.Make(User_ord)
+
module InductiveOrdered = struct
type t = inductive
let compare (spx,ix) (spy,iy) =
@@ -306,7 +328,8 @@ let eq_egr e1 e2 = match e1,e2 with
EvalConstRef con1, EvalConstRef con2 -> eq_constant con1 con2
| _,_ -> e1 = e2
-(* Hash-consing of name objects *)
+(** {6 Hash-consing of name objects } *)
+
module Hname = Hashcons.Make(
struct
type t = name
@@ -326,7 +349,7 @@ module Hdir = Hashcons.Make(
struct
type t = dir_path
type u = identifier -> identifier
- let hash_sub hident d = List.map hident d
+ let hash_sub hident d = list_smartmap hident d
let rec equal d1 d2 = match (d1,d2) with
| [],[] -> true
| id1::d1,id2::d2 -> id1 == id2 & equal d1 d2
@@ -337,9 +360,9 @@ module Hdir = Hashcons.Make(
module Huniqid = Hashcons.Make(
struct
type t = uniq_ident
- type u = (string -> string) * (dir_path -> dir_path)
- let hash_sub (hstr,hdir) (n,s,dir) = (n,hstr s,hdir dir)
- let equal (n1,s1,dir1) (n2,s2,dir2) = n1 = n2 & s1 = s2 & dir1 == dir2
+ type u = (identifier -> identifier) * (dir_path -> dir_path)
+ let hash_sub (hid,hdir) (n,s,dir) = (n,hid s,hdir dir)
+ let equal (n1,s1,dir1) (n2,s2,dir2) = n1 = n2 && s1 == s2 && dir1 == dir2
let hash = Hashtbl.hash
end)
@@ -355,34 +378,66 @@ module Hmod = Hashcons.Make(
let rec equal d1 d2 = match (d1,d2) with
| MPfile dir1, MPfile dir2 -> dir1 == dir2
| MPbound m1, MPbound m2 -> m1 == m2
- | MPdot (mod1,l1), MPdot (mod2,l2) -> equal mod1 mod2 & l1 = l2
+ | MPdot (mod1,l1), MPdot (mod2,l2) -> l1 == l2 && equal mod1 mod2
| _ -> false
let hash = Hashtbl.hash
end)
-
-module Hcn = Hashcons.Make(
- struct
- type t = kernel_name*kernel_name
+module Hkn = Hashcons.Make(
+ struct
+ type t = kernel_name
type u = (module_path -> module_path)
* (dir_path -> dir_path) * (string -> string)
- let hash_sub (hmod,hdir,hstr) ((md,dir,l),(mde,dire,le)) =
- ((hmod md, hdir dir, hstr l),(hmod mde, hdir dire, hstr le))
- let equal ((mod1,dir1,l1),_) ((mod2,dir2,l2),_) =
+ let hash_sub (hmod,hdir,hstr) (md,dir,l) =
+ (hmod md, hdir dir, hstr l)
+ let equal (mod1,dir1,l1) (mod2,dir2,l2) =
mod1 == mod2 && dir1 == dir2 && l1 == l2
let hash = Hashtbl.hash
end)
-let hcons_names () =
- let hstring = Hashcons.simple_hcons Hashcons.Hstring.f () in
- let hident = Hashcons.simple_hcons Hident.f hstring in
- let hname = Hashcons.simple_hcons Hname.f hident in
- let hdir = Hashcons.simple_hcons Hdir.f hident in
- let huniqid = Hashcons.simple_hcons Huniqid.f (hstring,hdir) in
- let hmod = Hashcons.simple_hcons Hmod.f (hdir,huniqid,hstring) in
- let hmind = Hashcons.simple_hcons Hcn.f (hmod,hdir,hstring) in
- let hcn = Hashcons.simple_hcons Hcn.f (hmod,hdir,hstring) in
- (hcn,hmind,hdir,hname,hident,hstring)
+(** For [constant] and [mutual_inductive], we discriminate only on
+ the user part : having the same user part implies having the
+ same canonical part (invariant of the system). *)
+
+module Hcn = Hashcons.Make(
+ struct
+ type t = kernel_name*kernel_name
+ type u = kernel_name -> kernel_name
+ let hash_sub hkn (user,can) = (hkn user, hkn can)
+ let equal (user1,_) (user2,_) = user1 == user2
+ let hash (user,_) = Hashtbl.hash user
+ end)
+
+module Hind = Hashcons.Make(
+ struct
+ type t = inductive
+ type u = mutual_inductive -> mutual_inductive
+ let hash_sub hmind (mind, i) = (hmind mind, i)
+ let equal (mind1,i1) (mind2,i2) = mind1 == mind2 && i1 = i2
+ let hash = Hashtbl.hash
+ end)
+
+module Hconstruct = Hashcons.Make(
+ struct
+ type t = constructor
+ type u = inductive -> inductive
+ let hash_sub hind (ind, j) = (hind ind, j)
+ let equal (ind1,j1) (ind2,j2) = ind1 == ind2 && j1 = j2
+ let hash = Hashtbl.hash
+ end)
+
+let hcons_string = Hashcons.simple_hcons Hashcons.Hstring.f ()
+let hcons_ident = hcons_string
+let hcons_name = Hashcons.simple_hcons Hname.f hcons_ident
+let hcons_dirpath = Hashcons.simple_hcons Hdir.f hcons_ident
+let hcons_uid = Hashcons.simple_hcons Huniqid.f (hcons_ident,hcons_dirpath)
+let hcons_mp =
+ Hashcons.simple_hcons Hmod.f (hcons_dirpath,hcons_uid,hcons_string)
+let hcons_kn = Hashcons.simple_hcons Hkn.f (hcons_mp,hcons_dirpath,hcons_string)
+let hcons_con = Hashcons.simple_hcons Hcn.f hcons_kn
+let hcons_mind = Hashcons.simple_hcons Hcn.f hcons_kn
+let hcons_ind = Hashcons.simple_hcons Hind.f hcons_mind
+let hcons_construct = Hashcons.simple_hcons Hconstruct.f hcons_ind
(*******)
diff --git a/kernel/names.mli b/kernel/names.mli
index 612851dd..34c5e62c 100644
--- a/kernel/names.mli
+++ b/kernel/names.mli
@@ -1,62 +1,59 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: names.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*s Identifiers *)
+(** {6 Identifiers } *)
type identifier
-type name = Name of identifier | Anonymous
-(* Parsing and printing of identifiers *)
+
+(** Parsing and printing of identifiers *)
val string_of_id : identifier -> string
val id_of_string : string -> identifier
val id_ord : identifier -> identifier -> int
-(* Identifiers sets and maps *)
+(** Identifiers sets and maps *)
module Idset : Set.S with type elt = identifier
module Idpred : Predicate.S with type elt = identifier
-module Idmap : Map.S with type key = identifier
+module Idmap : sig
+ include Map.S with type key = identifier
+ val exists : (identifier -> 'a -> bool) -> 'a t -> bool
+ val singleton : key -> 'a -> 'a t
+end
+
+(** {6 Various types based on identifiers } *)
+
+type name = Name of identifier | Anonymous
+type variable = identifier
+
+(** {6 Directory paths = section names paths } *)
-(*s Directory paths = section names paths *)
type module_ident = identifier
module ModIdmap : Map.S with type key = module_ident
type dir_path
-(* Inner modules idents on top of list (to improve sharing).
+(** Inner modules idents on top of list (to improve sharing).
For instance: A.B.C is ["C";"B";"A"] *)
val make_dirpath : module_ident list -> dir_path
val repr_dirpath : dir_path -> module_ident list
val empty_dirpath : dir_path
-(* Printing of directory paths as ["coq_root.module.submodule"] *)
+(** Printing of directory paths as ["coq_root.module.submodule"] *)
val string_of_dirpath : dir_path -> string
-type label
-
-(*s Unique names for bound modules *)
-type mod_bound_id
-
-(* The first argument is a file name - to prevent conflict between
- different files *)
-val make_mbid : dir_path -> string -> mod_bound_id
-val repr_mbid : mod_bound_id -> int * string * dir_path
-val id_of_mbid : mod_bound_id -> identifier
-val label_of_mbid : mod_bound_id -> label
-val debug_string_of_mbid : mod_bound_id -> string
-val string_of_mbid : mod_bound_id -> string
+(** {6 Names of structure elements } *)
-(*s Names of structure elements *)
+type label
val mk_label : string -> label
val string_of_label : label -> string
+val pr_label : label -> Pp.std_ppcmds
val label_of_id : identifier -> label
val id_of_label : label -> identifier
@@ -64,14 +61,26 @@ val id_of_label : label -> identifier
module Labset : Set.S with type elt = label
module Labmap : Map.S with type key = label
-(*s The module part of the kernel name *)
+(** {6 Unique names for bound modules } *)
+
+type mod_bound_id
+
+(** The first argument is a file name - to prevent conflict between
+ different files *)
+
+val make_mbid : dir_path -> identifier -> mod_bound_id
+val repr_mbid : mod_bound_id -> int * identifier * dir_path
+val id_of_mbid : mod_bound_id -> identifier
+val debug_string_of_mbid : mod_bound_id -> string
+val string_of_mbid : mod_bound_id -> string
+
+(** {6 The module part of the kernel name } *)
+
type module_path =
| MPfile of dir_path
| MPbound of mod_bound_id
- (* | MPapp of module_path * module_path very soon *)
| MPdot of module_path * label
-
val check_bound_mp : module_path -> bool
val string_of_mp : module_path -> string
@@ -79,17 +88,17 @@ val string_of_mp : module_path -> string
module MPset : Set.S with type elt = module_path
module MPmap : Map.S with type key = module_path
-(* Initial "seed" of the unique identifier generator *)
+(** Initial "seed" of the unique identifier generator *)
val initial_dir : dir_path
-(* Name of the toplevel structure *)
-val initial_path : module_path (* [= MPfile initial_dir] *)
+(** Name of the toplevel structure *)
+val initial_path : module_path (** [= MPfile initial_dir] *)
-(*s The absolute names of objects seen by kernel *)
+(** {6 The absolute names of objects seen by kernel } *)
type kernel_name
-(* Constructor and destructor *)
+(** Constructor and destructor *)
val make_kn : module_path -> dir_path -> label -> kernel_name
val repr_kn : kernel_name -> module_path * dir_path * label
@@ -99,23 +108,25 @@ val label : kernel_name -> label
val string_of_kn : kernel_name -> string
val pr_kn : kernel_name -> Pp.std_ppcmds
+val kn_ord : kernel_name -> kernel_name -> int
module KNset : Set.S with type elt = kernel_name
module KNpred : Predicate.S with type elt = kernel_name
module KNmap : Map.S with type key = kernel_name
-(*s Specific paths for declarations *)
+(** {6 Specific paths for declarations } *)
-type variable = identifier
type constant
type mutual_inductive
-(* Beware: first inductive has index 0 *)
+
+(** Beware: first inductive has index 0 *)
type inductive = mutual_inductive * int
-(* Beware: first constructor has index 1 *)
+
+(** Beware: first constructor has index 1 *)
type constructor = inductive * int
-(* *_env modules consider an order on user part of names
+(** *_env modules consider an order on user part of names
the others consider an order on canonical part of names*)
module Cmap : Map.S with type key = constant
module Cmap_env : Map.S with type key = constant
@@ -169,7 +180,6 @@ val debug_string_of_mind : mutual_inductive -> string
-val mind_modpath : mutual_inductive -> module_path
val ind_modpath : inductive -> module_path
val constr_modpath : constructor -> module_path
@@ -180,7 +190,7 @@ val index_of_constructor : constructor -> int
val eq_ind : inductive -> inductive -> bool
val eq_constructor : constructor -> constructor -> bool
-(* Better to have it here that in Closure, since required in grammar.cma *)
+(** Better to have it here that in Closure, since required in grammar.cma *)
type evaluable_global_reference =
| EvalVarRef of identifier
| EvalConstRef of constant
@@ -188,12 +198,16 @@ type evaluable_global_reference =
val eq_egr : evaluable_global_reference -> evaluable_global_reference
-> bool
-(* Hash-consing *)
-val hcons_names : unit ->
- (constant -> constant) *
- (mutual_inductive -> mutual_inductive) * (dir_path -> dir_path) *
- (name -> name) * (identifier -> identifier) * (string -> string)
+(** {6 Hash-consing } *)
+val hcons_string : string -> string
+val hcons_ident : identifier -> identifier
+val hcons_name : name -> name
+val hcons_dirpath : dir_path -> dir_path
+val hcons_con : constant -> constant
+val hcons_mind : mutual_inductive -> mutual_inductive
+val hcons_ind : inductive -> inductive
+val hcons_construct : constructor -> constructor
(******)
@@ -209,8 +223,8 @@ val full_transparent_state : transparent_state
val var_full_transparent_state : transparent_state
val cst_full_transparent_state : transparent_state
-type inv_rel_key = int (* index in the [rel_context] part of environment
- starting by the end, {\em inverse}
+type inv_rel_key = int (** index in the [rel_context] part of environment
+ starting by the end, {e inverse}
of de Bruijn indice *)
type id_key = inv_rel_key tableKey
diff --git a/kernel/pre_env.ml b/kernel/pre_env.ml
index c852ab72..985aac95 100644
--- a/kernel/pre_env.ml
+++ b/kernel/pre_env.ml
@@ -1,12 +1,17 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: pre_env.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
+(* Created by Benjamin Grégoire out of environ.ml for better
+ modularity in the design of the bytecode virtual evaluation
+ machine, Dec 2005 *)
+(* Bug fix by Jean-Marc Notin *)
+
+(* This file defines the type of kernel environments *)
open Util
open Names
diff --git a/kernel/pre_env.mli b/kernel/pre_env.mli
index 70776551..40ce887b 100644
--- a/kernel/pre_env.mli
+++ b/kernel/pre_env.mli
@@ -1,13 +1,11 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: pre_env.mli 14641 2011-11-06 11:59:10Z herbelin $ *)
-
open Util
open Names
open Sign
@@ -15,7 +13,7 @@ open Univ
open Term
open Declarations
-(* The type of environments. *)
+(** The type of environments. *)
type key = int option ref
@@ -57,25 +55,27 @@ val empty_named_context_val : named_context_val
val empty_env : env
-(* Rel context *)
+(** Rel context *)
val nb_rel : env -> int
val push_rel : rel_declaration -> env -> env
val lookup_rel_val : int -> env -> lazy_val
val env_of_rel : int -> env -> env
-(* Named context *)
+
+(** Named context *)
val push_named_context_val :
named_declaration -> named_context_val -> named_context_val
val push_named : named_declaration -> env -> env
val lookup_named_val : identifier -> env -> lazy_val
val env_of_named : identifier -> env -> env
-(* Global constants *)
+
+(** Global constants *)
val lookup_constant_key : constant -> env -> constant_key
val lookup_constant : constant -> env -> constant_body
-(* Mutual Inductives *)
+(** Mutual Inductives *)
val lookup_mind : mutual_inductive -> env -> mutual_inductive_body
diff --git a/kernel/reduction.ml b/kernel/reduction.ml
index 38d1c70b..fc5e32cf 100644
--- a/kernel/reduction.ml
+++ b/kernel/reduction.ml
@@ -1,12 +1,19 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: reduction.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
+(* Created under Benjamin Werner account by Bruno Barras to implement
+ a call-by-value conversion algorithm and a lazy reduction machine
+ with sharing, Nov 1996 *)
+(* Addition of zeta-reduction (let-in contraction) by Hugo Herbelin, Oct 2000 *)
+(* Irreversibility of opacity by Bruno Barras *)
+(* Cleaning and lightening of the kernel by Bruno Barras, Nov 2001 *)
+(* Equal inductive types by Jacek Chrzaszcz as part of the module
+ system, Aug 2002 *)
open Util
open Names
@@ -190,9 +197,9 @@ let sort_cmp pb s0 s1 cuniv =
| (_, _) -> raise NotConvertible
-let conv_sort env s0 s1 = sort_cmp CONV s0 s1 Constraint.empty
+let conv_sort env s0 s1 = sort_cmp CONV s0 s1 empty_constraint
-let conv_sort_leq env s0 s1 = sort_cmp CUMUL s0 s1 Constraint.empty
+let conv_sort_leq env s0 s1 = sort_cmp CUMUL s0 s1 empty_constraint
let rec no_arg_available = function
| [] -> true
@@ -232,14 +239,14 @@ let in_whnf (t,stk) =
| FLOCKED -> assert false
(* Conversion between [lft1]term1 and [lft2]term2 *)
-let rec ccnv cv_pb infos lft1 lft2 term1 term2 cuniv =
- eqappr cv_pb infos (lft1, (term1,[])) (lft2, (term2,[])) cuniv
+let rec ccnv cv_pb l2r infos lft1 lft2 term1 term2 cuniv =
+ eqappr cv_pb l2r infos (lft1, (term1,[])) (lft2, (term2,[])) cuniv
(* Conversion between [lft1](hd1 v1) and [lft2](hd2 v2) *)
-and eqappr cv_pb infos (lft1,st1) (lft2,st2) cuniv =
+and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv =
Util.check_for_interrupt ();
(* First head reduce both terms *)
- let rec whd_both (t1,stk1) (t2,stk2) =
+ let rec whd_both (t1,stk1) (t2,stk2) =
let st1' = whd_stack (snd infos) t1 stk1 in
let st2' = whd_stack (snd infos) t2 stk2 in
(* Now, whd_stack on term2 might have modified st1 (due to sharing),
@@ -260,13 +267,13 @@ and eqappr cv_pb infos (lft1,st1) (lft2,st2) cuniv =
sort_cmp cv_pb s1 s2 cuniv
| (Meta n, Meta m) ->
if n=m
- then convert_stacks infos lft1 lft2 v1 v2 cuniv
+ then convert_stacks l2r infos lft1 lft2 v1 v2 cuniv
else raise NotConvertible
| _ -> raise NotConvertible)
| (FEvar ((ev1,args1),env1), FEvar ((ev2,args2),env2)) ->
if ev1=ev2 then
- let u1 = convert_stacks infos lft1 lft2 v1 v2 cuniv in
- convert_vect infos el1 el2
+ let u1 = convert_stacks l2r infos lft1 lft2 v1 v2 cuniv in
+ convert_vect l2r infos el1 el2
(Array.map (mk_clos env1) args1)
(Array.map (mk_clos env2) args2) u1
else raise NotConvertible
@@ -274,19 +281,19 @@ and eqappr cv_pb infos (lft1,st1) (lft2,st2) cuniv =
(* 2 index known to be bound to no constant *)
| (FRel n, FRel m) ->
if reloc_rel n el1 = reloc_rel m el2
- then convert_stacks infos lft1 lft2 v1 v2 cuniv
+ then convert_stacks l2r infos lft1 lft2 v1 v2 cuniv
else raise NotConvertible
(* 2 constants, 2 local defined vars or 2 defined rels *)
| (FFlex fl1, FFlex fl2) ->
(try (* try first intensional equality *)
if eq_table_key fl1 fl2
- then convert_stacks infos lft1 lft2 v1 v2 cuniv
+ then convert_stacks l2r infos lft1 lft2 v1 v2 cuniv
else raise NotConvertible
with NotConvertible ->
(* else the oracle tells which constant is to be expanded *)
let (app1,app2) =
- if Conv_oracle.oracle_order fl1 fl2 then
+ if Conv_oracle.oracle_order l2r fl1 fl2 then
match unfold_reference infos fl1 with
| Some def1 -> ((lft1, whd_stack (snd infos) def1 v1), appr2)
| None ->
@@ -300,79 +307,95 @@ and eqappr cv_pb infos (lft1,st1) (lft2,st2) cuniv =
(match unfold_reference infos fl1 with
| Some def1 -> ((lft1, whd_stack (snd infos) def1 v1), appr2)
| None -> raise NotConvertible) in
- eqappr cv_pb infos app1 app2 cuniv)
-
- (* only one constant, defined var or defined rel *)
- | (FFlex fl1, _) ->
- (match unfold_reference infos fl1 with
- | Some def1 ->
- eqappr cv_pb infos (lft1, whd_stack (snd infos) def1 v1) appr2 cuniv
- | None -> raise NotConvertible)
- | (_, FFlex fl2) ->
- (match unfold_reference infos fl2 with
- | Some def2 ->
- eqappr cv_pb infos appr1 (lft2, whd_stack (snd infos) def2 v2) cuniv
- | None -> raise NotConvertible)
+ eqappr cv_pb l2r infos app1 app2 cuniv)
(* other constructors *)
| (FLambda _, FLambda _) ->
+ (* Inconsistency: we tolerate that v1, v2 contain shift and update but
+ we throw them away *)
if not (is_empty_stack v1 && is_empty_stack v2) then
anomaly "conversion was given ill-typed terms (FLambda)";
let (_,ty1,bd1) = destFLambda mk_clos hd1 in
let (_,ty2,bd2) = destFLambda mk_clos hd2 in
- let u1 = ccnv CONV infos el1 el2 ty1 ty2 cuniv in
- ccnv CONV infos (el_lift el1) (el_lift el2) bd1 bd2 u1
+ let u1 = ccnv CONV l2r infos el1 el2 ty1 ty2 cuniv in
+ ccnv CONV l2r infos (el_lift el1) (el_lift el2) bd1 bd2 u1
| (FProd (_,c1,c2), FProd (_,c'1,c'2)) ->
if not (is_empty_stack v1 && is_empty_stack v2) then
anomaly "conversion was given ill-typed terms (FProd)";
(* Luo's system *)
- let u1 = ccnv CONV infos el1 el2 c1 c'1 cuniv in
- ccnv cv_pb infos (el_lift el1) (el_lift el2) c2 c'2 u1
+ let u1 = ccnv CONV l2r infos el1 el2 c1 c'1 cuniv in
+ ccnv cv_pb l2r infos (el_lift el1) (el_lift el2) c2 c'2 u1
+
+ (* Eta-expansion on the fly *)
+ | (FLambda _, _) ->
+ if v1 <> [] then
+ anomaly "conversion was given unreduced term (FLambda)";
+ let (_,_ty1,bd1) = destFLambda mk_clos hd1 in
+ eqappr CONV l2r infos
+ (el_lift lft1, (bd1, [])) (el_lift lft2, (hd2, eta_expand_stack v2)) cuniv
+ | (_, FLambda _) ->
+ if v2 <> [] then
+ anomaly "conversion was given unreduced term (FLambda)";
+ let (_,_ty2,bd2) = destFLambda mk_clos hd2 in
+ eqappr CONV l2r infos
+ (el_lift lft1, (hd1, eta_expand_stack v1)) (el_lift lft2, (bd2, [])) cuniv
+
+ (* only one constant, defined var or defined rel *)
+ | (FFlex fl1, _) ->
+ (match unfold_reference infos fl1 with
+ | Some def1 ->
+ eqappr cv_pb l2r infos (lft1, whd_stack (snd infos) def1 v1) appr2 cuniv
+ | None -> raise NotConvertible)
+ | (_, FFlex fl2) ->
+ (match unfold_reference infos fl2 with
+ | Some def2 ->
+ eqappr cv_pb l2r infos appr1 (lft2, whd_stack (snd infos) def2 v2) cuniv
+ | None -> raise NotConvertible)
(* Inductive types: MutInd MutConstruct Fix Cofix *)
- | (FInd ind1, FInd ind2) ->
- if eq_ind ind1 ind2
- then
- convert_stacks infos lft1 lft2 v1 v2 cuniv
- else raise NotConvertible
-
- | (FConstruct (ind1,j1), FConstruct (ind2,j2)) ->
- if j1 = j2 && eq_ind ind1 ind2
- then
- convert_stacks infos lft1 lft2 v1 v2 cuniv
- else raise NotConvertible
-
- | (FFix ((op1,(_,tys1,cl1)),e1), FFix((op2,(_,tys2,cl2)),e2)) ->
- if op1 = op2
- then
- let n = Array.length cl1 in
- let fty1 = Array.map (mk_clos e1) tys1 in
- let fty2 = Array.map (mk_clos e2) tys2 in
- let fcl1 = Array.map (mk_clos (subs_liftn n e1)) cl1 in
- let fcl2 = Array.map (mk_clos (subs_liftn n e2)) cl2 in
- let u1 = convert_vect infos el1 el2 fty1 fty2 cuniv in
- let u2 =
- convert_vect infos
- (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 u1 in
- convert_stacks infos lft1 lft2 v1 v2 u2
- else raise NotConvertible
-
- | (FCoFix ((op1,(_,tys1,cl1)),e1), FCoFix((op2,(_,tys2,cl2)),e2)) ->
- if op1 = op2
- then
- let n = Array.length cl1 in
- let fty1 = Array.map (mk_clos e1) tys1 in
- let fty2 = Array.map (mk_clos e2) tys2 in
- let fcl1 = Array.map (mk_clos (subs_liftn n e1)) cl1 in
- let fcl2 = Array.map (mk_clos (subs_liftn n e2)) cl2 in
- let u1 = convert_vect infos el1 el2 fty1 fty2 cuniv in
- let u2 =
- convert_vect infos
- (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 u1 in
- convert_stacks infos lft1 lft2 v1 v2 u2
- else raise NotConvertible
+ | (FInd ind1, FInd ind2) ->
+ if eq_ind ind1 ind2
+ then
+ convert_stacks l2r infos lft1 lft2 v1 v2 cuniv
+ else raise NotConvertible
+
+ | (FConstruct (ind1,j1), FConstruct (ind2,j2)) ->
+ if j1 = j2 && eq_ind ind1 ind2
+ then
+ convert_stacks l2r infos lft1 lft2 v1 v2 cuniv
+ else raise NotConvertible
+
+ | (FFix ((op1,(_,tys1,cl1)),e1), FFix((op2,(_,tys2,cl2)),e2)) ->
+ if op1 = op2
+ then
+ let n = Array.length cl1 in
+ let fty1 = Array.map (mk_clos e1) tys1 in
+ let fty2 = Array.map (mk_clos e2) tys2 in
+ let fcl1 = Array.map (mk_clos (subs_liftn n e1)) cl1 in
+ let fcl2 = Array.map (mk_clos (subs_liftn n e2)) cl2 in
+ let u1 = convert_vect l2r infos el1 el2 fty1 fty2 cuniv in
+ let u2 =
+ convert_vect l2r infos
+ (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 u1 in
+ convert_stacks l2r infos lft1 lft2 v1 v2 u2
+ else raise NotConvertible
+
+ | (FCoFix ((op1,(_,tys1,cl1)),e1), FCoFix((op2,(_,tys2,cl2)),e2)) ->
+ if op1 = op2
+ then
+ let n = Array.length cl1 in
+ let fty1 = Array.map (mk_clos e1) tys1 in
+ let fty2 = Array.map (mk_clos e2) tys2 in
+ let fcl1 = Array.map (mk_clos (subs_liftn n e1)) cl1 in
+ let fcl2 = Array.map (mk_clos (subs_liftn n e2)) cl2 in
+ let u1 = convert_vect l2r infos el1 el2 fty1 fty2 cuniv in
+ let u2 =
+ convert_vect l2r infos
+ (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 u1 in
+ convert_stacks l2r infos lft1 lft2 v1 v2 u2
+ else raise NotConvertible
(* Should not happen because both (hd1,v1) and (hd2,v2) are in whnf *)
| ( (FLetIn _, _) | (FCases _,_) | (FApp _,_) | (FCLOS _,_) | (FLIFT _,_)
@@ -382,13 +405,13 @@ and eqappr cv_pb infos (lft1,st1) (lft2,st2) cuniv =
(* In all other cases, terms are not convertible *)
| _ -> raise NotConvertible
-and convert_stacks infos lft1 lft2 stk1 stk2 cuniv =
+and convert_stacks l2r infos lft1 lft2 stk1 stk2 cuniv =
compare_stacks
- (fun (l1,t1) (l2,t2) c -> ccnv CONV infos l1 l2 t1 t2 c)
+ (fun (l1,t1) (l2,t2) c -> ccnv CONV l2r infos l1 l2 t1 t2 c)
(eq_ind)
lft1 stk1 lft2 stk2 cuniv
-and convert_vect infos lft1 lft2 v1 v2 cuniv =
+and convert_vect l2r infos lft1 lft2 v1 v2 cuniv =
let lv1 = Array.length v1 in
let lv2 = Array.length v2 in
if lv1 = lv2
@@ -396,62 +419,62 @@ and convert_vect infos lft1 lft2 v1 v2 cuniv =
let rec fold n univ =
if n >= lv1 then univ
else
- let u1 = ccnv CONV infos lft1 lft2 v1.(n) v2.(n) univ in
+ let u1 = ccnv CONV l2r infos lft1 lft2 v1.(n) v2.(n) univ in
fold (n+1) u1 in
fold 0 cuniv
else raise NotConvertible
-let clos_fconv trans cv_pb evars env t1 t2 =
+let clos_fconv trans cv_pb l2r evars env t1 t2 =
let infos = trans, create_clos_infos ~evars betaiotazeta env in
- ccnv cv_pb infos ELID ELID (inject t1) (inject t2) Constraint.empty
+ ccnv cv_pb l2r infos el_id el_id (inject t1) (inject t2) empty_constraint
-let trans_fconv reds cv_pb evars env t1 t2 =
- if eq_constr t1 t2 then Constraint.empty
- else clos_fconv reds cv_pb evars env t1 t2
+let trans_fconv reds cv_pb l2r evars env t1 t2 =
+ if eq_constr t1 t2 then empty_constraint
+ else clos_fconv reds cv_pb l2r evars env t1 t2
-let trans_conv_cmp conv reds = trans_fconv reds conv (fun _->None)
-let trans_conv ?(evars=fun _->None) reds = trans_fconv reds CONV evars
-let trans_conv_leq ?(evars=fun _->None) reds = trans_fconv reds CUMUL evars
+let trans_conv_cmp ?(l2r=false) conv reds = trans_fconv reds conv l2r (fun _->None)
+let trans_conv ?(l2r=false) ?(evars=fun _->None) reds = trans_fconv reds CONV l2r evars
+let trans_conv_leq ?(l2r=false) ?(evars=fun _->None) reds = trans_fconv reds CUMUL l2r evars
let fconv = trans_fconv (Idpred.full, Cpred.full)
-let conv_cmp cv_pb = fconv cv_pb (fun _->None)
-let conv ?(evars=fun _->None) = fconv CONV evars
-let conv_leq ?(evars=fun _->None) = fconv CUMUL evars
+let conv_cmp ?(l2r=false) cv_pb = fconv cv_pb l2r (fun _->None)
+let conv ?(l2r=false) ?(evars=fun _->None) = fconv CONV l2r evars
+let conv_leq ?(l2r=false) ?(evars=fun _->None) = fconv CUMUL l2r evars
-let conv_leq_vecti ?(evars=fun _->None) env v1 v2 =
+let conv_leq_vecti ?(l2r=false) ?(evars=fun _->None) env v1 v2 =
array_fold_left2_i
(fun i c t1 t2 ->
let c' =
- try conv_leq ~evars env t1 t2
+ try conv_leq ~l2r ~evars env t1 t2
with NotConvertible -> raise (NotConvertibleVect i) in
- Constraint.union c c')
- Constraint.empty
+ union_constraints c c')
+ empty_constraint
v1
v2
(* option for conversion *)
-let vm_conv = ref (fun cv_pb -> fconv cv_pb (fun _->None))
+let vm_conv = ref (fun cv_pb -> fconv cv_pb false (fun _->None))
let set_vm_conv f = vm_conv := f
let vm_conv cv_pb env t1 t2 =
try
!vm_conv cv_pb env t1 t2
with Not_found | Invalid_argument _ ->
(* If compilation fails, fall-back to closure conversion *)
- fconv cv_pb (fun _->None) env t1 t2
+ fconv cv_pb false (fun _->None) env t1 t2
-let default_conv = ref (fun cv_pb -> fconv cv_pb (fun _->None))
+let default_conv = ref (fun cv_pb ?(l2r=false) -> fconv cv_pb l2r (fun _->None))
let set_default_conv f = default_conv := f
-let default_conv cv_pb env t1 t2 =
+let default_conv cv_pb ?(l2r=false) env t1 t2 =
try
- !default_conv cv_pb env t1 t2
+ !default_conv ~l2r cv_pb env t1 t2
with Not_found | Invalid_argument _ ->
(* If compilation fails, fall-back to closure conversion *)
- fconv cv_pb (fun _->None) env t1 t2
+ fconv cv_pb false (fun _->None) env t1 t2
let default_conv_leq = default_conv CUMUL
(*
@@ -511,15 +534,16 @@ let dest_prod_assum env =
in
prodec_rec env empty_rel_context
+exception NotArity
+
let dest_arity env c =
let l, c = dest_prod_assum env c in
match kind_of_term c with
| Sort s -> l,s
- | _ -> error "not an arity"
+ | _ -> raise NotArity
let is_arity env c =
try
let _ = dest_arity env c in
true
- with UserError _ -> false
-
+ with NotArity -> false
diff --git a/kernel/reduction.mli b/kernel/reduction.mli
index 4a3e4cd5..aa78fbda 100644
--- a/kernel/reduction.mli
+++ b/kernel/reduction.mli
@@ -1,21 +1,17 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: reduction.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
open Term
open Environ
open Closure
-(*i*)
-(************************************************************************)
-(*s Reduction functions *)
+(***********************************************************************
+ s Reduction functions *)
val whd_betaiotazeta : constr -> constr
val whd_betadeltaiota : env -> constr -> constr
@@ -24,8 +20,8 @@ val whd_betadeltaiota_nolet : env -> constr -> constr
val whd_betaiota : constr -> constr
val nf_betaiota : constr -> constr
-(************************************************************************)
-(*s conversion functions *)
+(***********************************************************************
+ s conversion functions *)
exception NotConvertible
exception NotConvertibleVect of int
@@ -40,45 +36,47 @@ val sort_cmp :
val conv_sort : sorts conversion_function
val conv_sort_leq : sorts conversion_function
-val trans_conv_cmp : conv_pb -> constr trans_conversion_function
+val trans_conv_cmp : ?l2r:bool -> conv_pb -> constr trans_conversion_function
val trans_conv :
- ?evars:(existential->constr option) -> constr trans_conversion_function
+ ?l2r:bool -> ?evars:(existential->constr option) -> constr trans_conversion_function
val trans_conv_leq :
- ?evars:(existential->constr option) -> types trans_conversion_function
+ ?l2r:bool -> ?evars:(existential->constr option) -> types trans_conversion_function
-val conv_cmp : conv_pb -> constr conversion_function
+val conv_cmp : ?l2r:bool -> conv_pb -> constr conversion_function
val conv :
- ?evars:(existential->constr option) -> constr conversion_function
+ ?l2r:bool -> ?evars:(existential->constr option) -> constr conversion_function
val conv_leq :
- ?evars:(existential->constr option) -> types conversion_function
+ ?l2r:bool -> ?evars:(existential->constr option) -> types conversion_function
val conv_leq_vecti :
- ?evars:(existential->constr option) -> types array conversion_function
+ ?l2r:bool -> ?evars:(existential->constr option) -> types array conversion_function
-(* option for conversion *)
+(** option for conversion *)
val set_vm_conv : (conv_pb -> types conversion_function) -> unit
val vm_conv : conv_pb -> types conversion_function
-val set_default_conv : (conv_pb -> types conversion_function) -> unit
-val default_conv : conv_pb -> types conversion_function
-val default_conv_leq : types conversion_function
+val set_default_conv : (conv_pb -> ?l2r:bool -> types conversion_function) -> unit
+val default_conv : conv_pb -> ?l2r:bool -> types conversion_function
+val default_conv_leq : ?l2r:bool -> types conversion_function
(************************************************************************)
-(* Builds an application node, reducing beta redexes it may produce. *)
+(** Builds an application node, reducing beta redexes it may produce. *)
val beta_appvect : constr -> constr array -> constr
-(* Builds an application node, reducing the [n] first beta-zeta redexes. *)
+(** Builds an application node, reducing the [n] first beta-zeta redexes. *)
val betazeta_appvect : int -> constr -> constr array -> constr
-(* Pseudo-reduction rule Prod(x,A,B) a --> B[x\a] *)
+(** Pseudo-reduction rule Prod(x,A,B) a --> B[x\a] *)
val hnf_prod_applist : env -> types -> constr list -> types
-(************************************************************************)
-(*s Recognizing products and arities modulo reduction *)
+(***********************************************************************
+ s Recognizing products and arities modulo reduction *)
val dest_prod : env -> types -> rel_context * types
val dest_prod_assum : env -> types -> rel_context * types
-val dest_arity : env -> types -> arity
+exception NotArity
+
+val dest_arity : env -> types -> arity (* raises NotArity if not an arity *)
val is_arity : env -> types -> bool
diff --git a/kernel/retroknowledge.ml b/kernel/retroknowledge.ml
index 5e8dd9f8..10d0bae7 100644
--- a/kernel/retroknowledge.ml
+++ b/kernel/retroknowledge.ml
@@ -1,12 +1,17 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: retroknowledge.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
+(* Created by Arnaud Spiwack, May 2007 *)
+(* Addition of native Head (nb of heading 0) and Tail (nb of trailing 0) by
+ Benjamin Grégoire, Jun 2007 *)
+
+(* This file defines the knowledge that the kernel is able to optimize
+ for evaluation in the bytecode virtual machine *)
open Term
open Names
diff --git a/kernel/retroknowledge.mli b/kernel/retroknowledge.mli
index 6cf871d3..b9793f6d 100644
--- a/kernel/retroknowledge.mli
+++ b/kernel/retroknowledge.mli
@@ -1,24 +1,20 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: retroknowledge.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
open Names
open Term
-(*i*)
type retroknowledge
-(* aliased type for clarity purpose*)
+(** aliased type for clarity purpose*)
type entry = (constr, types) kind_of_term
-(* the following types correspond to the different "things"
+(** the following types correspond to the different "things"
the kernel can learn about.*)
type nat_field =
| NatType
@@ -58,25 +54,26 @@ type int31_field =
| Int31Tail0
type field =
-(* | KEq
+
+(** | KEq
| KNat of nat_field
| KN of n_field *)
| KInt31 of string*int31_field
-(* This type represent an atomic action of the retroknowledge. It
- is stored in the compiled libraries *)
-(* As per now, there is only the possibility of registering things
+(** This type represent an atomic action of the retroknowledge. It
+ is stored in the compiled libraries
+ As per now, there is only the possibility of registering things
the possibility of unregistering or changing the flag is under study *)
type action =
| RKRegister of field*entry
-(* initial value for retroknowledge *)
+(** initial value for retroknowledge *)
val initial_retroknowledge : retroknowledge
-(* Given an identifier id (usually Const _)
+(** Given an identifier id (usually Const _)
and the continuation cont of the bytecode compilation
returns the compilation of id in cont if it has a specific treatment
or raises Not_found if id should be compiled as usual *)
@@ -103,28 +100,29 @@ val get_vm_constant_dynamic_info : retroknowledge -> entry ->
Cbytecodes.comp_env ->
Cbytecodes.block array ->
int -> Cbytecodes.bytecodes -> Cbytecodes.bytecodes
-(* Given a type identifier, this function is used before compiling a match
+
+(** Given a type identifier, this function is used before compiling a match
over this type. In the case of 31-bit integers for instance, it is used
to add the instruction sequence which would perform a dynamic decompilation
in case the argument of the match is not in coq representation *)
val get_vm_before_match_info : retroknowledge -> entry -> Cbytecodes.bytecodes
-> Cbytecodes.bytecodes
-(* Given a type identifier, this function is used by pretyping/vnorm.ml to
+(** Given a type identifier, this function is used by pretyping/vnorm.ml to
recover the elements of that type from their compiled form if it's non
standard (it is used (and can be used) only when the compiled form
is not a block *)
val get_vm_decompile_constant_info : retroknowledge -> entry -> int -> Term.constr
-(* the following functions are solely used in Pre_env and Environ to implement
+(** the following functions are solely used in Pre_env and Environ to implement
the functions register and unregister (and mem) of Environ *)
val add_field : retroknowledge -> field -> entry -> retroknowledge
val mem : retroknowledge -> field -> bool
val remove : retroknowledge -> field -> retroknowledge
val find : retroknowledge -> field -> entry
-(* the following function manipulate the reactive information of values
+(** the following function manipulate the reactive information of values
they are only used by the functions of Pre_env, and Environ to implement
the functions register and unregister of Environ *)
val add_vm_compiling_info : retroknowledge-> entry ->
diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml
index 4575d5bc..c2d71ebb 100644
--- a/kernel/safe_typing.ml
+++ b/kernel/safe_typing.ml
@@ -1,12 +1,61 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: safe_typing.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
+(* Created by Jean-Christophe Filliâtre as part of the rebuilding of
+ Coq around a purely functional abstract type-checker, Dec 1999 *)
+
+(* This file provides the entry points to the kernel type-checker. It
+ defines the abstract type of well-formed environments and
+ implements the rules that build well-formed environments.
+
+ An environment is made of constants and inductive types (E), of
+ section declarations (Delta), of local bound-by-index declarations
+ (Gamma) and of universe constraints (C). Below E[Delta,Gamma] |-_C
+ means that the tuple E, Delta, Gamma, C is a well-formed
+ environment. Main rules are:
+
+ empty_environment:
+
+ ------
+ [,] |-
+
+ push_named_assum(a,T):
+
+ E[Delta,Gamma] |-_G
+ ------------------------
+ E[Delta,Gamma,a:T] |-_G'
+
+ push_named_def(a,t,T):
+
+ E[Delta,Gamma] |-_G
+ ---------------------------
+ E[Delta,Gamma,a:=t:T] |-_G'
+
+ add_constant(ConstantEntry(DefinitionEntry(c,t,T))):
+
+ E[Delta,Gamma] |-_G
+ ---------------------------
+ E,c:=t:T[Delta,Gamma] |-_G'
+
+ add_constant(ConstantEntry(ParameterEntry(c,T))):
+
+ E[Delta,Gamma] |-_G
+ ------------------------
+ E,c:T[Delta,Gamma] |-_G'
+
+ add_mind(Ind(Ind[Gamma_p](Gamma_I:=Gamma_C))):
+
+ E[Delta,Gamma] |-_G
+ ------------------------
+ E,Ind[Gamma_p](Gamma_I:=Gamma_C)[Delta,Gamma] |-_G'
+
+ etc.
+*)
open Util
open Names
@@ -41,25 +90,6 @@ type module_info =
resolver : delta_resolver;
resolver_of_param : delta_resolver;}
-let check_label l labset =
- if Labset.mem l labset then error_existing_label l
-
-let check_labels ls senv =
- Labset.iter (fun l -> check_label l senv) ls
-
-let labels_of_mib mib =
- let add,get =
- let labels = ref Labset.empty in
- (fun id -> labels := Labset.add (label_of_id id) !labels),
- (fun () -> !labels)
- in
- let visit_mip mip =
- add mip.mind_typename;
- Array.iter add mip.mind_consnames
- in
- Array.iter visit_mip mib.mind_packets;
- get ()
-
let set_engagement_opt oeng env =
match oeng with
Some eng -> set_engagement eng env
@@ -79,16 +109,26 @@ type safe_environment =
loads : (module_path * module_body) list;
local_retroknowledge : Retroknowledge.action list}
-(*
- { old = senv.old;
- env = ;
- modinfo = senv.modinfo;
- labset = ;
- revsign = ;
- imports = senv.imports ;
- loads = senv.loads }
-*)
+let exists_label l senv = Labset.mem l senv.labset
+
+let check_label l senv =
+ if exists_label l senv then error_existing_label l
+let check_labels ls senv =
+ Labset.iter (fun l -> check_label l senv) ls
+
+let labels_of_mib mib =
+ let add,get =
+ let labels = ref Labset.empty in
+ (fun id -> labels := Labset.add (label_of_id id) !labels),
+ (fun () -> !labels)
+ in
+ let visit_mip mip =
+ add mip.mind_typename;
+ Array.iter add mip.mind_consnames
+ in
+ Array.iter visit_mip mib.mind_packets;
+ get ()
(* a small hack to avoid variants and an unused case in all functions *)
let rec empty_environment =
@@ -102,7 +142,7 @@ let rec empty_environment =
resolver_of_param = empty_delta_resolver};
labset = Labset.empty;
revstruct = [];
- univ = Univ.Constraint.empty;
+ univ = Univ.empty_constraint;
engagement = None;
imports = [];
loads = [];
@@ -111,16 +151,50 @@ let rec empty_environment =
let env_of_safe_env senv = senv.env
let env_of_senv = env_of_safe_env
-
-
-
-
-
-
let add_constraints cst senv =
- {senv with
+ { senv with
env = Environ.add_constraints cst senv.env;
- univ = Univ.Constraint.union cst senv.univ }
+ univ = Univ.union_constraints cst senv.univ }
+
+let constraints_of_sfb = function
+ | SFBconst cb -> cb.const_constraints
+ | SFBmind mib -> mib.mind_constraints
+ | SFBmodtype mtb -> mtb.typ_constraints
+ | SFBmodule mb -> mb.mod_constraints
+
+(* A generic function for adding a new field in a same environment.
+ It also performs the corresponding [add_constraints]. *)
+
+type generic_name =
+ | C of constant
+ | I of mutual_inductive
+ | MT of module_path
+ | M
+
+let add_field ((l,sfb) as field) gn senv =
+ let labels = match sfb with
+ | SFBmind mib -> labels_of_mib mib
+ | _ -> Labset.singleton l
+ in
+ check_labels labels senv;
+ let senv = add_constraints (constraints_of_sfb sfb) senv in
+ let env' = match sfb, gn with
+ | SFBconst cb, C con -> Environ.add_constant con cb senv.env
+ | SFBmind mib, I mind -> Environ.add_mind mind mib senv.env
+ | SFBmodtype mtb, MT mp -> Environ.add_modtype mp mtb senv.env
+ | SFBmodule mb, M -> Modops.add_module mb senv.env
+ | _ -> assert false
+ in
+ { senv with
+ env = env';
+ labset = Labset.union labels senv.labset;
+ revstruct = field :: senv.revstruct }
+
+(* Applying a certain function to the resolver of a safe environment *)
+
+let update_resolver f senv =
+ let mi = senv.modinfo in
+ { senv with modinfo = { mi with resolver = f mi.resolver }}
(* universal lifting, used for the "get" operations mostly *)
@@ -131,8 +205,9 @@ let register senv field value by_clause =
(* todo : value closed, by_clause safe, by_clause of the proper type*)
(* spiwack : updates the safe_env with the information that the register
action has to be performed (again) when the environement is imported *)
- {senv with env = Environ.register senv.env field value;
- local_retroknowledge =
+ {senv with
+ env = Environ.register senv.env field value;
+ local_retroknowledge =
Retroknowledge.RKRegister (field,value)::senv.local_retroknowledge
}
@@ -185,52 +260,21 @@ type global_declaration =
| ConstantEntry of constant_entry
| GlobalRecipe of Cooking.recipe
-let hcons_constant_type = function
- | NonPolymorphicType t ->
- NonPolymorphicType (hcons1_constr t)
- | PolymorphicArity (ctx,s) ->
- PolymorphicArity (map_rel_context hcons1_constr ctx,s)
-
-let hcons_constant_body cb =
- let body = match cb.const_body with
- None -> None
- | Some l_constr -> let constr = Declarations.force l_constr in
- Some (Declarations.from_val (hcons1_constr constr))
- in
- { cb with
- const_body = body;
- const_type = hcons_constant_type cb.const_type }
-
let add_constant dir l decl senv =
- check_label l senv.labset;
let kn = make_con senv.modinfo.modpath dir l in
- let cb =
- match decl with
- | ConstantEntry ce -> translate_constant senv.env kn ce
- | GlobalRecipe r ->
- let cb = translate_recipe senv.env kn r in
- if dir = empty_dirpath then hcons_constant_body cb else cb
+ let cb = match decl with
+ | ConstantEntry ce -> translate_constant senv.env kn ce
+ | GlobalRecipe r ->
+ let cb = translate_recipe senv.env kn r in
+ if dir = empty_dirpath then hcons_const_body cb else cb
in
- let senv' = add_constraints cb.const_constraints senv in
- let env'' = Environ.add_constant kn cb senv'.env in
- let resolver =
- if cb.const_inline then
- add_inline_delta_resolver kn senv'.modinfo.resolver
- else
- senv'.modinfo.resolver
+ let senv' = add_field (l,SFBconst cb) (C kn) senv in
+ let senv'' = match cb.const_body with
+ | Undef (Some lev) ->
+ update_resolver (add_inline_delta_resolver (user_con kn) (lev,None)) senv'
+ | _ -> senv'
in
- kn, { old = senv'.old;
- env = env'';
- modinfo = {senv'.modinfo with
- resolver = resolver};
- labset = Labset.add l senv'.labset;
- revstruct = (l,SFBconst cb)::senv'.revstruct;
- univ = senv'.univ;
- engagement = senv'.engagement;
- imports = senv'.imports;
- loads = senv'.loads ;
- local_retroknowledge = senv'.local_retroknowledge }
-
+ kn, senv''
(* Insertion of inductive types. *)
@@ -242,79 +286,41 @@ let add_mind dir l mie senv =
if l <> label_of_id id then
anomaly ("the label of inductive packet and its first inductive"^
" type do not match");
- let mib = translate_mind senv.env mie in
- let labels = labels_of_mib mib in
- check_labels labels senv.labset;
- let senv' = add_constraints mib.mind_constraints senv in
let kn = make_mind senv.modinfo.modpath dir l in
- let env'' = Environ.add_mind kn mib senv'.env in
- kn, { old = senv'.old;
- env = env'';
- modinfo = senv'.modinfo;
- labset = Labset.union labels senv'.labset;
- revstruct = (l,SFBmind mib)::senv'.revstruct;
- univ = senv'.univ;
- engagement = senv'.engagement;
- imports = senv'.imports;
- loads = senv'.loads;
- local_retroknowledge = senv'.local_retroknowledge }
+ let mib = translate_mind senv.env kn mie in
+ let mib = if mib.mind_hyps <> [] then mib else hcons_mind mib in
+ let senv' = add_field (l,SFBmind mib) (I kn) senv in
+ kn, senv'
(* Insertion of module types *)
let add_modtype l mte inl senv =
- check_label l senv.labset;
let mp = MPdot(senv.modinfo.modpath, l) in
let mtb = translate_module_type senv.env mp inl mte in
- let senv' = add_constraints mtb.typ_constraints senv in
- let env'' = Environ.add_modtype mp mtb senv'.env in
- mp, { old = senv'.old;
- env = env'';
- modinfo = senv'.modinfo;
- labset = Labset.add l senv'.labset;
- revstruct = (l,SFBmodtype mtb)::senv'.revstruct;
- univ = senv'.univ;
- engagement = senv'.engagement;
- imports = senv'.imports;
- loads = senv'.loads;
- local_retroknowledge = senv'.local_retroknowledge }
-
+ let senv' = add_field (l,SFBmodtype mtb) (MT mp) senv in
+ mp, senv'
(* full_add_module adds module with universes and constraints *)
let full_add_module mb senv =
let senv = add_constraints mb.mod_constraints senv in
- let env = Modops.add_module mb senv.env in
- {senv with env = env}
+ { senv with env = Modops.add_module mb senv.env }
(* Insertion of modules *)
let add_module l me inl senv =
- check_label l senv.labset;
let mp = MPdot(senv.modinfo.modpath, l) in
let mb = translate_module senv.env mp inl me in
- let senv' = full_add_module mb senv in
- let modinfo = match mb.mod_type with
- SEBstruct _ ->
- { senv'.modinfo with
- resolver =
- add_delta_resolver mb.mod_delta senv'.modinfo.resolver}
- | _ -> senv'.modinfo
+ let senv' = add_field (l,SFBmodule mb) M senv in
+ let senv'' = match mb.mod_type with
+ | SEBstruct _ -> update_resolver (add_delta_resolver mb.mod_delta) senv'
+ | _ -> senv'
in
- mp,mb.mod_delta,
- { old = senv'.old;
- env = senv'.env;
- modinfo = modinfo;
- labset = Labset.add l senv'.labset;
- revstruct = (l,SFBmodule mb)::senv'.revstruct;
- univ = senv'.univ;
- engagement = senv'.engagement;
- imports = senv'.imports;
- loads = senv'.loads;
- local_retroknowledge = senv'.local_retroknowledge }
-
+ mp,mb.mod_delta,senv''
+
(* Interactive modules *)
let start_module l senv =
- check_label l senv.labset;
+ check_label l senv;
let mp = MPdot(senv.modinfo.modpath, l) in
let modinfo = { modpath = mp;
label = l;
@@ -327,7 +333,7 @@ let start_module l senv =
modinfo = modinfo;
labset = Labset.empty;
revstruct = [];
- univ = Univ.Constraint.empty;
+ univ = Univ.empty_constraint;
engagement = None;
imports = senv.imports;
loads = [];
@@ -347,7 +353,7 @@ let end_module l restype senv =
| STRUCT params -> params, (List.length params > 0)
in
if l <> modinfo.label then error_incompatible_labels l modinfo.label;
- if not (empty_context senv.env) then error_local_context None;
+ if not (empty_context senv.env) then error_non_empty_local_context None;
let functorize_struct tb =
List.fold_left
(fun mtb (arg_id,arg_b) ->
@@ -361,13 +367,13 @@ let end_module l restype senv =
let mexpr,mod_typ,mod_typ_alg,resolver,cst =
match restype with
| None -> let mexpr = functorize_struct auto_tb in
- mexpr,mexpr,None,modinfo.resolver,Constraint.empty
+ mexpr,mexpr,None,modinfo.resolver,empty_constraint
| Some mtb ->
let auto_mtb = {
typ_mp = senv.modinfo.modpath;
typ_expr = auto_tb;
typ_expr_alg = None;
- typ_constraints = Constraint.empty;
+ typ_constraints = empty_constraint;
typ_delta = empty_delta_resolver} in
let cst = check_subtypes senv.env auto_mtb
mtb in
@@ -377,7 +383,7 @@ let end_module l restype senv =
Option.map functorize_struct mtb.typ_expr_alg in
mexpr,mod_typ,typ_alg,mtb.typ_delta,cst
in
- let cst = Constraint.union cst senv.univ in
+ let cst = union_constraints cst senv.univ in
let mb =
{ mod_mp = mp;
mod_expr = Some mexpr;
@@ -411,12 +417,12 @@ let end_module l restype senv =
modinfo = modinfo;
labset = Labset.add l oldsenv.labset;
revstruct = (l,SFBmodule mb)::oldsenv.revstruct;
- univ = Univ.Constraint.union senv'.univ oldsenv.univ;
+ univ = Univ.union_constraints senv'.univ oldsenv.univ;
(* engagement is propagated to the upper level *)
engagement = senv'.engagement;
imports = senv'.imports;
loads = senv'.loads@oldsenv.loads;
- local_retroknowledge =
+ local_retroknowledge =
senv'.local_retroknowledge@oldsenv.local_retroknowledge }
@@ -424,8 +430,8 @@ let end_module l restype senv =
let add_include me is_module inl senv =
let sign,cst,resolver =
if is_module then
- let sign,resolver,cst =
- translate_struct_include_module_entry senv.env
+ let sign,_,resolver,cst =
+ translate_struct_include_module_entry senv.env
senv.modinfo.modpath inl me in
sign,cst,resolver
else
@@ -437,106 +443,46 @@ let end_module l restype senv =
let senv = add_constraints cst senv in
let mp_sup = senv.modinfo.modpath in
(* Include Self support *)
- let rec compute_sign sign mb resolver senv =
+ let rec compute_sign sign mb resolver senv =
match sign with
| SEBfunctor(mbid,mtb,str) ->
let cst_sub = check_subtypes senv.env mb mtb in
let senv = add_constraints cst_sub senv in
- let mpsup_delta = if not inl then mb.typ_delta else
- complete_inline_delta_resolver senv.env mp_sup mbid mtb mb.typ_delta
+ let mpsup_delta =
+ inline_delta_resolver senv.env inl mp_sup mbid mtb mb.typ_delta
in
let subst = map_mbid mbid mp_sup mpsup_delta in
let resolver = subst_codom_delta_resolver subst resolver in
(compute_sign
- (subst_struct_expr subst str) mb resolver senv)
+ (subst_struct_expr subst str) mb resolver senv)
| str -> resolver,str,senv
- in
+ in
let resolver,sign,senv = compute_sign sign {typ_mp = mp_sup;
typ_expr = SEBstruct (List.rev senv.revstruct);
typ_expr_alg = None;
- typ_constraints = Constraint.empty;
- typ_delta = senv.modinfo.resolver} resolver senv in
+ typ_constraints = empty_constraint;
+ typ_delta = senv.modinfo.resolver} resolver senv
+ in
let str = match sign with
| SEBstruct(str_l) -> str_l
| _ -> error ("You cannot Include a high-order structure.")
in
- let senv =
- {senv
- with modinfo =
- {senv.modinfo
- with resolver =
- add_delta_resolver resolver senv.modinfo.resolver}}
+ let senv = update_resolver (add_delta_resolver resolver) senv
in
- let add senv (l,elem) =
- check_label l senv.labset;
- match elem with
- | SFBconst cb ->
+ let add senv ((l,elem) as field) =
+ let new_name = match elem with
+ | SFBconst _ ->
let kn = make_kn mp_sup empty_dirpath l in
- let con = constant_of_kn_equiv kn
- (canonical_con
- (constant_of_delta resolver (constant_of_kn kn)))
- in
- let senv' = add_constraints cb.const_constraints senv in
- let env'' = Environ.add_constant con cb senv'.env in
- { old = senv'.old;
- env = env'';
- modinfo = senv'.modinfo;
- labset = Labset.add l senv'.labset;
- revstruct = (l,SFBconst cb)::senv'.revstruct;
- univ = senv'.univ;
- engagement = senv'.engagement;
- imports = senv'.imports;
- loads = senv'.loads ;
- local_retroknowledge = senv'.local_retroknowledge }
- | SFBmind mib ->
+ C (constant_of_delta_kn resolver kn)
+ | SFBmind _ ->
let kn = make_kn mp_sup empty_dirpath l in
- let mind = mind_of_kn_equiv kn
- (canonical_mind
- (mind_of_delta resolver (mind_of_kn kn)))
- in
- let labels = labels_of_mib mib in
- check_labels labels senv.labset;
- let senv' = add_constraints mib.mind_constraints senv in
- let env'' = Environ.add_mind mind mib senv'.env in
- { old = senv'.old;
- env = env'';
- modinfo = senv'.modinfo;
- labset = Labset.union labels senv'.labset;
- revstruct = (l,SFBmind mib)::senv'.revstruct;
- univ = senv'.univ;
- engagement = senv'.engagement;
- imports = senv'.imports;
- loads = senv'.loads;
- local_retroknowledge = senv'.local_retroknowledge }
-
- | SFBmodule mb ->
- let senv' = full_add_module mb senv in
- { old = senv'.old;
- env = senv'.env;
- modinfo = senv'.modinfo;
- labset = Labset.add l senv'.labset;
- revstruct = (l,SFBmodule mb)::senv'.revstruct;
- univ = senv'.univ;
- engagement = senv'.engagement;
- imports = senv'.imports;
- loads = senv'.loads;
- local_retroknowledge = senv'.local_retroknowledge }
- | SFBmodtype mtb ->
- let senv' = add_constraints mtb.typ_constraints senv in
- let mp = MPdot(senv.modinfo.modpath, l) in
- let env' = Environ.add_modtype mp mtb senv'.env in
- { old = senv.old;
- env = env';
- modinfo = senv'.modinfo;
- labset = Labset.add l senv.labset;
- revstruct = (l,SFBmodtype mtb)::senv'.revstruct;
- univ = senv'.univ;
- engagement = senv'.engagement;
- imports = senv'.imports;
- loads = senv'.loads;
- local_retroknowledge = senv'.local_retroknowledge }
+ I (mind_of_delta_kn resolver kn)
+ | SFBmodule _ -> M
+ | SFBmodtype _ -> MT (MPdot(senv.modinfo.modpath, l))
+ in
+ add_field field new_name senv
in
- resolver,(List.fold_left add senv str)
+ resolver,(List.fold_left add senv str)
(* Adding parameters to modules or module types *)
@@ -576,7 +522,7 @@ let add_module_parameter mbid mte inl senv =
(* Interactive module types *)
let start_modtype l senv =
- check_label l senv.labset;
+ check_label l senv;
let mp = MPdot(senv.modinfo.modpath, l) in
let modinfo = { modpath = mp;
label = l;
@@ -589,7 +535,7 @@ let start_modtype l senv =
modinfo = modinfo;
labset = Labset.empty;
revstruct = [];
- univ = Univ.Constraint.empty;
+ univ = Univ.empty_constraint;
engagement = None;
imports = senv.imports;
loads = [] ;
@@ -605,7 +551,7 @@ let end_modtype l senv =
| SIG params -> params
in
if l <> modinfo.label then error_incompatible_labels l modinfo.label;
- if not (empty_context senv.env) then error_local_context None;
+ if not (empty_context senv.env) then error_non_empty_local_context None;
let auto_tb =
SEBstruct (List.rev senv.revstruct)
in
@@ -640,7 +586,7 @@ let end_modtype l senv =
modinfo = oldsenv.modinfo;
labset = Labset.add l oldsenv.labset;
revstruct = (l,SFBmodtype mtb)::oldsenv.revstruct;
- univ = Univ.Constraint.union senv.univ oldsenv.univ;
+ univ = Univ.union_constraints senv.univ oldsenv.univ;
engagement = senv.engagement;
imports = senv.imports;
loads = senv.loads@oldsenv.loads;
@@ -699,7 +645,7 @@ let start_library dir senv =
modinfo = modinfo;
labset = Labset.empty;
revstruct = [];
- univ = Univ.Constraint.empty;
+ univ = Univ.empty_constraint;
engagement = None;
imports = senv.imports;
loads = [];
@@ -710,7 +656,7 @@ let pack_module senv =
mod_expr=None;
mod_type= SEBstruct (List.rev senv.revstruct);
mod_type_alg=None;
- mod_constraints=Constraint.empty;
+ mod_constraints=empty_constraint;
mod_delta=senv.modinfo.resolver;
mod_retroknowledge=[];
}
@@ -786,40 +732,146 @@ let import (dp,mb,depends,engmt) digest senv =
loads = (mp,mb)::senv.loads }
-(* Remove the body of opaque constants in modules *)
- let rec lighten_module mb =
- { mb with
- mod_expr = None;
- mod_type = lighten_modexpr mb.mod_type;
- }
-
-and lighten_struct struc =
- let lighten_body (l,body) = (l,match body with
- | SFBconst ({const_opaque=true} as x) -> SFBconst {x with const_body=None}
- | (SFBconst _ | SFBmind _ ) as x -> x
- | SFBmodule m -> SFBmodule (lighten_module m)
- | SFBmodtype m -> SFBmodtype
- ({m with
- typ_expr = lighten_modexpr m.typ_expr}))
- in
- List.map lighten_body struc
-
-and lighten_modexpr = function
- | SEBfunctor (mbid,mty,mexpr) ->
- SEBfunctor (mbid,
+ (* Store the body of modules' opaque constants inside a table.
+
+ This module is used during the serialization and deserialization
+ of vo files.
+
+ By adding an indirection to the opaque constant definitions, we
+ gain the ability not to load them. As these constant definitions
+ are usually big terms, we save a deserialization time as well as
+ some memory space. *)
+module LightenLibrary : sig
+ type table
+ type lightened_compiled_library
+ val save : compiled_library -> lightened_compiled_library * table
+ val load : load_proof:Flags.load_proofs -> table Lazy.t
+ -> lightened_compiled_library -> compiled_library
+end = struct
+
+ (* The table is implemented as an array of [constr_substituted].
+ Keys are hence integers. To avoid changing the [compiled_library]
+ type, we brutally encode integers into [lazy_constr]. This isn't
+ pretty, but shouldn't be dangerous since the produced structure
+ [lightened_compiled_library] is abstract and only meant for writing
+ to .vo via Marshal (which doesn't care about types).
+ *)
+ type table = constr_substituted array
+ let key_as_lazy_constr (i:int) = (Obj.magic i : lazy_constr)
+ let key_of_lazy_constr (c:lazy_constr) = (Obj.magic c : int)
+
+ (* To avoid any future misuse of the lightened library that could
+ interpret encoded keys as real [constr_substituted], we hide
+ these kind of values behind an abstract datatype. *)
+ type lightened_compiled_library = compiled_library
+
+ (* Map a [compiled_library] to another one by just updating
+ the opaque term [t] to [on_opaque_const_body t]. *)
+ let traverse_library on_opaque_const_body =
+ let rec traverse_module mb =
+ match mb.mod_expr with
+ None ->
+ { mb with
+ mod_expr = None;
+ mod_type = traverse_modexpr mb.mod_type;
+ }
+ | Some impl when impl == mb.mod_type->
+ let mtb = traverse_modexpr mb.mod_type in
+ { mb with
+ mod_expr = Some mtb;
+ mod_type = mtb;
+ }
+ | Some impl ->
+ { mb with
+ mod_expr = Option.map traverse_modexpr mb.mod_expr;
+ mod_type = traverse_modexpr mb.mod_type;
+ }
+ and traverse_struct struc =
+ let traverse_body (l,body) = (l,match body with
+ | SFBconst cb when is_opaque cb ->
+ SFBconst {cb with const_body = on_opaque_const_body cb.const_body}
+ | (SFBconst _ | SFBmind _ ) as x ->
+ x
+ | SFBmodule m ->
+ SFBmodule (traverse_module m)
+ | SFBmodtype m ->
+ SFBmodtype ({m with typ_expr = traverse_modexpr m.typ_expr}))
+ in
+ List.map traverse_body struc
+
+ and traverse_modexpr = function
+ | SEBfunctor (mbid,mty,mexpr) ->
+ SEBfunctor (mbid,
({mty with
- typ_expr = lighten_modexpr mty.typ_expr}),
- lighten_modexpr mexpr)
- | SEBident mp as x -> x
- | SEBstruct (struc) ->
- SEBstruct (lighten_struct struc)
- | SEBapply (mexpr,marg,u) ->
- SEBapply (lighten_modexpr mexpr,lighten_modexpr marg,u)
- | SEBwith (seb,wdcl) ->
- SEBwith (lighten_modexpr seb,wdcl)
-
-let lighten_library (dp,mb,depends,s) = (dp,lighten_module mb,depends,s)
-
+ typ_expr = traverse_modexpr mty.typ_expr}),
+ traverse_modexpr mexpr)
+ | SEBident mp as x -> x
+ | SEBstruct (struc) ->
+ SEBstruct (traverse_struct struc)
+ | SEBapply (mexpr,marg,u) ->
+ SEBapply (traverse_modexpr mexpr,traverse_modexpr marg,u)
+ | SEBwith (seb,wdcl) ->
+ SEBwith (traverse_modexpr seb,wdcl)
+ in
+ fun (dp,mb,depends,s) -> (dp,traverse_module mb,depends,s)
+
+ (* To disburden a library from opaque definitions, we simply
+ traverse it and add an indirection between the module body
+ and its reference to a [const_body]. *)
+ let save library =
+ let ((insert : constant_def -> constant_def),
+ (get_table : unit -> table)) =
+ (* We use an integer as a key inside the table. *)
+ let counter = ref (-1) in
+
+ (* During the traversal, the table is implemented by a list
+ to get constant time insertion. *)
+ let opaque_definitions = ref [] in
+
+ ((* Insert inside the table. *)
+ (fun def ->
+ let opaque_definition = match def with
+ | OpaqueDef lc -> force_lazy_constr lc
+ | _ -> assert false
+ in
+ incr counter;
+ opaque_definitions := opaque_definition :: !opaque_definitions;
+ OpaqueDef (key_as_lazy_constr !counter)),
+
+ (* Get the final table representation. *)
+ (fun () -> Array.of_list (List.rev !opaque_definitions)))
+ in
+ let lightened_library = traverse_library insert library in
+ (lightened_library, get_table ())
+
+ (* Loading is also a traversing that decodes the embedded keys that
+ are inside the [lightened_library]. If the [load_proof] flag is
+ set, we lookup inside the table to graft the
+ [constr_substituted]. Otherwise, we set the [const_body] field
+ to [None].
+ *)
+ let load ~load_proof (table : table Lazy.t) lightened_library =
+ let decode_key = function
+ | Undef _ | Def _ -> assert false
+ | OpaqueDef k ->
+ let k = key_of_lazy_constr k in
+ let access key =
+ try (Lazy.force table).(key)
+ with _ -> error "Error while retrieving an opaque body"
+ in
+ match load_proof with
+ | Flags.Force ->
+ let lc = Lazy.lazy_from_val (access k) in
+ OpaqueDef (make_lazy_constr lc)
+ | Flags.Lazy ->
+ let lc = lazy (access k) in
+ OpaqueDef (make_lazy_constr lc)
+ | Flags.Dont ->
+ Undef None
+ in
+ traverse_library decode_key lightened_library
+
+end
type judgment = unsafe_judgment
diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli
index 33a6a775..6f46a45b 100644
--- a/kernel/safe_typing.mli
+++ b/kernel/safe_typing.mli
@@ -1,22 +1,20 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: safe_typing.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
open Names
open Term
open Declarations
open Entries
open Mod_subst
-(*i*)
-(*s Safe environments. Since we are now able to type terms, we can
+(** {6 Safe environments } *)
+
+(** Since we are now able to type terms, we can
define an abstract type of safe environments, where objects are
typed before being added.
@@ -31,7 +29,7 @@ val env_of_safe_env : safe_environment -> Environ.env
val empty_environment : safe_environment
val is_empty : safe_environment -> bool
-(* Adding and removing local declarations (Local or Variables) *)
+(** Adding and removing local declarations (Local or Variables) *)
val push_named_assum :
identifier * types -> safe_environment ->
Univ.constraints * safe_environment
@@ -39,7 +37,7 @@ val push_named_def :
identifier * constr * types option -> safe_environment ->
Univ.constraints * safe_environment
-(* Adding global axioms or definitions *)
+(** Adding global axioms or definitions *)
type global_declaration =
| ConstantEntry of constant_entry
| GlobalRecipe of Cooking.recipe
@@ -48,39 +46,40 @@ val add_constant :
dir_path -> label -> global_declaration -> safe_environment ->
constant * safe_environment
-(* Adding an inductive type *)
+(** Adding an inductive type *)
val add_mind :
dir_path -> label -> mutual_inductive_entry -> safe_environment ->
mutual_inductive * safe_environment
-(* Adding a module *)
+(** Adding a module *)
val add_module :
- label -> module_entry -> bool -> safe_environment
+ label -> module_entry -> inline -> safe_environment
-> module_path * delta_resolver * safe_environment
-(* Adding a module type *)
+(** Adding a module type *)
val add_modtype :
- label -> module_struct_entry -> bool -> safe_environment
+ label -> module_struct_entry -> inline -> safe_environment
-> module_path * safe_environment
-(* Adding universe constraints *)
+(** Adding universe constraints *)
val add_constraints :
Univ.constraints -> safe_environment -> safe_environment
-(* Settin the strongly constructive or classical logical engagement *)
+(** Settin the strongly constructive or classical logical engagement *)
val set_engagement : engagement -> safe_environment -> safe_environment
-(*s Interactive module functions *)
+(** {6 Interactive module functions } *)
+
val start_module :
label -> safe_environment -> module_path * safe_environment
val end_module :
- label -> (module_struct_entry * bool) option
+ label -> (module_struct_entry * inline) option
-> safe_environment -> module_path * delta_resolver * safe_environment
val add_module_parameter :
- mod_bound_id -> module_struct_entry -> bool -> safe_environment -> delta_resolver * safe_environment
+ mod_bound_id -> module_struct_entry -> inline -> safe_environment -> delta_resolver * safe_environment
val start_modtype :
label -> safe_environment -> module_path * safe_environment
@@ -89,16 +88,17 @@ val end_modtype :
label -> safe_environment -> module_path * safe_environment
val add_include :
- module_struct_entry -> bool -> bool -> safe_environment ->
+ module_struct_entry -> bool -> inline -> safe_environment ->
delta_resolver * safe_environment
val pack_module : safe_environment -> module_body
val current_modpath : safe_environment -> module_path
val delta_of_senv : safe_environment -> delta_resolver*delta_resolver
-(* Loading and saving compilation units *)
-(* exporting and importing modules *)
+(** Loading and saving compilation units *)
+
+(** exporting and importing modules *)
type compiled_library
val start_library : dir_path -> safe_environment
@@ -110,18 +110,25 @@ val export : safe_environment -> dir_path
val import : compiled_library -> Digest.t -> safe_environment
-> module_path * safe_environment
-(* Remove the body of opaque constants *)
+(** Remove the body of opaque constants *)
-val lighten_library : compiled_library -> compiled_library
+module LightenLibrary :
+sig
+ type table
+ type lightened_compiled_library
+ val save : compiled_library -> lightened_compiled_library * table
+ val load : load_proof:Flags.load_proofs -> table Lazy.t ->
+ lightened_compiled_library -> compiled_library
+end
-(*s Typing judgments *)
+(** {6 Typing judgments } *)
type judgment
val j_val : judgment -> constr
val j_type : judgment -> constr
-(* Safe typing of a term returning a typing judgment and universe
+(** Safe typing of a term returning a typing judgment and universe
constraints to be added to the environment for the judgment to
hold. It is guaranteed that the constraints are satisfiable
*)
@@ -129,7 +136,9 @@ val safe_infer : safe_environment -> constr -> judgment * Univ.constraints
val typing : safe_environment -> constr -> judgment
+(** {7 Query } *)
+val exists_label : label -> safe_environment -> bool
(*spiwack: safe retroknowledge functionalities *)
diff --git a/kernel/sign.ml b/kernel/sign.ml
index d241f677..71169563 100644
--- a/kernel/sign.ml
+++ b/kernel/sign.ml
@@ -1,12 +1,19 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: sign.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
+(* Created by Jean-Christophe Filliâtre out of names.ml as part of the
+ rebuilding of Coq around a purely functional abstract type-checker,
+ Aug 1999 *)
+(* Miscellaneous extensions, restructurations and bug-fixes by Hugo
+ Herbelin and Bruno Barras *)
+
+(* This file defines types and combinators regarding indexes-based and
+ names-based contexts *)
open Names
open Util
@@ -27,6 +34,7 @@ let rec lookup_named id = function
| [] -> raise Not_found
let named_context_length = List.length
+let named_context_equal = list_equal eq_named_declaration
let vars_of_named_context = List.map (fun (id,_,_) -> id)
diff --git a/kernel/sign.mli b/kernel/sign.mli
index 35e49003..074139c9 100644
--- a/kernel/sign.mli
+++ b/kernel/sign.mli
@@ -1,19 +1,15 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: sign.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
open Names
open Term
-(*i*)
-(*s Signatures of ordered named declarations *)
+(** {6 Signatures of ordered named declarations } *)
type named_context = named_declaration list
type section_context = named_context
@@ -24,39 +20,45 @@ val vars_of_named_context : named_context -> identifier list
val lookup_named : identifier -> named_context -> named_declaration
-(* number of declarations *)
+(** number of declarations *)
val named_context_length : named_context -> int
-(*s Recurrence on [named_context]: older declarations processed first *)
+(** named context equality *)
+val named_context_equal : named_context -> named_context -> bool
+
+(** {6 Recurrence on [named_context]: older declarations processed first } *)
val fold_named_context :
(named_declaration -> 'a -> 'a) -> named_context -> init:'a -> 'a
-(* newer declarations first *)
+
+(** newer declarations first *)
val fold_named_context_reverse :
('a -> named_declaration -> 'a) -> init:'a -> named_context -> 'a
-(*s Section-related auxiliary functions *)
+(** {6 Section-related auxiliary functions } *)
val instance_from_named_context : named_context -> constr array
-(*s Signatures of ordered optionally named variables, intended to be
+(** {6 ... } *)
+(** Signatures of ordered optionally named variables, intended to be
accessed by de Bruijn indices *)
val push_named_to_rel_context : named_context -> rel_context -> rel_context
-(*s Recurrence on [rel_context]: older declarations processed first *)
+(** {6 Recurrence on [rel_context]: older declarations processed first } *)
val fold_rel_context :
(rel_declaration -> 'a -> 'a) -> rel_context -> init:'a -> 'a
-(* newer declarations first *)
+
+(** newer declarations first *)
val fold_rel_context_reverse :
('a -> rel_declaration -> 'a) -> init:'a -> rel_context -> 'a
-(*s Map function of [rel_context] *)
+(** {6 Map function of [rel_context] } *)
val map_rel_context : (constr -> constr) -> rel_context -> rel_context
-(*s Map function of [named_context] *)
+(** {6 Map function of [named_context] } *)
val map_named_context : (constr -> constr) -> named_context -> named_context
-(*s Map function of [rel_context] *)
+(** {6 Map function of [rel_context] } *)
val iter_rel_context : (constr -> unit) -> rel_context -> unit
-(*s Map function of [named_context] *)
+(** {6 Map function of [named_context] } *)
val iter_named_context : (constr -> unit) -> named_context -> unit
diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml
index 447e062a..c141a02a 100644
--- a/kernel/subtyping.ml
+++ b/kernel/subtyping.ml
@@ -1,12 +1,15 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: subtyping.ml 14641 2011-11-06 11:59:10Z herbelin $ i*)
+(* Created by Jacek Chrzaszcz, Aug 2002 as part of the implementation of
+ the Coq module system *)
+
+(* This module checks subtyping of module types *)
(*i*)
open Util
@@ -22,8 +25,6 @@ open Mod_subst
open Entries
(*i*)
-
-
(* This local type is used to subtype a constant with a constructor or
an inductive type. It can also be useful to allow reorderings in
inductive types *)
@@ -66,26 +67,26 @@ let make_label_map mp list =
in
List.fold_right add_one list Labmap.empty
-let check_conv_error error cst f env a1 a2 =
+let check_conv_error error why cst f env a1 a2 =
try
- Constraint.union cst (f env a1 a2)
+ union_constraints cst (f env a1 a2)
with
- NotConvertible -> error ()
+ NotConvertible -> error why
(* for now we do not allow reorderings *)
let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2=
let kn1 = make_mind mp1 empty_dirpath l in
let kn2 = make_mind mp2 empty_dirpath l in
- let error () = error_not_match l spec2 in
- let check_conv cst f = check_conv_error error cst f in
+ let error why = error_signature_mismatch l spec2 why in
+ let check_conv why cst f = check_conv_error error why cst f in
let mib1 =
match info1 with
| IndType ((_,0), mib) -> subst_mind subst1 mib
- | _ -> error ()
+ | _ -> error (InductiveFieldExpected mib2)
in
let mib2 = subst_mind subst2 mib2 in
- let check_inductive_type cst env t1 t2 =
+ let check_inductive_type cst name env t1 t2 =
(* Due to sort-polymorphism in inductive types, the conclusions of
t1 and t2, if in Type, are generated as the least upper bounds
@@ -114,40 +115,43 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2
let s1,s2 =
match s1, s2 with
| Type _, Type _ -> (* shortcut here *) prop_sort, prop_sort
- | (Prop _, Type _) | (Type _,Prop _) -> error ()
+ | (Prop _, Type _) | (Type _,Prop _) ->
+ error (NotConvertibleInductiveField name)
| _ -> (s1, s2) in
- check_conv cst conv_leq env (mkArity (ctx1,s1)) (mkArity (ctx2,s2))
+ check_conv (NotConvertibleInductiveField name)
+ cst conv_leq env (mkArity (ctx1,s1)) (mkArity (ctx2,s2))
in
let check_packet cst p1 p2 =
- let check f = if f p1 <> f p2 then error () in
- check (fun p -> p.mind_consnames);
- check (fun p -> p.mind_typename);
+ let check f why = if f p1 <> f p2 then error why in
+ check (fun p -> p.mind_consnames) NotSameConstructorNamesField;
+ check (fun p -> p.mind_typename) NotSameInductiveNameInBlockField;
(* nf_lc later *)
(* nf_arity later *)
(* user_lc ignored *)
(* user_arity ignored *)
- check (fun p -> p.mind_nrealargs);
+ check (fun p -> p.mind_nrealargs) (NotConvertibleInductiveField p2.mind_typename); (* How can it fail since the type of inductive are checked below? [HH] *)
(* kelim ignored *)
(* listrec ignored *)
(* finite done *)
(* nparams done *)
(* params_ctxt done because part of the inductive types *)
(* Don't check the sort of the type if polymorphic *)
- let cst = check_inductive_type cst env (type_of_inductive env (mib1,p1)) (type_of_inductive env (mib2,p2))
+ let cst = check_inductive_type cst p2.mind_typename env (type_of_inductive env (mib1,p1)) (type_of_inductive env (mib2,p2))
in
cst
in
let check_cons_types i cst p1 p2 =
- array_fold_left2
- (fun cst t1 t2 -> check_conv cst conv env t1 t2)
+ array_fold_left3
+ (fun cst id t1 t2 -> check_conv (NotConvertibleConstructorField id) cst conv env t1 t2)
cst
+ p2.mind_consnames
(arities_of_specif kn1 (mib1,p1))
(arities_of_specif kn1 (mib2,p2))
in
- let check f = if f mib1 <> f mib2 then error () in
- check (fun mib -> mib.mind_finite);
- check (fun mib -> mib.mind_ntypes);
+ let check f why = if f mib1 <> f mib2 then error (why (f mib2)) in
+ check (fun mib -> mib.mind_finite) (fun x -> FiniteInductiveFieldExpected x);
+ check (fun mib -> mib.mind_ntypes) (fun x -> InductiveNumbersFieldExpected x);
assert (mib1.mind_hyps=[] && mib2.mind_hyps=[]);
assert (Array.length mib1.mind_packets >= 1
&& Array.length mib2.mind_packets >= 1);
@@ -157,17 +161,17 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2
(* at the time of checking the inductive arities in check_packet. *)
(* Notice that we don't expect the local definitions to match: only *)
(* the inductive types and constructors types have to be convertible *)
- check (fun mib -> mib.mind_nparams);
+ check (fun mib -> mib.mind_nparams) (fun x -> InductiveParamsNumberField x);
- begin
+ begin
match mind_of_delta reso2 kn2 with
| kn2' when kn2=kn2' -> ()
| kn2' ->
if not (eq_mind (mind_of_delta reso1 kn1) (subst_ind subst2 kn2')) then
- error ()
+ error NotEqualInductiveAliases
end;
(* we check that records and their field names are preserved. *)
- check (fun mib -> mib.mind_record);
+ check (fun mib -> mib.mind_record) (fun x -> RecordFieldExpected x);
if mib1.mind_record then begin
let rec names_prod_letin t = match kind_of_term t with
| Prod(n,_,t) -> n::(names_prod_letin t)
@@ -179,7 +183,11 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2
assert (Array.length mib2.mind_packets = 1);
assert (Array.length mib1.mind_packets.(0).mind_user_lc = 1);
assert (Array.length mib2.mind_packets.(0).mind_user_lc = 1);
- check (fun mib -> names_prod_letin mib.mind_packets.(0).mind_user_lc.(0));
+ check (fun mib ->
+ let nparamdecls = List.length mib.mind_params_ctxt in
+ let names = names_prod_letin (mib.mind_packets.(0).mind_user_lc.(0)) in
+ snd (list_chop nparamdecls names))
+ (fun x -> RecordProjectionsExpected x);
end;
(* we first check simple things *)
let cst =
@@ -193,7 +201,7 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2
let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 =
- let error () = error_not_match l spec2 in
+ let error why = error_signature_mismatch l spec2 why in
let check_conv cst f = check_conv_error error cst f in
let check_type cst env t1 t2 =
@@ -233,66 +241,42 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 =
constraints of the form "univ <= max(...)" are not
expressible in the system of algebraic universes: we fail
(the user has to use an explicit type in the interface *)
- error ()
- with UserError _ (* "not an arity" *) ->
- error () end
- | _ -> t1,t2
+ error NoTypeConstraintExpected
+ with NotArity ->
+ error NotConvertibleTypeField end
+ | _ ->
+ t1,t2
else
(t1,t2) in
- check_conv cst conv_leq env t1 t2
+ check_conv NotConvertibleTypeField cst conv_leq env t1 t2
in
match info1 with
| Constant cb1 ->
- assert (cb1.const_hyps=[] && cb2.const_hyps=[]) ;
- (*Start by checking types*)
- let cb1 = subst_const_body subst1 cb1 in
- let cb2 = subst_const_body subst2 cb2 in
+ assert (cb1.const_hyps=[] && cb2.const_hyps=[]) ;
+ let cb1 = subst_const_body subst1 cb1 in
+ let cb2 = subst_const_body subst2 cb2 in
+ (* Start by checking types*)
let typ1 = Typeops.type_of_constant_type env cb1.const_type in
let typ2 = Typeops.type_of_constant_type env cb2.const_type in
let cst = check_type cst env typ1 typ2 in
- let con = make_con mp1 empty_dirpath l in
- let cst =
- if cb2.const_opaque then
- (* In this case we compare opaque definitions, we need to bypass
- the opacity and do a delta step*)
- match cb2.const_body with
- | None -> cst
- | Some lc2 ->
- let c2 = Declarations.force lc2 in
- let c1 = match cb1.const_body with
- | Some lc1 ->
- let c = Declarations.force lc1 in
- begin
- match (kind_of_term c),(kind_of_term c2) with
- Const n1,Const n2 when (eq_constant n1 n2) -> c
- (* c1 may have been strenghtened
- we need to unfold it*)
- | Const n,_ ->
- let cb = subst_const_body subst1
- (lookup_constant n env) in
- (match cb.const_opaque,
- cb.const_body with
- | true, Some lc1 ->
- Declarations.force lc1
- | _,_ -> c)
- | _ ,_-> c
- end
- | None -> mkConst con
- in
- check_conv cst conv env c1 c2
- else
- match cb2.const_body with
- | None -> cst
- | Some lc2 ->
- let c2 = Declarations.force lc2 in
- let c1 = match cb1.const_body with
- | Some lc1 -> Declarations.force lc1
- | None -> mkConst con
- in
- check_conv cst conv env c1 c2
- in
- cst
+ (* Now we check the bodies:
+ - A transparent constant can only be implemented by a compatible
+ transparent constant.
+ - In the signature, an opaque is handled just as a parameter:
+ anything of the right type can implement it, even if bodies differ.
+ *)
+ (match cb2.const_body with
+ | Undef _ | OpaqueDef _ -> cst
+ | Def lc2 ->
+ (match cb1.const_body with
+ | Undef _ | OpaqueDef _ -> error NotConvertibleBodyField
+ | Def lc1 ->
+ (* NB: cb1 might have been strengthened and appear as transparent.
+ Anyway [check_conv] will handle that afterwards. *)
+ let c1 = Declarations.force lc1 in
+ let c2 = Declarations.force lc2 in
+ check_conv NotConvertibleBodyField cst conv env c1 c2))
| IndType ((kn,i),mind1) ->
ignore (Util.error (
"The kernel does not recognize yet that a parameter can be " ^
@@ -300,10 +284,10 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 =
"inductive type and give a definition to map the old name to the new " ^
"name."));
assert (mind1.mind_hyps=[] && cb2.const_hyps=[]) ;
- if cb2.const_body <> None then error () ;
+ if constant_has_body cb2 then error DefinitionFieldExpected;
let arity1 = type_of_inductive env (mind1,mind1.mind_packets.(i)) in
let typ2 = Typeops.type_of_constant_type env cb2.const_type in
- check_conv cst conv_leq env arity1 typ2
+ check_conv NotConvertibleTypeField cst conv_leq env arity1 typ2
| IndConstr (((kn,i),j) as cstr,mind1) ->
ignore (Util.error (
"The kernel does not recognize yet that a parameter can be " ^
@@ -311,15 +295,15 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 =
"constructor and give a definition to map the old name to the new " ^
"name."));
assert (mind1.mind_hyps=[] && cb2.const_hyps=[]) ;
- if cb2.const_body <> None then error () ;
+ if constant_has_body cb2 then error DefinitionFieldExpected;
let ty1 = type_of_constructor cstr (mind1,mind1.mind_packets.(i)) in
let ty2 = Typeops.type_of_constant_type env cb2.const_type in
- check_conv cst conv env ty1 ty2
- | _ -> error ()
+ check_conv NotConvertibleTypeField cst conv env ty1 ty2
+ | _ -> error DefinitionFieldExpected
let rec check_modules cst env msb1 msb2 subst1 subst2 =
- let mty1 = module_type_of_module env None msb1 in
- let mty2 = module_type_of_module env None msb2 in
+ let mty1 = module_type_of_module None msb1 in
+ let mty2 = module_type_of_module None msb2 in
let cst = check_modtypes cst env mty1 mty2 subst1 subst2 false in
cst
@@ -344,13 +328,13 @@ and check_signatures cst env mp1 sig1 mp2 sig2 subst1 subst2 reso1 reso2=
match info1 with
| Module msb -> check_modules cst env msb msb2
subst1 subst2
- | _ -> error_not_match l spec2
+ | _ -> error_signature_mismatch l spec2 ModuleFieldExpected
end
| SFBmodtype mtb2 ->
let mtb1 =
match info1 with
| Modtype mtb -> mtb
- | _ -> error_not_match l spec2
+ | _ -> error_signature_mismatch l spec2 ModuleTypeFieldExpected
in
let env = add_module (module_body_of_type mtb2.typ_mp mtb2)
(add_module (module_body_of_type mtb1.typ_mp mtb1) env) in
@@ -368,7 +352,7 @@ and check_modtypes cst env mtb1 mtb2 subst1 subst2 equiv =
if equiv then
let subst2 =
add_mp mtb2.typ_mp mtb1.typ_mp mtb1.typ_delta subst2 in
- Univ.Constraint.union
+ Univ.union_constraints
(check_signatures cst env
mtb1.typ_mp list1 mtb2.typ_mp list2 subst1 subst2
mtb1.typ_delta mtb2.typ_delta)
@@ -412,7 +396,7 @@ and check_modtypes cst env mtb1 mtb2 subst1 subst2 equiv =
let check_subtypes env sup super =
let env = add_module
(module_body_of_type sup.typ_mp sup) env in
- check_modtypes Constraint.empty env
- (strengthen env sup sup.typ_mp) super empty_subst
+ check_modtypes empty_constraint env
+ (strengthen sup sup.typ_mp) super empty_subst
(map_mp super.typ_mp sup.typ_mp sup.typ_delta) false
diff --git a/kernel/subtyping.mli b/kernel/subtyping.mli
index a32804b9..cf9cb540 100644
--- a/kernel/subtyping.mli
+++ b/kernel/subtyping.mli
@@ -1,18 +1,14 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: subtyping.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
open Univ
open Declarations
open Environ
-(*i*)
val check_subtypes : env -> module_type_body -> module_type_body -> constraints
diff --git a/kernel/term.ml b/kernel/term.ml
index 1894417c..dcb63cf7 100644
--- a/kernel/term.ml
+++ b/kernel/term.ml
@@ -1,14 +1,27 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: term.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
-(* This module instantiates the structure of generic deBruijn terms to Coq *)
+(* File initially created by Gérard Huet and Thierry Coquand in 1984 *)
+(* Extension to inductive constructions by Christine Paulin for Coq V5.6 *)
+(* Extension to mutual inductive constructions by Christine Paulin for
+ Coq V5.10.2 *)
+(* Extension to co-inductive constructions by Eduardo Gimenez *)
+(* Optimization of substitution functions by Chet Murthy *)
+(* Optimization of lifting functions by Bruno Barras, Mar 1997 *)
+(* Hash-consing by Bruno Barras in Feb 1998 *)
+(* Restructuration of Coq of the type-checking kernel by Jean-Christophe
+ Filliâtre, 1999 *)
+(* Abstraction of the syntax of terms and iterators by Hugo Herbelin, 2000 *)
+(* Cleaning and lightening of the kernel by Bruno Barras, Nov 2001 *)
+
+(* This file defines the internal syntax of the Calculus of
+ Inductive Constructions (CIC) terms together with constructors,
+ destructors, iterators and basic functions *)
open Util
open Pp
@@ -16,12 +29,14 @@ open Names
open Univ
open Esubst
-(* Coq abstract syntax with deBruijn variables; 'a is the type of sorts *)
type existential_key = int
type metavariable = int
(* This defines the strategy to use for verifiying a Cast *)
+(* Warning: REVERTcast is not exported to vo-files; as of r14492, it has to *)
+(* come after the vo-exported cast_kind so as to be compatible with coqchk *)
+type cast_kind = VMcast | DEFAULTcast | REVERTcast
(* This defines Cases annotations *)
type case_style = LetStyle | IfStyle | LetPatternStyle | MatchStyle | RegularStyle
@@ -31,7 +46,7 @@ type case_printing =
type case_info =
{ ci_ind : inductive;
ci_npar : int;
- ci_cstr_nargs : int array; (* number of real args of each constructor *)
+ ci_cstr_ndecls : int array; (* number of pattern vars of each constructor *)
ci_pp_info : case_printing (* not interpreted by the kernel *)
}
@@ -58,8 +73,6 @@ let family_of_sort = function
(* Constructions as implemented *)
(********************************************************************)
-type cast_kind = VMcast | DEFAULTcast
-
(* [constr array] is an instance matching definitional [named_context] in
the same order (i.e. last argument first) *)
type 'constr pexistential = existential_key * 'constr array
@@ -90,24 +103,6 @@ type ('constr, 'types) kind_of_term =
| Fix of ('constr, 'types) pfixpoint
| CoFix of ('constr, 'types) pcofixpoint
-(* Experimental *)
-type ('constr, 'types) kind_of_type =
- | SortType of sorts
- | CastType of 'types * 'types
- | ProdType of name * 'types * 'types
- | LetInType of name * 'constr * 'types * 'types
- | AtomicType of 'constr * 'constr array
-
-let kind_of_type = function
- | Sort s -> SortType s
- | Cast (c,_,t) -> CastType (c, t)
- | Prod (na,t,c) -> ProdType (na, t, c)
- | LetIn (na,b,t,c) -> LetInType (na, b, t, c)
- | App (c,l) -> AtomicType (c, l)
- | (Rel _ | Meta _ | Var _ | Evar _ | Const _ | Case _ | Fix _ | CoFix _ | Ind _ as c)
- -> AtomicType (c,[||])
- | (Lambda _ | Construct _) -> failwith "Not a type"
-
(* constr is the fixpoint of the previous type. Requires option
-rectypes of the Caml compiler to be set *)
type constr = (constr,constr) kind_of_term
@@ -117,82 +112,10 @@ type rec_declaration = name array * constr array * constr array
type fixpoint = (int array * int) * rec_declaration
type cofixpoint = int * rec_declaration
-(***************************)
-(* hash-consing functions *)
-(***************************)
-let comp_term t1 t2 =
- match t1, t2 with
- | Rel n1, Rel n2 -> n1 = n2
- | Meta m1, Meta m2 -> m1 == m2
- | Var id1, Var id2 -> id1 == id2
- | Sort s1, Sort s2 -> s1 == s2
- | Cast (c1,_,t1), Cast (c2,_,t2) -> c1 == c2 & t1 == t2
- | Prod (n1,t1,c1), Prod (n2,t2,c2) -> n1 == n2 & t1 == t2 & c1 == c2
- | Lambda (n1,t1,c1), Lambda (n2,t2,c2) -> n1 == n2 & t1 == t2 & c1 == c2
- | LetIn (n1,b1,t1,c1), LetIn (n2,b2,t2,c2) ->
- n1 == n2 & b1 == b2 & t1 == t2 & c1 == c2
- | App (c1,l1), App (c2,l2) -> c1 == c2 & array_for_all2 (==) l1 l2
- | Evar (e1,l1), Evar (e2,l2) -> e1 = e2 & array_for_all2 (==) l1 l2
- | Const c1, Const c2 -> c1 == c2
- | Ind (sp1,i1), Ind (sp2,i2) -> sp1 == sp2 & i1 = i2
- | Construct ((sp1,i1),j1), Construct ((sp2,i2),j2) ->
- sp1 == sp2 & i1 = i2 & j1 = j2
- | Case (ci1,p1,c1,bl1), Case (ci2,p2,c2,bl2) ->
- ci1 == ci2 & p1 == p2 & c1 == c2 & array_for_all2 (==) bl1 bl2
- | Fix (ln1,(lna1,tl1,bl1)), Fix (ln2,(lna2,tl2,bl2)) ->
- ln1 = ln2
- & array_for_all2 (==) lna1 lna2
- & array_for_all2 (==) tl1 tl2
- & array_for_all2 (==) bl1 bl2
- | CoFix(ln1,(lna1,tl1,bl1)), CoFix(ln2,(lna2,tl2,bl2)) ->
- ln1 = ln2
- & array_for_all2 (==) lna1 lna2
- & array_for_all2 (==) tl1 tl2
- & array_for_all2 (==) bl1 bl2
- | _ -> false
-
-let hash_term (sh_rec,(sh_sort,sh_con,sh_kn,sh_na,sh_id)) t =
- match t with
- | Rel _ -> t
- | Meta x -> Meta x
- | Var x -> Var (sh_id x)
- | Sort s -> Sort (sh_sort s)
- | Cast (c, k, t) -> Cast (sh_rec c, k, (sh_rec t))
- | Prod (na,t,c) -> Prod (sh_na na, sh_rec t, sh_rec c)
- | Lambda (na,t,c) -> Lambda (sh_na na, sh_rec t, sh_rec c)
- | LetIn (na,b,t,c) -> LetIn (sh_na na, sh_rec b, sh_rec t, sh_rec c)
- | App (c,l) -> App (sh_rec c, Array.map sh_rec l)
- | Evar (e,l) -> Evar (e, Array.map sh_rec l)
- | Const c -> Const (sh_con c)
- | Ind (kn,i) -> Ind (sh_kn kn,i)
- | Construct ((kn,i),j) -> Construct ((sh_kn kn,i),j)
- | Case (ci,p,c,bl) -> (* TO DO: extract ind_kn *)
- Case (ci, sh_rec p, sh_rec c, Array.map sh_rec bl)
- | Fix (ln,(lna,tl,bl)) ->
- Fix (ln,(Array.map sh_na lna,
- Array.map sh_rec tl,
- Array.map sh_rec bl))
- | CoFix(ln,(lna,tl,bl)) ->
- CoFix (ln,(Array.map sh_na lna,
- Array.map sh_rec tl,
- Array.map sh_rec bl))
-
-module Hconstr =
- Hashcons.Make(
- struct
- type t = constr
- type u = (constr -> constr) *
- ((sorts -> sorts) * (constant -> constant) *
- (mutual_inductive -> mutual_inductive) * (name -> name) *
- (identifier -> identifier))
- let hash_sub = hash_term
- let equal = comp_term
- let hash = Hashtbl.hash
- end)
-
-let hcons_term (hsorts,hcon,hkn,hname,hident) =
- Hashcons.recursive_hcons Hconstr.f (hsorts,hcon,hkn,hname,hident)
+(*********************)
+(* Term constructors *)
+(*********************)
(* Constructs a DeBrujin index with number n *)
let rels =
@@ -201,21 +124,20 @@ let rels =
let mkRel n = if 0<n & n<=16 then rels.(n-1) else Rel n
-(* Constructs an existential variable named "?n" *)
-let mkMeta n = Meta n
-
-(* Constructs a Variable named id *)
-let mkVar id = Var id
-
(* Construct a type *)
-let mkSort s = Sort s
+let mkProp = Sort prop_sort
+let mkSet = Sort set_sort
+let mkType u = Sort (Type u)
+let mkSort = function
+ | Prop Null -> mkProp (* Easy sharing *)
+ | Prop Pos -> mkSet
+ | s -> Sort s
(* Constructs the term t1::t2, i.e. the term t1 casted with the type t2 *)
-(* (that means t2 is declared as the type of t1)
- [s] is the strategy to use when *)
+(* (that means t2 is declared as the type of t1) *)
let mkCast (t1,k2,t2) =
match t1 with
- | Cast (c,k1, _) when k1 = k2 -> Cast (c,k1,t2)
+ | Cast (c,k1, _) when k1 = VMcast & k1 = k2 -> Cast (c,k1,t2)
| _ -> Cast (t1,k2,t2)
(* Constructs the product (x:t1)t2 *)
@@ -236,16 +158,13 @@ let mkApp (f, a) =
| App (g, cl) -> App (g, Array.append cl a)
| _ -> App (f, a)
-
(* Constructs a constant *)
-(* The array of terms correspond to the variables introduced in the section *)
let mkConst c = Const c
(* Constructs an existential variable *)
let mkEvar e = Evar e
(* Constructs the ith (co)inductive type of the block named kn *)
-(* The array of terms correspond to the variables introduced in the section *)
let mkInd m = Ind m
(* Constructs the jth constructor of the ith (co)inductive type of the
@@ -256,12 +175,48 @@ let mkConstruct c = Construct c
(* Constructs the term <p>Case c of c1 | c2 .. | cn end *)
let mkCase (ci, p, c, ac) = Case (ci, p, c, ac)
+(* If recindxs = [|i1,...in|]
+ funnames = [|f1,...fn|]
+ typarray = [|t1,...tn|]
+ bodies = [|b1,...bn|]
+ then
+
+ mkFix ((recindxs,i),(funnames,typarray,bodies))
+
+ constructs the ith function of the block
+
+ Fixpoint f1 [ctx1] : t1 := b1
+ with f2 [ctx2] : t2 := b2
+ ...
+ with fn [ctxn] : tn := bn.
+
+ where the lenght of the jth context is ij.
+*)
+
let mkFix fix = Fix fix
-let mkCoFix cofix = CoFix cofix
+(* If funnames = [|f1,...fn|]
+ typarray = [|t1,...tn|]
+ bodies = [|b1,...bn|]
+ then
+
+ mkCoFix (i,(funnames,typsarray,bodies))
+
+ constructs the ith function of the block
+
+ CoFixpoint f1 : t1 := b1
+ with f2 : t2 := b2
+ ...
+ with fn : tn := bn.
+*)
+let mkCoFix cofix= CoFix cofix
+
+(* Constructs an existential variable named "?n" *)
+let mkMeta n = Meta n
+
+(* Constructs a Variable named id *)
+let mkVar id = Var id
-let kind_of_term c = c
-let kind_of_term2 c = c
(************************************************************************)
(* kind_of_term = constructions as seen by the user *)
@@ -271,15 +226,25 @@ let kind_of_term2 c = c
least one argument and the function is not itself an applicative
term *)
-let kind_of_term = kind_of_term
+let kind_of_term c = c
+(* Experimental, used in Presburger contrib *)
+type ('constr, 'types) kind_of_type =
+ | SortType of sorts
+ | CastType of 'types * 'types
+ | ProdType of name * 'types * 'types
+ | LetInType of name * 'constr * 'types * 'types
+ | AtomicType of 'constr * 'constr array
-(* En vue d'un kind_of_type : constr -> hnftype ??? *)
-type hnftype =
- | HnfSort of sorts
- | HnfProd of name * constr * constr
- | HnfAtom of constr
- | HnfInd of inductive * constr array
+let kind_of_type = function
+ | Sort s -> SortType s
+ | Cast (c,_,t) -> CastType (c, t)
+ | Prod (na,t,c) -> ProdType (na, t, c)
+ | LetIn (na,b,t,c) -> LetInType (na, b, t, c)
+ | App (c,l) -> AtomicType (c, l)
+ | (Rel _ | Meta _ | Var _ | Evar _ | Const _ | Case _ | Fix _ | CoFix _ | Ind _ as c)
+ -> AtomicType (c,[||])
+ | (Lambda _ | Construct _) -> failwith "Not a type"
(**********************************************************************)
(* Non primitive term destructors *)
@@ -334,18 +299,12 @@ let rec is_Type c = match kind_of_term c with
| Cast (c,_,_) -> is_Type c
| _ -> false
-let isType = function
- | Type _ -> true
- | _ -> false
-
let is_small = function
| Prop _ -> true
| _ -> false
let iskind c = isprop c or is_Type c
-let same_kind c1 c2 = (isprop c1 & isprop c2) or (is_Type c1 & is_Type c2)
-
(* Tests if an evar *)
let isEvar c = match kind_of_term c with Evar _ -> true | _ -> false
@@ -366,6 +325,7 @@ let isRel c = match kind_of_term c with Rel _ -> true | _ -> false
(* Tests if a variable *)
let isVar c = match kind_of_term c with Var _ -> true | _ -> false
+let isVarId id c = match kind_of_term c with Var id' -> id = id' | _ -> false
(* Tests if an inductive *)
let isInd c = match kind_of_term c with Ind _ -> true | _ -> false
@@ -387,7 +347,7 @@ let isLambda c = match kind_of_term c with | Lambda _ -> true | _ -> false
(* Destructs the let [x:=b:t1]t2 *)
let destLetIn c = match kind_of_term c with
| LetIn (x,b,t1,t2) -> (x,b,t1,t2)
- | _ -> invalid_arg "destProd"
+ | _ -> invalid_arg "destLetIn"
let isLetIn c = match kind_of_term c with LetIn _ -> true | _ -> false
@@ -412,10 +372,6 @@ let destEvar c = match kind_of_term c with
| Evar (kn, a as r) -> r
| _ -> invalid_arg "destEvar"
-let num_of_evar c = match kind_of_term c with
- | Evar (n, _) -> n
- | _ -> anomaly "num_of_evar called with bad args"
-
(* Destructs a (co)inductive type named kn *)
let destInd c = match kind_of_term c with
| Ind (kn, a as r) -> r
@@ -485,18 +441,6 @@ let decompose_app c =
| App (f,cl) -> (f, Array.to_list cl)
| _ -> (c,[])
-(* strips head casts and flattens head applications *)
-let rec strip_head_cast c = match kind_of_term c with
- | App (f,cl) ->
- let rec collapse_rec f cl2 = match kind_of_term f with
- | App (g,cl1) -> collapse_rec g (Array.append cl1 cl2)
- | Cast (c,_,_) -> collapse_rec c cl2
- | _ -> if Array.length cl2 = 0 then f else mkApp (f,cl2)
- in
- collapse_rec f cl
- | Cast (c,_,_) -> strip_head_cast c
- | _ -> c
-
(****************************************************************************)
(* Functions to recur through subterms *)
(****************************************************************************)
@@ -621,15 +565,11 @@ let compare_constr f t1 t2 =
| Prod (_,t1,c1), Prod (_,t2,c2) -> f t1 t2 & f c1 c2
| Lambda (_,t1,c1), Lambda (_,t2,c2) -> f t1 t2 & f c1 c2
| LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> f b1 b2 & f t1 t2 & f c1 c2
+ | App (c1,l1), _ when isCast c1 -> f (mkApp (pi1 (destCast c1),l1)) t2
+ | _, App (c2,l2) when isCast c2 -> f t1 (mkApp (pi1 (destCast c2),l2))
| App (c1,l1), App (c2,l2) ->
- if Array.length l1 = Array.length l2 then
- f c1 c2 & array_for_all2 f l1 l2
- else
- let (h1,l1) = decompose_app t1 in
- let (h2,l2) = decompose_app t2 in
- if List.length l1 = List.length l2 then
- f h1 h2 & List.for_all2 f l1 l2
- else false
+ Array.length l1 = Array.length l2 &&
+ f c1 c2 && array_for_all2 f l1 l2
| Evar (e1,l1), Evar (e2,l2) -> e1 = e2 & array_for_all2 f l1 l2
| Const c1, Const c2 -> eq_constant c1 c2
| Ind c1, Ind c2 -> eq_ind c1 c2
@@ -642,6 +582,62 @@ let compare_constr f t1 t2 =
ln1 = ln2 & array_for_all2 f tl1 tl2 & array_for_all2 f bl1 bl2
| _ -> false
+(*******************************)
+(* alpha conversion functions *)
+(*******************************)
+
+(* alpha conversion : ignore print names and casts *)
+
+let rec eq_constr m n =
+ (m==n) or
+ compare_constr eq_constr m n
+
+let eq_constr m n = eq_constr m n (* to avoid tracing a recursive fun *)
+
+let constr_ord_int f t1 t2 =
+ let (=?) f g i1 i2 j1 j2=
+ let c=f i1 i2 in
+ if c=0 then g j1 j2 else c in
+ let (==?) fg h i1 i2 j1 j2 k1 k2=
+ let c=fg i1 i2 j1 j2 in
+ if c=0 then h k1 k2 else c in
+ match kind_of_term t1, kind_of_term t2 with
+ | Rel n1, Rel n2 -> n1 - n2
+ | Meta m1, Meta m2 -> m1 - m2
+ | Var id1, Var id2 -> id_ord id1 id2
+ | Sort s1, Sort s2 -> Pervasives.compare s1 s2
+ | Cast (c1,_,_), _ -> f c1 t2
+ | _, Cast (c2,_,_) -> f t1 c2
+ | Prod (_,t1,c1), Prod (_,t2,c2)
+ | Lambda (_,t1,c1), Lambda (_,t2,c2) ->
+ (f =? f) t1 t2 c1 c2
+ | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) ->
+ ((f =? f) ==? f) b1 b2 t1 t2 c1 c2
+ | App (c1,l1), _ when isCast c1 -> f (mkApp (pi1 (destCast c1),l1)) t2
+ | _, App (c2,l2) when isCast c2 -> f t1 (mkApp (pi1 (destCast c2),l2))
+ | App (c1,l1), App (c2,l2) -> (f =? (array_compare f)) c1 c2 l1 l2
+ | Evar (e1,l1), Evar (e2,l2) ->
+ ((-) =? (array_compare f)) e1 e2 l1 l2
+ | Const c1, Const c2 -> kn_ord (canonical_con c1) (canonical_con c2)
+ | Ind (spx, ix), Ind (spy, iy) ->
+ let c = ix - iy in if c = 0 then kn_ord (canonical_mind spx) (canonical_mind spy) else c
+ | Construct ((spx, ix), jx), Construct ((spy, iy), jy) ->
+ let c = jx - jy in if c = 0 then
+ (let c = ix - iy in if c = 0 then kn_ord (canonical_mind spx) (canonical_mind spy) else c)
+ else c
+ | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) ->
+ ((f =? f) ==? (array_compare f)) p1 p2 c1 c2 bl1 bl2
+ | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) ->
+ ((Pervasives.compare =? (array_compare f)) ==? (array_compare f))
+ ln1 ln2 tl1 tl2 bl1 bl2
+ | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) ->
+ ((Pervasives.compare =? (array_compare f)) ==? (array_compare f))
+ ln1 ln2 tl1 tl2 bl1 bl2
+ | t1, t2 -> Pervasives.compare t1 t2
+
+let rec constr_ord m n=
+ constr_ord_int constr_ord m n
+
(***************************************************************************)
(* Type of assumptions *)
(***************************************************************************)
@@ -659,6 +655,18 @@ let map_rel_declaration = map_named_declaration
let fold_named_declaration f (_, v, ty) a = f ty (Option.fold_right f v a)
let fold_rel_declaration = fold_named_declaration
+let exists_named_declaration f (_, v, ty) = Option.cata f false v || f ty
+let exists_rel_declaration f (_, v, ty) = Option.cata f false v || f ty
+
+let for_all_named_declaration f (_, v, ty) = Option.cata f true v && f ty
+let for_all_rel_declaration f (_, v, ty) = Option.cata f true v && f ty
+
+let eq_named_declaration (i1, c1, t1) (i2, c2, t2) =
+ id_ord i1 i2 = 0 && Option.Misc.compare eq_constr c1 c2 && eq_constr t1 t2
+
+let eq_rel_declaration (n1, c1, t1) (n2, c2, t2) =
+ n1 = n2 && Option.Misc.compare eq_constr c1 c2 && eq_constr t1 t2
+
(***************************************************************************)
(* Type of local contexts (telescopes) *)
(***************************************************************************)
@@ -762,12 +770,12 @@ let rec exliftn el c = match kind_of_term c with
(* Lifting the binding depth across k bindings *)
-let liftn k n =
- match el_liftn (pred n) (el_shft k ELID) with
+let liftn n k =
+ match el_liftn (pred k) (el_shft n el_id) with
| ELID -> (fun c -> c)
| el -> exliftn el
-let lift k = liftn k 1
+let lift n = liftn n 1
(*********************)
(* Substituting *)
@@ -814,12 +822,12 @@ let substnl laml n =
let substl laml = substnl laml 0
let subst1 lam = substl [lam]
-let substnl_decl laml k (id,bodyopt,typ) =
- (id,Option.map (substnl laml k) bodyopt,substnl laml k typ)
+let substnl_decl laml k = map_rel_declaration (substnl laml k)
let substl_decl laml = substnl_decl laml 0
let subst1_decl lam = substl_decl [lam]
-let subst1_named_decl = subst1_decl
+let substnl_named laml k = map_named_declaration (substnl laml k)
let substl_named_decl = substl_decl
+let subst1_named_decl = subst1_decl
(* (thin_val sigma) removes identity substitutions from sigma *)
@@ -858,44 +866,12 @@ let substn_vars p vars =
let subst_vars = substn_vars 1
-(*********************)
-(* Term constructors *)
-(*********************)
-
-(* Constructs a DeBrujin index with number n *)
-let mkRel = mkRel
-
-(* Constructs an existential variable named "?n" *)
-let mkMeta = mkMeta
-
-(* Constructs a Variable named id *)
-let mkVar = mkVar
-
-(* Construct a type *)
-let mkProp = mkSort prop_sort
-let mkSet = mkSort set_sort
-let mkType u = mkSort (Type u)
-let mkSort = function
- | Prop Null -> mkProp (* Easy sharing *)
- | Prop Pos -> mkSet
- | s -> mkSort s
-
-(* Constructs the term t1::t2, i.e. the term t1 casted with the type t2 *)
-(* (that means t2 is declared as the type of t1) *)
-let mkCast = mkCast
+(***************************)
+(* Other term constructors *)
+(***************************)
-(* Constructs the product (x:t1)t2 *)
-let mkProd = mkProd
let mkNamedProd id typ c = mkProd (Name id, typ, subst_var id c)
-let mkProd_string s t c = mkProd (Name (id_of_string s), t, c)
-
-(* Constructs the abstraction [x:t1]t2 *)
-let mkLambda = mkLambda
let mkNamedLambda id typ c = mkLambda (Name id, typ, subst_var id c)
-let mkLambda_string s t c = mkLambda (Name (id_of_string s), t, c)
-
-(* Constructs [x=c_1:t]c_2 *)
-let mkLetIn = mkLetIn
let mkNamedLetIn id c1 t c2 = mkLetIn (Name id, c1, t, subst_var id c2)
(* Constructs either [(x:t)c] or [[x=b:t]c] *)
@@ -909,17 +885,6 @@ let mkNamedProd_or_LetIn (id,body,t) c =
| None -> mkNamedProd id t c
| Some b -> mkNamedLetIn id b t c
-(* Constructs either [[x:t]c] or [[x=b:t]c] *)
-let mkLambda_or_LetIn (na,body,t) c =
- match body with
- | None -> mkLambda (na, t, c)
- | Some b -> mkLetIn (na, b, t, c)
-
-let mkNamedLambda_or_LetIn (id,body,t) c =
- match body with
- | None -> mkNamedLambda id t c
- | Some b -> mkNamedLetIn id b t c
-
(* Constructs either [(x:t)c] or [c] where [x] is replaced by [b] *)
let mkProd_wo_LetIn (na,body,t) c =
match body with
@@ -934,83 +899,16 @@ let mkNamedProd_wo_LetIn (id,body,t) c =
(* non-dependent product t1 -> t2 *)
let mkArrow t1 t2 = mkProd (Anonymous, t1, t2)
-(* If lt = [t1; ...; tn], constructs the application (t1 ... tn) *)
-(* We ensure applicative terms have at most one arguments and the
- function is not itself an applicative term *)
-let mkApp = mkApp
-
-let mkAppA v =
- let l = Array.length v in
- if l=0 then anomaly "mkAppA received an empty array"
- else mkApp (v.(0), Array.sub v 1 (Array.length v -1))
-
-(* Constructs a constant *)
-(* The array of terms correspond to the variables introduced in the section *)
-let mkConst = mkConst
-
-(* Constructs an existential variable *)
-let mkEvar = mkEvar
-
-(* Constructs the ith (co)inductive type of the block named kn *)
-(* The array of terms correspond to the variables introduced in the section *)
-let mkInd = mkInd
-
-(* Constructs the jth constructor of the ith (co)inductive type of the
- block named kn. The array of terms correspond to the variables
- introduced in the section *)
-let mkConstruct = mkConstruct
-
-(* Constructs the term <p>Case c of c1 | c2 .. | cn end *)
-let mkCase = mkCase
-let mkCaseL (ci, p, c, ac) = mkCase (ci, p, c, Array.of_list ac)
-
-(* If recindxs = [|i1,...in|]
- funnames = [|f1,...fn|]
- typarray = [|t1,...tn|]
- bodies = [|b1,...bn|]
- then
-
- mkFix ((recindxs,i),(funnames,typarray,bodies))
-
- constructs the ith function of the block
-
- Fixpoint f1 [ctx1] : t1 := b1
- with f2 [ctx2] : t2 := b2
- ...
- with fn [ctxn] : tn := bn.
-
- where the lenght of the jth context is ij.
-*)
-
-let mkFix = mkFix
-
-(* If funnames = [|f1,...fn|]
- typarray = [|t1,...tn|]
- bodies = [|b1,...bn|]
- then
-
- mkCoFix (i,(funnames,typsarray,bodies))
-
- constructs the ith function of the block
-
- CoFixpoint f1 : t1 := b1
- with f2 : t2 := b2
- ...
- with fn : tn := bn.
-*)
-let mkCoFix = mkCoFix
-
-(* Construct an implicit *)
-let implicit_sort = Type (make_univ(make_dirpath[id_of_string"implicit"],0))
-let mkImplicit = mkSort implicit_sort
-
-(***************************)
-(* Other term constructors *)
-(***************************)
+(* Constructs either [[x:t]c] or [[x=b:t]c] *)
+let mkLambda_or_LetIn (na,body,t) c =
+ match body with
+ | None -> mkLambda (na, t, c)
+ | Some b -> mkLetIn (na, b, t, c)
-let abs_implicit c = mkLambda (Anonymous, mkImplicit, c)
-let lambda_implicit a = mkLambda (Name(id_of_string"y"), mkImplicit, a)
-let lambda_implicit_lift n a = iterate lambda_implicit n (lift n a)
+let mkNamedLambda_or_LetIn (id,body,t) c =
+ match body with
+ | None -> mkNamedLambda id t c
+ | Some b -> mkNamedLetIn id b t c
(* prodn n [xn:Tn;..;x1:T1;Gamma] b = (x1:T1)..(xn:Tn)b *)
let prodn n env b =
@@ -1252,37 +1150,216 @@ let rec isArity c =
| Sort _ -> true
| _ -> false
-(*******************************)
-(* alpha conversion functions *)
-(*******************************)
-
-(* alpha conversion : ignore print names and casts *)
-
-let rec eq_constr m n =
- (m==n) or
- compare_constr eq_constr m n
-
-let eq_constr m n = eq_constr m n (* to avoid tracing a recursive fun *)
-
(*******************)
(* hash-consing *)
(*******************)
-module Htype =
- Hashcons.Make(
- struct
- type t = types
- type u = (constr -> constr) * (sorts -> sorts)
-(*
- let hash_sub (hc,hs) j = {body=hc j.body; typ=hs j.typ}
- let equal j1 j2 = j1.body==j2.body & j1.typ==j2.typ
+(* Hash-consing of [constr] does not use the module [Hashcons] because
+ [Hashcons] is not efficient on deep tree-like data
+ structures. Indeed, [Hashcons] is based the (very efficient)
+ generic hash function [Hashtbl.hash], which computes the hash key
+ through a depth bounded traversal of the data structure to be
+ hashed. As a consequence, for a deep [constr] like the natural
+ number 1000 (S (S (... (S O)))), the same hash is assigned to all
+ the sub [constr]s greater than the maximal depth handled by
+ [Hashtbl.hash]. This entails a huge number of collisions in the
+ hash table and leads to cubic hash-consing in this worst-case.
+
+ In order to compute a hash key that is independent of the data
+ structure depth while being constant-time, an incremental hashing
+ function must be devised. A standard implementation creates a cache
+ of the hashing function by decorating each node of the hash-consed
+ data structure with its hash key. In that case, the hash function
+ can deduce the hash key of a toplevel data structure by a local
+ computation based on the cache held on its substructures.
+ Unfortunately, this simple implementation introduces a space
+ overhead that is damageable for the hash-consing of small [constr]s
+ (the most common case). One can think of an heterogeneous
+ distribution of caches on smartly chosen nodes, but this is forbidden
+ by the use of generic equality in Coq source code. (Indeed, this forces
+ each [constr] to have a unique canonical representation.)
+
+ Given that hash-consing proceeds inductively, we can nonetheless
+ computes the hash key incrementally during hash-consing by changing
+ a little the signature of the hash-consing function: it now returns
+ both the hash-consed term and its hash key. This simple solution is
+ implemented in the following code: it does not introduce a space
+ overhead in [constr], that's why the efficiency is unchanged for
+ small [constr]s. Besides, it does handle deep [constr]s without
+ introducing an unreasonable number of collisions in the hash table.
+ Some benchmarks make us think that this implementation of
+ hash-consing is linear in the size of the hash-consed data
+ structure for our daily use of Coq.
*)
-(**)
- let hash_sub (hc,hs) j = hc j
- let equal j1 j2 = j1==j2
-(**)
- let hash = Hashtbl.hash
- end)
+
+let array_eqeq t1 t2 =
+ t1 == t2 ||
+ (Array.length t1 = Array.length t2 &&
+ let rec aux i =
+ (i = Array.length t1) || (t1.(i) == t2.(i) && aux (i + 1))
+ in aux 0)
+
+let equals_constr t1 t2 =
+ match t1, t2 with
+ | Rel n1, Rel n2 -> n1 == n2
+ | Meta m1, Meta m2 -> m1 == m2
+ | Var id1, Var id2 -> id1 == id2
+ | Sort s1, Sort s2 -> s1 == s2
+ | Cast (c1,k1,t1), Cast (c2,k2,t2) -> c1 == c2 & k1 == k2 & t1 == t2
+ | Prod (n1,t1,c1), Prod (n2,t2,c2) -> n1 == n2 & t1 == t2 & c1 == c2
+ | Lambda (n1,t1,c1), Lambda (n2,t2,c2) -> n1 == n2 & t1 == t2 & c1 == c2
+ | LetIn (n1,b1,t1,c1), LetIn (n2,b2,t2,c2) ->
+ n1 == n2 & b1 == b2 & t1 == t2 & c1 == c2
+ | App (c1,l1), App (c2,l2) -> c1 == c2 & array_eqeq l1 l2
+ | Evar (e1,l1), Evar (e2,l2) -> e1 = e2 & array_eqeq l1 l2
+ | Const c1, Const c2 -> c1 == c2
+ | Ind (sp1,i1), Ind (sp2,i2) -> sp1 == sp2 & i1 = i2
+ | Construct ((sp1,i1),j1), Construct ((sp2,i2),j2) ->
+ sp1 == sp2 & i1 = i2 & j1 = j2
+ | Case (ci1,p1,c1,bl1), Case (ci2,p2,c2,bl2) ->
+ ci1 == ci2 & p1 == p2 & c1 == c2 & array_eqeq bl1 bl2
+ | Fix (ln1,(lna1,tl1,bl1)), Fix (ln2,(lna2,tl2,bl2)) ->
+ ln1 = ln2
+ & array_eqeq lna1 lna2
+ & array_eqeq tl1 tl2
+ & array_eqeq bl1 bl2
+ | CoFix(ln1,(lna1,tl1,bl1)), CoFix(ln2,(lna2,tl2,bl2)) ->
+ ln1 = ln2
+ & array_eqeq lna1 lna2
+ & array_eqeq tl1 tl2
+ & array_eqeq bl1 bl2
+ | _ -> 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 *)
+
+module H = Hashtbl_alt.Make(struct type t = constr let equals = equals_constr end)
+
+open Hashtbl_alt.Combine
+
+(* [hcons_term hash_consing_functions constr] computes an hash-consed
+ representation for [constr] using [hash_consing_functions] on
+ leaves. *)
+let hcons_term (sh_sort,sh_ci,sh_construct,sh_ind,sh_con,sh_na,sh_id) =
+
+ (* Note : we hash-cons constr arrays *in place* *)
+
+ let rec hash_term_array t =
+ let accu = ref 0 in
+ for i = 0 to Array.length t - 1 do
+ let x, h = sh_rec t.(i) in
+ accu := combine !accu h;
+ t.(i) <- x
+ done;
+ !accu
+
+ and hash_term t =
+ match t with
+ | Var i ->
+ (Var (sh_id i), combinesmall 1 (Hashtbl.hash i))
+ | Sort s ->
+ (Sort (sh_sort s), combinesmall 2 (Hashtbl.hash s))
+ | Cast (c, k, t) ->
+ let c, hc = sh_rec c in
+ let t, ht = sh_rec t in
+ (Cast (c, k, t), combinesmall 3 (combine3 hc (Hashtbl.hash k) ht))
+ | Prod (na,t,c) ->
+ let t, ht = sh_rec t
+ and c, hc = sh_rec c in
+ (Prod (sh_na na, t, c), combinesmall 4 (combine3 (Hashtbl.hash na) ht hc))
+ | Lambda (na,t,c) ->
+ let t, ht = sh_rec t
+ and c, hc = sh_rec c in
+ (Lambda (sh_na na, t, c), combinesmall 5 (combine3 (Hashtbl.hash na) ht hc))
+ | LetIn (na,b,t,c) ->
+ let b, hb = sh_rec b in
+ let t, ht = sh_rec t in
+ let c, hc = sh_rec c in
+ (LetIn (sh_na na, b, t, c), combinesmall 6 (combine4 (Hashtbl.hash na) hb ht hc))
+ | App (c,l) ->
+ let c, hc = sh_rec c in
+ let hl = hash_term_array l in
+ (App (c, l), combinesmall 7 (combine hl hc))
+ | Evar (e,l) ->
+ let hl = hash_term_array l in
+ (* since the array have been hashed in place : *)
+ (t, combinesmall 8 (combine (Hashtbl.hash e) hl))
+ | Const c ->
+ (Const (sh_con c), combinesmall 9 (Hashtbl.hash c))
+ | Ind ((kn,i) as ind) ->
+ (Ind (sh_ind ind), combinesmall 9 (combine (Hashtbl.hash kn) i))
+ | Construct (((kn,i),j) as c)->
+ (Construct (sh_construct c), combinesmall 10 (combine3 (Hashtbl.hash kn) i j))
+ | Case (ci,p,c,bl) ->
+ let p, hp = sh_rec p
+ and c, hc = sh_rec c in
+ let hbl = hash_term_array bl in
+ let hbl = combine (combine hc hp) hbl in
+ (Case (sh_ci ci, p, c, bl), combinesmall 11 hbl)
+ | Fix (ln,(lna,tl,bl)) ->
+ let hbl = hash_term_array bl in
+ let htl = hash_term_array tl in
+ Array.iteri (fun i x -> lna.(i) <- sh_na x) lna;
+ (* since the three arrays have been hashed in place : *)
+ (t, combinesmall 13 (combine (Hashtbl.hash lna) (combine hbl htl)))
+ | CoFix(ln,(lna,tl,bl)) ->
+ let hbl = hash_term_array bl in
+ let htl = hash_term_array tl in
+ Array.iteri (fun i x -> lna.(i) <- sh_na x) lna;
+ (* since the three arrays have been hashed in place : *)
+ (t, combinesmall 14 (combine (Hashtbl.hash lna) (combine hbl htl)))
+ | Meta n ->
+ (t, combinesmall 15 n)
+ | Rel n ->
+ (t, combinesmall 16 n)
+
+ and sh_rec t =
+ let (y, h) = hash_term t in
+ (* [h] must be positive. *)
+ let h = h land 0x3FFFFFFF in
+ (H.may_add_and_get h y, h)
+
+ in
+ (* Make sure our statically allocated Rels (1 to 16) are considered
+ as canonical, and hence hash-consed to themselves *)
+ ignore (hash_term_array rels);
+
+ fun t -> fst (sh_rec t)
+
+(* Exported hashing fonction on constr, used mainly in plugins.
+ Appears to have slight differences from [snd (hash_term t)] above ? *)
+
+let rec hash_constr t =
+ match kind_of_term t with
+ | Var i -> combinesmall 1 (Hashtbl.hash i)
+ | Sort s -> combinesmall 2 (Hashtbl.hash s)
+ | Cast (c, _, _) -> hash_constr c
+ | Prod (_, t, c) -> combinesmall 4 (combine (hash_constr t) (hash_constr c))
+ | Lambda (_, t, c) -> combinesmall 5 (combine (hash_constr t) (hash_constr c))
+ | LetIn (_, b, t, c) ->
+ combinesmall 6 (combine3 (hash_constr b) (hash_constr t) (hash_constr c))
+ | App (c,l) when isCast c -> hash_constr (mkApp (pi1 (destCast c),l))
+ | App (c,l) ->
+ combinesmall 7 (combine (hash_term_array l) (hash_constr c))
+ | Evar (e,l) ->
+ combinesmall 8 (combine (Hashtbl.hash e) (hash_term_array l))
+ | Const c ->
+ combinesmall 9 (Hashtbl.hash c) (* TODO: proper hash function for constants *)
+ | Ind (kn,i) ->
+ combinesmall 9 (combine (Hashtbl.hash kn) i)
+ | Construct ((kn,i),j) ->
+ combinesmall 10 (combine3 (Hashtbl.hash kn) i j)
+ | Case (_ , p, c, bl) ->
+ combinesmall 11 (combine3 (hash_constr c) (hash_constr p) (hash_term_array bl))
+ | Fix (ln ,(_, tl, bl)) ->
+ combinesmall 13 (combine (hash_term_array bl) (hash_term_array tl))
+ | CoFix(ln, (_, tl, bl)) ->
+ combinesmall 14 (combine (hash_term_array bl) (hash_term_array tl))
+ | Meta n -> combinesmall 15 n
+ | Rel n -> combinesmall 16 n
+
+and hash_term_array t =
+ Array.fold_left (fun acc t -> combine (hash_constr t) acc) 0 t
module Hsorts =
Hashcons.Make(
@@ -1300,16 +1377,34 @@ module Hsorts =
let hash = Hashtbl.hash
end)
-let hsort = Hsorts.f
+module Hcaseinfo =
+ Hashcons.Make(
+ struct
+ type t = case_info
+ type u = inductive -> inductive
+ let hash_sub hind ci = { ci with ci_ind = hind ci.ci_ind }
+ let equal ci ci' =
+ ci.ci_ind == ci'.ci_ind &&
+ ci.ci_npar = ci'.ci_npar &&
+ ci.ci_cstr_ndecls = ci'.ci_cstr_ndecls && (* we use (=) on purpose *)
+ ci.ci_pp_info = ci'.ci_pp_info (* we use (=) on purpose *)
+ let hash = Hashtbl.hash
+ end)
-let hcons_constr (hcon,hkn,hdir,hname,hident,hstr) =
- let hsortscci = Hashcons.simple_hcons hsort hcons1_univ in
- let hcci = hcons_term (hsortscci,hcon,hkn,hname,hident) in
- let htcci = Hashcons.simple_hcons Htype.f (hcci,hsortscci) in
- (hcci,htcci)
+let hcons_sorts = Hashcons.simple_hcons Hsorts.f hcons_univ
+let hcons_caseinfo = Hashcons.simple_hcons Hcaseinfo.f hcons_ind
-let (hcons1_constr, hcons1_types) = hcons_constr (hcons_names())
+let hcons_constr =
+ hcons_term
+ (hcons_sorts,
+ hcons_caseinfo,
+ hcons_construct,
+ hcons_ind,
+ hcons_con,
+ hcons_name,
+ hcons_ident)
+let hcons_types = hcons_constr
(*******)
(* Type of abstract machine values *)
diff --git a/kernel/term.mli b/kernel/term.mli
index c9a97bbe..d5899f18 100644
--- a/kernel/term.mli
+++ b/kernel/term.mli
@@ -1,169 +1,176 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: term.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
open Names
-(*i*)
-(*s The sorts of CCI. *)
+(** {6 The sorts of CCI. } *)
type contents = Pos | Null
type sorts =
- | Prop of contents (* Prop and Set *)
- | Type of Univ.universe (* Type *)
+ | Prop of contents (** Prop and Set *)
+ | Type of Univ.universe (** Type *)
val set_sort : sorts
val prop_sort : sorts
val type1_sort : sorts
-(*s The sorts family of CCI. *)
+(** {6 The sorts family of CCI. } *)
type sorts_family = InProp | InSet | InType
val family_of_sort : sorts -> sorts_family
-(*s Useful types *)
+(** {6 Useful types } *)
-(*s Existential variables *)
+(** {6 Existential variables } *)
type existential_key = int
-(*s Existential variables *)
+(** {6 Existential variables } *)
type metavariable = int
-(*s Case annotation *)
-type case_style = LetStyle | IfStyle | LetPatternStyle | MatchStyle | RegularStyle
+(** {6 Case annotation } *)
+type case_style = LetStyle | IfStyle | LetPatternStyle | MatchStyle
+ | RegularStyle (** infer printing form from number of constructor *)
type case_printing =
- { ind_nargs : int; (* length of the arity of the inductive type *)
+ { ind_nargs : int; (** length of the arity of the inductive type *)
style : case_style }
-(* the integer is the number of real args, needed for reduction *)
+
+(** the integer is the number of real args, needed for reduction *)
type case_info =
{ ci_ind : inductive;
ci_npar : int;
- ci_cstr_nargs : int array; (* number of real args of each constructor *)
- ci_pp_info : case_printing (* not interpreted by the kernel *)
+ ci_cstr_ndecls : int array; (** number of real args of each constructor *)
+ ci_pp_info : case_printing (** not interpreted by the kernel *)
}
-(*s*******************************************************************)
-(* The type of constructions *)
+(** {6 The type of constructions } *)
type constr
-(* [eq_constr a b] is true if [a] equals [b] modulo alpha, casts,
+(** [eq_constr a b] is true if [a] equals [b] modulo alpha, casts,
and application grouping *)
val eq_constr : constr -> constr -> bool
-(* [types] is the same as [constr] but is intended to be used for
+(** [types] is the same as [constr] but is intended to be used for
documentation to indicate that such or such function specifically works
- with {\em types} (i.e. terms of type a sort).
+ with {e types} (i.e. terms of type a sort).
(Rem:plurial form since [type] is a reserved ML keyword) *)
type types = constr
-(*s Functions for dealing with constr terms.
+(** {5 Functions for dealing with constr terms. }
The following functions are intended to simplify and to uniform the
manipulation of terms. Some of these functions may be overlapped with
previous ones. *)
-(*s Term constructors. *)
+(** {6 Term constructors. } *)
-(* Constructs a DeBrujin index (DB indices begin at 1) *)
+(** Constructs a DeBrujin index (DB indices begin at 1) *)
val mkRel : int -> constr
-(* Constructs a Variable *)
+(** Constructs a Variable *)
val mkVar : identifier -> constr
-(* Constructs an patvar named "?n" *)
+(** Constructs an patvar named "?n" *)
val mkMeta : metavariable -> constr
-(* Constructs an existential variable *)
+(** Constructs an existential variable *)
type existential = existential_key * constr array
val mkEvar : existential -> constr
-(* Construct a sort *)
+(** Construct a sort *)
val mkSort : sorts -> types
val mkProp : types
val mkSet : types
val mkType : Univ.universe -> types
-(* This defines the strategy to use for verifiying a Cast *)
-type cast_kind = VMcast | DEFAULTcast
+(** This defines the strategy to use for verifiying a Cast *)
+type cast_kind = VMcast | DEFAULTcast | REVERTcast
-(* Constructs the term [t1::t2], i.e. the term $t_1$ casted with the
- type $t_2$ (that means t2 is declared as the type of t1). *)
+(** Constructs the term [t1::t2], i.e. the term t{_ 1} casted with the
+ type t{_ 2} (that means t2 is declared as the type of t1). *)
val mkCast : constr * cast_kind * constr -> constr
-(* Constructs the product [(x:t1)t2] *)
+(** Constructs the product [(x:t1)t2] *)
val mkProd : name * types * types -> types
val mkNamedProd : identifier -> types -> types -> types
-(* non-dependant product $t_1 \rightarrow t_2$, an alias for
- [(_:t1)t2]. Beware $t_2$ is NOT lifted.
- Eg: A |- A->A is built by [(mkArrow (mkRel 0) (mkRel 1))] *)
+
+(** non-dependent product [t1 -> t2], an alias for
+ [forall (_:t1), t2]. Beware [t_2] is NOT lifted.
+ Eg: in context [A:Prop], [A->A] is built by [(mkArrow (mkRel 0) (mkRel 1))]
+*)
val mkArrow : types -> types -> constr
-(* Constructs the abstraction $[x:t_1]t_2$ *)
+(** Constructs the abstraction \[x:t{_ 1}\]t{_ 2} *)
val mkLambda : name * types * constr -> constr
val mkNamedLambda : identifier -> types -> constr -> constr
-(* Constructs the product [let x = t1 : t2 in t3] *)
+(** Constructs the product [let x = t1 : t2 in t3] *)
val mkLetIn : name * constr * types * constr -> constr
val mkNamedLetIn : identifier -> constr -> types -> constr -> constr
-(* [mkApp (f,[| t_1; ...; t_n |]] constructs the application
- $(f~t_1~\dots~t_n)$. *)
+(** [mkApp (f,[| t_1; ...; t_n |]] constructs the application
+ {% $(f~t_1~\dots~t_n)$ %}. *)
val mkApp : constr * constr array -> constr
-(* Constructs a constant *)
-(* The array of terms correspond to the variables introduced in the section *)
+(** Constructs a constant
+ The array of terms correspond to the variables introduced in the section *)
val mkConst : constant -> constr
-(* Inductive types *)
+(** Inductive types *)
-(* Constructs the ith (co)inductive type of the block named kn *)
-(* The array of terms correspond to the variables introduced in the section *)
+(** Constructs the ith (co)inductive type of the block named kn
+ The array of terms correspond to the variables introduced in the section *)
val mkInd : inductive -> constr
-(* Constructs the jth constructor of the ith (co)inductive type of the
+(** Constructs the jth constructor of the ith (co)inductive type of the
block named kn. The array of terms correspond to the variables
introduced in the section *)
val mkConstruct : constructor -> constr
-(* Constructs the term <p>Case c of c1 | c2 .. | cn end *)
+(** Constructs a destructor of inductive type.
+
+ [mkCase ci p c ac] stand for match [c] as [x] in [I args] return [p] with [ac]
+ presented as describe in [ci].
+
+ [p] stucture is [fun args x -> "return clause"]
+
+ [ac]{^ ith} element is ith constructor case presented as
+ {e lambda construct_args (without params). case_term } *)
val mkCase : case_info * constr * constr * constr array -> constr
-(* If [recindxs = [|i1,...in|]]
+(** If [recindxs = [|i1,...in|]]
[funnames = [|f1,.....fn|]]
[typarray = [|t1,...tn|]]
[bodies = [|b1,.....bn|]]
- then [ mkFix ((recindxs,i), funnames, typarray, bodies) ]
- constructs the $i$th function of the block (counting from 0)
+ then [mkFix ((recindxs,i), funnames, typarray, bodies) ]
+ constructs the {% $ %}i{% $ %}th function of the block (counting from 0)
[Fixpoint f1 [ctx1] = b1
with f2 [ctx2] = b2
...
with fn [ctxn] = bn.]
- \noindent where the length of the $j$th context is $ij$.
+ where the length of the {% $ %}j{% $ %}th context is {% $ %}ij{% $ %}.
*)
type rec_declaration = name array * types array * constr array
type fixpoint = (int array * int) * rec_declaration
val mkFix : fixpoint -> constr
-(* If [funnames = [|f1,.....fn|]]
+(** If [funnames = [|f1,.....fn|]]
[typarray = [|t1,...tn|]]
- [bodies = [b1,.....bn]] \par\noindent
- then [mkCoFix (i, (typsarray, funnames, bodies))]
+ [bodies = [b1,.....bn]]
+ then [mkCoFix (i, (funnames, typarray, bodies))]
constructs the ith function of the block
-
+
[CoFixpoint f1 = b1
with f2 = b2
...
@@ -173,9 +180,9 @@ type cofixpoint = int * rec_declaration
val mkCoFix : cofixpoint -> constr
-(*s Concrete type for making pattern-matching. *)
+(** {6 Concrete type for making pattern-matching. } *)
-(* [constr array] is an instance matching definitional [named_context] in
+(** [constr array] is an instance matching definitional [named_context] in
the same order (i.e. last argument first) *)
type 'constr pexistential = existential_key * 'constr array
type ('constr, 'types) prec_declaration =
@@ -203,14 +210,13 @@ type ('constr, 'types) kind_of_term =
| Fix of ('constr, 'types) pfixpoint
| CoFix of ('constr, 'types) pcofixpoint
-(* User view of [constr]. For [App], it is ensured there is at
+(** User view of [constr]. For [App], it is ensured there is at
least one argument and the function is not itself an applicative
term *)
val kind_of_term : constr -> (constr, types) kind_of_term
-val kind_of_term2 : constr -> ((constr,types) kind_of_term,constr) kind_of_term
-(* Experimental *)
+(** Experimental, used in Presburger contrib *)
type ('constr, 'types) kind_of_type =
| SortType of sorts
| CastType of 'types * 'types
@@ -220,10 +226,11 @@ type ('constr, 'types) kind_of_type =
val kind_of_type : types -> (constr, types) kind_of_type
-(*s Simple term case analysis. *)
+(** {6 Simple term case analysis. } *)
val isRel : constr -> bool
val isVar : constr -> bool
+val isVarId : identifier -> constr -> bool
val isInd : constr -> bool
val isEvar : constr -> bool
val isMeta : constr -> bool
@@ -247,77 +254,83 @@ val is_Type : constr -> bool
val iskind : constr -> bool
val is_small : sorts -> bool
-(*s Term destructors.
- Destructor operations are partial functions and
- raise [invalid_arg "dest*"] if the term has not the expected form. *)
-(* Destructs a DeBrujin index *)
+(** {6 Term destructors } *)
+(** Destructor operations are partial functions and
+ @raise Invalid_argument "dest*" if the term has not the expected form. *)
+
+(** Destructs a DeBrujin index *)
val destRel : constr -> int
-(* Destructs an existential variable *)
+(** Destructs an existential variable *)
val destMeta : constr -> metavariable
-(* Destructs a variable *)
+(** Destructs a variable *)
val destVar : constr -> identifier
-(* Destructs a sort. [is_Prop] recognizes the sort \textsf{Prop}, whether
- [isprop] recognizes both \textsf{Prop} and \textsf{Set}. *)
+(** Destructs a sort. [is_Prop] recognizes the sort {% \textsf{%}Prop{% }%}, whether
+ [isprop] recognizes both {% \textsf{%}Prop{% }%} and {% \textsf{%}Set{% }%}. *)
val destSort : constr -> sorts
-(* Destructs a casted term *)
+(** Destructs a casted term *)
val destCast : constr -> constr * cast_kind * constr
-(* Destructs the product $(x:t_1)t_2$ *)
+(** Destructs the product {% $ %}(x:t_1)t_2{% $ %} *)
val destProd : types -> name * types * types
-(* Destructs the abstraction $[x:t_1]t_2$ *)
+(** Destructs the abstraction {% $ %}[x:t_1]t_2{% $ %} *)
val destLambda : constr -> name * types * constr
-(* Destructs the let $[x:=b:t_1]t_2$ *)
+(** Destructs the let {% $ %}[x:=b:t_1]t_2{% $ %} *)
val destLetIn : constr -> name * constr * types * constr
-(* Destructs an application *)
+(** Destructs an application *)
val destApp : constr -> constr * constr array
-(* Obsolete synonym of destApp *)
+(** Obsolete synonym of destApp *)
val destApplication : constr -> constr * constr array
-(* Decompose any term as an applicative term; the list of args can be empty *)
+(** Decompose any term as an applicative term; the list of args can be empty *)
val decompose_app : constr -> constr * constr list
-(* Destructs a constant *)
+(** Destructs a constant *)
val destConst : constr -> constant
-(* Destructs an existential variable *)
+(** Destructs an existential variable *)
val destEvar : constr -> existential
-(* Destructs a (co)inductive type *)
+(** Destructs a (co)inductive type *)
val destInd : constr -> inductive
-(* Destructs a constructor *)
+(** Destructs a constructor *)
val destConstruct : constr -> constructor
-(* Destructs a term <p>Case c of lc1 | lc2 .. | lcn end *)
+(** Destructs a [match c as x in I args return P with ... |
+Ci(...yij...) => ti | ... end] (or [let (..y1i..) := c as x in I args
+return P in t1], or [if c then t1 else t2])
+@return [(info,c,fun args x => P,[|...|fun yij => ti| ...|])]
+where [info] is pretty-printing information *)
val destCase : constr -> case_info * constr * constr * constr array
-(* Destructs the $i$th function of the block
- $\mathit{Fixpoint} ~ f_1 ~ [ctx_1] = b_1
- \mathit{with} ~ f_2 ~ [ctx_2] = b_2
- \dots
- \mathit{with} ~ f_n ~ [ctx_n] = b_n$,
- where the lenght of the $j$th context is $ij$.
+(** Destructs the {% $ %}i{% $ %}th function of the block
+ [Fixpoint f{_ 1} ctx{_ 1} = b{_ 1}
+ with f{_ 2} ctx{_ 2} = b{_ 2}
+ ...
+ with f{_ n} ctx{_ n} = b{_ n}],
+ where the length of the {% $ %}j{% $ %}th context is {% $ %}ij{% $ %}.
*)
val destFix : constr -> fixpoint
val destCoFix : constr -> cofixpoint
-(*s A {\em declaration} has the form (name,body,type). It is either an
- {\em assumption} if [body=None] or a {\em definition} if
- [body=Some actualbody]. It is referred by {\em name} if [na] is an
- identifier or by {\em relative index} if [na] is not an identifier
+(** {6 Local } *)
+(** A {e declaration} has the form [(name,body,type)]. It is either an
+ {e assumption} if [body=None] or a {e definition} if
+ [body=Some actualbody]. It is referred by {e name} if [na] is an
+ identifier or by {e relative index} if [na] is not an identifier
(in the latter case, [na] is of type [name] but just for printing
- purpose *)
+ purpose) *)
type named_declaration = identifier * constr option * types
type rel_declaration = name * constr option * types
@@ -332,9 +345,25 @@ val fold_named_declaration :
val fold_rel_declaration :
(constr -> 'a -> 'a) -> rel_declaration -> 'a -> 'a
-(*s Contexts of declarations referred to by de Bruijn indices *)
+val exists_named_declaration :
+ (constr -> bool) -> named_declaration -> bool
+val exists_rel_declaration :
+ (constr -> bool) -> rel_declaration -> bool
-(* In [rel_context], more recent declaration is on top *)
+val for_all_named_declaration :
+ (constr -> bool) -> named_declaration -> bool
+val for_all_rel_declaration :
+ (constr -> bool) -> rel_declaration -> bool
+
+val eq_named_declaration :
+ named_declaration -> named_declaration -> bool
+
+val eq_rel_declaration :
+ rel_declaration -> rel_declaration -> bool
+
+(** {6 Contexts of declarations referred to by de Bruijn indices } *)
+
+(** In [rel_context], more recent declaration is on top *)
type rel_context = rel_declaration list
val empty_rel_context : rel_context
@@ -344,185 +373,186 @@ val lookup_rel : int -> rel_context -> rel_declaration
val rel_context_length : rel_context -> int
val rel_context_nhyps : rel_context -> int
-(* Constructs either [(x:t)c] or [[x=b:t]c] *)
+(** Constructs either [(x:t)c] or [[x=b:t]c] *)
val mkProd_or_LetIn : rel_declaration -> types -> types
+val mkProd_wo_LetIn : rel_declaration -> types -> types
val mkNamedProd_or_LetIn : named_declaration -> types -> types
val mkNamedProd_wo_LetIn : named_declaration -> types -> types
-(* Constructs either [[x:t]c] or [[x=b:t]c] *)
+(** Constructs either [[x:t]c] or [[x=b:t]c] *)
val mkLambda_or_LetIn : rel_declaration -> constr -> constr
val mkNamedLambda_or_LetIn : named_declaration -> constr -> constr
-(*s Other term constructors. *)
+(** {6 Other term constructors. } *)
-val abs_implicit : constr -> constr
-val lambda_implicit : constr -> constr
-val lambda_implicit_lift : int -> constr -> constr
-
-(* [applist (f,args)] and co work as [mkApp] *)
+(** [applist (f,args)] and its variants work as [mkApp] *)
val applist : constr * constr list -> constr
val applistc : constr -> constr list -> constr
val appvect : constr * constr array -> constr
val appvectc : constr -> constr array -> constr
-(* [prodn n l b] = $(x_1:T_1)..(x_n:T_n)b$
- where $l = [(x_n,T_n);\dots;(x_1,T_1);Gamma]$ *)
+(** [prodn n l b] = [forall (x_1:T_1)...(x_n:T_n), b]
+ where [l] is [(x_n,T_n)...(x_1,T_1)...]. *)
val prodn : int -> (name * constr) list -> constr -> constr
-(* [compose_prod l b] = $(x_1:T_1)..(x_n:T_n)b$
- where $l = [(x_n,T_n);\dots;(x_1,T_1)]$.
+(** [compose_prod l b]
+ @return [forall (x_1:T_1)...(x_n:T_n), b]
+ where [l] is [(x_n,T_n)...(x_1,T_1)].
Inverse of [decompose_prod]. *)
val compose_prod : (name * constr) list -> constr -> constr
-(* [lamn n l b] = $[x_1:T_1]..[x_n:T_n]b$
- where $l = [(x_n,T_n);\dots;(x_1,T_1);Gamma]$ *)
+(** [lamn n l b]
+ @return [fun (x_1:T_1)...(x_n:T_n) => b]
+ where [l] is [(x_n,T_n)...(x_1,T_1)...]. *)
val lamn : int -> (name * constr) list -> constr -> constr
-(* [compose_lam l b] = $[x_1:T_1]..[x_n:T_n]b$
- where $l = [(x_n,T_n);\dots;(x_1,T_1)]$.
+(** [compose_lam l b]
+ @return [fun (x_1:T_1)...(x_n:T_n) => b]
+ where [l] is [(x_n,T_n)...(x_1,T_1)].
Inverse of [it_destLam] *)
val compose_lam : (name * constr) list -> constr -> constr
-(* [to_lambda n l]
- = $[x_1:T_1]...[x_n:T_n]T$
- where $l = (x_1:T_1)...(x_n:T_n)T$ *)
+(** [to_lambda n l]
+ @return [fun (x_1:T_1)...(x_n:T_n) => T]
+ where [l] is [forall (x_1:T_1)...(x_n:T_n), T] *)
val to_lambda : int -> constr -> constr
-(* [to_prod n l]
- = $(x_1:T_1)...(x_n:T_n)T$
- where $l = [x_1:T_1]...[x_n:T_n]T$ *)
+(** [to_prod n l]
+ @return [forall (x_1:T_1)...(x_n:T_n), T]
+ where [l] is [fun (x_1:T_1)...(x_n:T_n) => T] *)
val to_prod : int -> constr -> constr
-(* pseudo-reduction rule *)
+(** pseudo-reduction rule *)
-(* [prod_appvect] $(x1:B1;...;xn:Bn)B a1...an \rightarrow B[a1...an]$ *)
+(** [prod_appvect] [forall (x1:B1;...;xn:Bn), B] [a1...an] @return [B[a1...an]] *)
val prod_appvect : constr -> constr array -> constr
val prod_applist : constr -> constr list -> constr
val it_mkLambda_or_LetIn : constr -> rel_context -> constr
val it_mkProd_or_LetIn : types -> rel_context -> types
-(*s Other term destructors. *)
+(** {6 Other term destructors. } *)
-(* Transforms a product term $(x_1:T_1)..(x_n:T_n)T$ into the pair
- $([(x_n,T_n);...;(x_1,T_1)],T)$, where $T$ is not a product.
+(** Transforms a product term {% $ %}(x_1:T_1)..(x_n:T_n)T{% $ %} into the pair
+ {% $ %}([(x_n,T_n);...;(x_1,T_1)],T){% $ %}, where {% $ %}T{% $ %} is not a product.
It includes also local definitions *)
val decompose_prod : constr -> (name*constr) list * constr
-(* Transforms a lambda term $[x_1:T_1]..[x_n:T_n]T$ into the pair
- $([(x_n,T_n);...;(x_1,T_1)],T)$, where $T$ is not a lambda. *)
+(** Transforms a lambda term {% $ %}[x_1:T_1]..[x_n:T_n]T{% $ %} into the pair
+ {% $ %}([(x_n,T_n);...;(x_1,T_1)],T){% $ %}, where {% $ %}T{% $ %} is not a lambda. *)
val decompose_lam : constr -> (name*constr) list * constr
-(* Given a positive integer n, transforms a product term
- $(x_1:T_1)..(x_n:T_n)T$
- into the pair $([(xn,Tn);...;(x1,T1)],T)$. *)
+(** Given a positive integer n, transforms a product term
+ {% $ %}(x_1:T_1)..(x_n:T_n)T{% $ %}
+ into the pair {% $ %}([(xn,Tn);...;(x1,T1)],T){% $ %}. *)
val decompose_prod_n : int -> constr -> (name * constr) list * constr
-(* Given a positive integer $n$, transforms a lambda term
- $[x_1:T_1]..[x_n:T_n]T$ into the pair $([(x_n,T_n);...;(x_1,T_1)],T)$ *)
+(** Given a positive integer {% $ %}n{% $ %}, transforms a lambda term
+ {% $ %}[x_1:T_1]..[x_n:T_n]T{% $ %} into the pair {% $ %}([(x_n,T_n);...;(x_1,T_1)],T){% $ %} *)
val decompose_lam_n : int -> constr -> (name * constr) list * constr
-(* Extract the premisses and the conclusion of a term of the form
+(** Extract the premisses and the conclusion of a term of the form
"(xi:Ti) ... (xj:=cj:Tj) ..., T" where T is not a product nor a let *)
val decompose_prod_assum : types -> rel_context * types
-(* Idem with lambda's *)
+(** Idem with lambda's *)
val decompose_lam_assum : constr -> rel_context * constr
-(* Idem but extract the first [n] premisses *)
+(** Idem but extract the first [n] premisses *)
val decompose_prod_n_assum : int -> types -> rel_context * types
val decompose_lam_n_assum : int -> constr -> rel_context * constr
-(* [nb_lam] $[x_1:T_1]...[x_n:T_n]c$ where $c$ is not an abstraction
- gives $n$ (casts are ignored) *)
+(** [nb_lam] {% $ %}[x_1:T_1]...[x_n:T_n]c{% $ %} where {% $ %}c{% $ %} is not an abstraction
+ gives {% $ %}n{% $ %} (casts are ignored) *)
val nb_lam : constr -> int
-(* Similar to [nb_lam], but gives the number of products instead *)
+(** Similar to [nb_lam], but gives the number of products instead *)
val nb_prod : constr -> int
-(* Returns the premisses/parameters of a type/term (let-in included) *)
+(** Returns the premisses/parameters of a type/term (let-in included) *)
val prod_assum : types -> rel_context
val lam_assum : constr -> rel_context
-(* Returns the first n-th premisses/parameters of a type/term (let included)*)
+(** Returns the first n-th premisses/parameters of a type/term (let included)*)
val prod_n_assum : int -> types -> rel_context
val lam_n_assum : int -> constr -> rel_context
-(* Remove the premisses/parameters of a type/term *)
+(** Remove the premisses/parameters of a type/term *)
val strip_prod : types -> types
val strip_lam : constr -> constr
-(* Remove the first n-th premisses/parameters of a type/term *)
+(** Remove the first n-th premisses/parameters of a type/term *)
val strip_prod_n : int -> types -> types
val strip_lam_n : int -> constr -> constr
-(* Remove the premisses/parameters of a type/term (including let-in) *)
+(** Remove the premisses/parameters of a type/term (including let-in) *)
val strip_prod_assum : types -> types
val strip_lam_assum : constr -> constr
-(* flattens application lists *)
+(** flattens application lists *)
val collapse_appl : constr -> constr
-(* Removes recursively the casts around a term i.e.
- [strip_outer_cast] (Cast (Cast ... (Cast c, t) ... ))] is [c]. *)
+(** Removes recursively the casts around a term i.e.
+ [strip_outer_cast (Cast (Cast ... (Cast c, t) ... ))] is [c]. *)
val strip_outer_cast : constr -> constr
-(* Apply a function letting Casted types in place *)
+(** Apply a function letting Casted types in place *)
val under_casts : (constr -> constr) -> constr -> constr
-(* Apply a function under components of Cast if any *)
+(** Apply a function under components of Cast if any *)
val under_outer_cast : (constr -> constr) -> constr -> constr
-(*s An "arity" is a term of the form [[x1:T1]...[xn:Tn]s] with [s] a sort.
+(** {6 ... } *)
+(** An "arity" is a term of the form [[x1:T1]...[xn:Tn]s] with [s] a sort.
Such a term can canonically be seen as the pair of a context of types
and of a sort *)
type arity = rel_context * sorts
-(* Build an "arity" from its canonical form *)
+(** Build an "arity" from its canonical form *)
val mkArity : arity -> types
-(* Destructs an "arity" into its canonical form *)
+(** Destructs an "arity" into its canonical form *)
val destArity : types -> arity
-(* Tells if a term has the form of an arity *)
+(** Tells if a term has the form of an arity *)
val isArity : types -> bool
-(*s Occur checks *)
+(** {6 Occur checks } *)
-(* [closedn n M] is true iff [M] is a (deBruijn) closed term under n binders *)
+(** [closedn n M] is true iff [M] is a (deBruijn) closed term under n binders *)
val closedn : int -> constr -> bool
-(* [closed0 M] is true iff [M] is a (deBruijn) closed term *)
+(** [closed0 M] is true iff [M] is a (deBruijn) closed term *)
val closed0 : constr -> bool
-(* [noccurn n M] returns true iff [Rel n] does NOT occur in term [M] *)
+(** [noccurn n M] returns true iff [Rel n] does NOT occur in term [M] *)
val noccurn : int -> constr -> bool
-(* [noccur_between n m M] returns true iff [Rel p] does NOT occur in term [M]
+(** [noccur_between n m M] returns true iff [Rel p] does NOT occur in term [M]
for n <= p < n+m *)
val noccur_between : int -> int -> constr -> bool
-(* Checking function for terms containing existential- or
+(** Checking function for terms containing existential- or
meta-variables. The function [noccur_with_meta] does not consider
meta-variables applied to some terms (intended to be its local
context) (for existential variables, it is necessarily the case) *)
val noccur_with_meta : int -> int -> constr -> bool
-(*s Relocation and substitution *)
+(** {6 Relocation and substitution } *)
-(* [exliftn el c] lifts [c] with lifting [el] *)
+(** [exliftn el c] lifts [c] with lifting [el] *)
val exliftn : Esubst.lift -> constr -> constr
-(* [liftn n k c] lifts by [n] indexes above or equal to [k] in [c] *)
+(** [liftn n k c] lifts by [n] indexes above or equal to [k] in [c] *)
val liftn : int -> int -> constr -> constr
-(* [lift n c] lifts by [n] the positive indexes in [c] *)
+(** [lift n c] lifts by [n] the positive indexes in [c] *)
val lift : int -> constr -> constr
-(* [substnl [a1;...;an] k c] substitutes in parallel [a1],...,[an]
+(** [substnl [a1;...;an] k c] substitutes in parallel [a1],...,[an]
for respectively [Rel(k+1)],...,[Rel(k+n)] in [c]; it relocates
accordingly indexes in [a1],...,[an] *)
val substnl : constr list -> int -> constr -> constr
@@ -539,29 +569,30 @@ val substl_named_decl : constr list -> named_declaration -> named_declaration
val replace_vars : (identifier * constr) list -> constr -> constr
val subst_var : identifier -> constr -> constr
-(* [subst_vars [id1;...;idn] t] substitute [VAR idj] by [Rel j] in [t]
+(** [subst_vars [id1;...;idn] t] substitute [VAR idj] by [Rel j] in [t]
if two names are identical, the one of least indice is kept *)
val subst_vars : identifier list -> constr -> constr
-(* [substn_vars n [id1;...;idn] t] substitute [VAR idj] by [Rel j+n-1] in [t]
+
+(** [substn_vars n [id1;...;idn] t] substitute [VAR idj] by [Rel j+n-1] in [t]
if two names are identical, the one of least indice is kept *)
val substn_vars : int -> identifier list -> constr -> constr
-(*s Functionals working on the immediate subterm of a construction *)
+(** {6 Functionals working on the immediate subterm of a construction } *)
-(* [fold_constr f acc c] folds [f] on the immediate subterms of [c]
+(** [fold_constr f acc c] folds [f] on the immediate subterms of [c]
starting from [acc] and proceeding from left to right according to
the usual representation of the constructions; it is not recursive *)
val fold_constr : ('a -> constr -> 'a) -> 'a -> constr -> 'a
-(* [map_constr f c] maps [f] on the immediate subterms of [c]; it is
+(** [map_constr f c] maps [f] on the immediate subterms of [c]; it is
not recursive and the order with which subterms are processed is
not specified *)
val map_constr : (constr -> constr) -> constr -> constr
-(* [map_constr_with_binders g f n c] maps [f n] on the immediate
+(** [map_constr_with_binders g f n c] maps [f n] on the immediate
subterms of [c]; it carries an extra data [n] (typically a lift
index) which is processed by [g] (which typically add 1 to [n]) at
each binder traversal; it is not recursive and the order with which
@@ -570,13 +601,13 @@ val map_constr : (constr -> constr) -> constr -> constr
val map_constr_with_binders :
('a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr
-(* [iter_constr f c] iters [f] on the immediate subterms of [c]; it is
+(** [iter_constr f c] iters [f] on the immediate subterms of [c]; it is
not recursive and the order with which subterms are processed is
not specified *)
val iter_constr : (constr -> unit) -> constr -> unit
-(* [iter_constr_with_binders g f n c] iters [f n] on the immediate
+(** [iter_constr_with_binders g f n c] iters [f n] on the immediate
subterms of [c]; it carries an extra data [n] (typically a lift
index) which is processed by [g] (which typically add 1 to [n]) at
each binder traversal; it is not recursive and the order with which
@@ -585,27 +616,20 @@ val iter_constr : (constr -> unit) -> constr -> unit
val iter_constr_with_binders :
('a -> 'a) -> ('a -> constr -> unit) -> 'a -> constr -> unit
-(* [compare_constr f c1 c2] compare [c1] and [c2] using [f] to compare
+(** [compare_constr f c1 c2] compare [c1] and [c2] using [f] to compare
the immediate subterms of [c1] of [c2] if needed; Cast's, binders
name and Cases annotations are not taken into account *)
val compare_constr : (constr -> constr -> bool) -> constr -> constr -> bool
+val constr_ord : constr -> constr -> int
+val hash_constr : constr -> int
+
(*********************************************************************)
-val hcons_constr:
- (constant -> constant) *
- (mutual_inductive -> mutual_inductive) *
- (dir_path -> dir_path) *
- (name -> name) *
- (identifier -> identifier) *
- (string -> string)
- ->
- (constr -> constr) *
- (types -> types)
-
-val hcons1_constr : constr -> constr
-val hcons1_types : types -> types
+val hcons_sorts : sorts -> sorts
+val hcons_constr : constr -> constr
+val hcons_types : types -> types
(**************************************)
diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml
index c1eb97a6..478b9c6f 100644
--- a/kernel/term_typing.ml
+++ b/kernel/term_typing.ml
@@ -1,12 +1,16 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: term_typing.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
+(* Created by Jacek Chrzaszcz, Aug 2002 as part of the implementation of
+ the Coq module system *)
+
+(* This module provides the main entry points for type-checking basic
+ declarations *)
open Util
open Names
@@ -28,8 +32,9 @@ let constrain_type env j cst1 = function
| Some t ->
let (tj,cst2) = infer_type env t in
let (_,cst3) = judge_of_cast env j DEFAULTcast tj in
- assert (t = tj.utj_val);
- NonPolymorphicType t, Constraint.union (Constraint.union cst1 cst2) cst3
+ assert (eq_constr t tj.utj_val);
+ let cstrs = union_constraints (union_constraints cst1 cst2) cst3 in
+ NonPolymorphicType t, cstrs
let local_constrain_type env j cst1 = function
| None ->
@@ -37,8 +42,8 @@ let local_constrain_type env j cst1 = function
| Some t ->
let (tj,cst2) = infer_type env t in
let (_,cst3) = judge_of_cast env j DEFAULTcast tj in
- assert (t = tj.utj_val);
- t, Constraint.union (Constraint.union cst1 cst2) cst3
+ assert (eq_constr t tj.utj_val);
+ t, union_constraints (union_constraints cst1 cst2) cst3
let translate_local_def env (b,topt) =
let (j,cst) = infer env b in
@@ -88,13 +93,20 @@ let infer_declaration env dcl =
match dcl with
| DefinitionEntry c ->
let (j,cst) = infer env c.const_entry_body in
+ let j =
+ {uj_val = hcons_constr j.uj_val;
+ uj_type = hcons_constr j.uj_type} in
let (typ,cst) = constrain_type env j cst c.const_entry_type in
- Some (Declarations.from_val j.uj_val), typ, cst,
- c.const_entry_opaque, c.const_entry_boxed, false
- | ParameterEntry (t,nl) ->
+ let def =
+ if c.const_entry_opaque
+ then OpaqueDef (Declarations.opaque_from_val j.uj_val)
+ else Def (Declarations.from_val j.uj_val)
+ in
+ def, typ, cst, c.const_entry_secctx
+ | ParameterEntry (ctx,t,nl) ->
let (j,cst) = infer env t in
- None, NonPolymorphicType (Typeops.assumption_of_judgment env j), cst,
- false, false, nl
+ let t = hcons_constr (Typeops.assumption_of_judgment env j) in
+ Undef nl, NonPolymorphicType t, cst, ctx
let global_vars_set_constant_type env = function
| NonPolymorphicType t -> global_vars_set env t
@@ -104,25 +116,32 @@ let global_vars_set_constant_type env = function
(fun t c -> Idset.union (global_vars_set env t) c))
ctx ~init:Idset.empty
-let build_constant_declaration env kn (body,typ,cst,op,boxed,inline) =
- let ids =
- match body with
- | None -> global_vars_set_constant_type env typ
- | Some b ->
- Idset.union
- (global_vars_set env (Declarations.force b))
- (global_vars_set_constant_type env typ)
- in
- let tps = Cemitcodes.from_val (compile_constant_body env body op boxed) in
- let hyps = keep_hyps env ids in
- { const_hyps = hyps;
- const_body = body;
- const_type = typ;
- const_body_code = tps;
- (* const_type_code = to_patch env typ;*)
- const_constraints = cst;
- const_opaque = op;
- const_inline = inline}
+let build_constant_declaration env kn (def,typ,cst,ctx) =
+ let hyps =
+ let inferred =
+ let ids_typ = global_vars_set_constant_type env typ in
+ let ids_def = match def with
+ | Undef _ -> Idset.empty
+ | Def cs -> global_vars_set env (Declarations.force cs)
+ | OpaqueDef lc ->
+ global_vars_set env (Declarations.force_opaque lc) in
+ keep_hyps env (Idset.union ids_typ ids_def) in
+ let declared = match ctx with
+ | None -> inferred
+ | Some declared -> declared in
+ let mk_set l = List.fold_right Idset.add (List.map pi1 l) Idset.empty in
+ let inferred_set, declared_set = mk_set inferred, mk_set declared in
+ if not (Idset.subset inferred_set declared_set) then
+ error ("The following section variable are used but not declared:\n"^
+ (String.concat ", " (List.map string_of_id
+ (Idset.elements (Idset.diff inferred_set declared_set)))));
+ declared in
+ let tps = Cemitcodes.from_val (compile_constant_body env def) in
+ { const_hyps = hyps;
+ const_body = def;
+ const_type = typ;
+ const_body_code = tps;
+ const_constraints = cst }
(*s Global and local constant declaration. *)
@@ -130,8 +149,9 @@ let translate_constant env kn ce =
build_constant_declaration env kn (infer_declaration env ce)
let translate_recipe env kn r =
- build_constant_declaration env kn (Cooking.cook_constant env r)
+ build_constant_declaration env kn
+ (let def,typ,cst = Cooking.cook_constant env r in def,typ,cst,None)
(* Insertion of inductive types. *)
-let translate_mind env mie = check_inductive env mie
+let translate_mind env kn mie = check_inductive env kn mie
diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli
index 217c9f91..3bbf5667 100644
--- a/kernel/term_typing.mli
+++ b/kernel/term_typing.mli
@@ -1,14 +1,11 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: term_typing.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
open Names
open Term
open Univ
@@ -17,7 +14,6 @@ open Inductive
open Environ
open Entries
open Typeops
-(*i*)
val translate_local_def : env -> constr * types option ->
constr * types * Univ.constraints
@@ -26,16 +22,16 @@ val translate_local_assum : env -> types ->
types * Univ.constraints
val infer_declaration : env -> constant_entry ->
- constr_substituted option * constant_type * constraints * bool * bool * bool
+ constant_def * constant_type * constraints * Sign.section_context option
val build_constant_declaration : env -> 'a ->
- constr_substituted option * constant_type * constraints * bool * bool * bool ->
- constant_body
+ constant_def * constant_type * constraints * Sign.section_context option ->
+ constant_body
val translate_constant : env -> constant -> constant_entry -> constant_body
val translate_mind :
- env -> mutual_inductive_entry -> mutual_inductive_body
+ env -> mutual_inductive -> mutual_inductive_entry -> mutual_inductive_body
val translate_recipe :
env -> constant -> Cooking.recipe -> constant_body
diff --git a/kernel/type_errors.ml b/kernel/type_errors.ml
index 2e6b8d50..8f129999 100644
--- a/kernel/type_errors.ml
+++ b/kernel/type_errors.ml
@@ -1,13 +1,11 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: type_errors.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
open Names
open Term
open Sign
@@ -20,7 +18,7 @@ type guard_error =
(* Fixpoints *)
| NotEnoughAbstractionInFixBody
| RecursionNotOnInductiveType of constr
- | RecursionOnIllegalTerm of int * constr * int list * int list
+ | RecursionOnIllegalTerm of int * (env * constr) * int list * int list
| NotEnoughArgumentsForFixCall of int
(* CoFixpoints *)
| CodomainNotInductiveType of constr
@@ -50,7 +48,7 @@ type type_error =
| CaseNotInductive of unsafe_judgment
| WrongCaseInfo of inductive * case_info
| NumberBranches of unsafe_judgment * int
- | IllFormedBranch of constr * int * constr * constr
+ | IllFormedBranch of constr * constructor * constr * constr
| Generalization of (name * types) * unsafe_judgment
| ActualType of unsafe_judgment * types
| CantApplyBadType of
@@ -111,4 +109,9 @@ let error_ill_formed_rec_body env why lna i fixenv vdefj =
let error_ill_typed_rec_body env i lna vdefj vargs =
raise (TypeError (env, IllTypedRecBody (i,lna,vdefj,vargs)))
+let error_elim_explain kp ki =
+ match kp,ki with
+ | (InType | InSet), InProp -> NonInformativeToInformative
+ | InType, InSet -> StrongEliminationOnNonSmallType (* if Set impredicative *)
+ | _ -> WrongArity
diff --git a/kernel/type_errors.mli b/kernel/type_errors.mli
index 989b8fbb..7c61e105 100644
--- a/kernel/type_errors.mli
+++ b/kernel/type_errors.mli
@@ -1,30 +1,26 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: type_errors.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
open Names
open Term
open Environ
-(*i*)
-(* Type errors. \label{typeerrors} *)
+(** Type errors. {% \label{%}typeerrors{% }%} *)
(*i Rem: NotEnoughAbstractionInFixBody should only occur with "/i" Fix
notation i*)
type guard_error =
- (* Fixpoints *)
+ (** Fixpoints *)
| NotEnoughAbstractionInFixBody
| RecursionNotOnInductiveType of constr
- | RecursionOnIllegalTerm of int * constr * int list * int list
+ | RecursionOnIllegalTerm of int * (env * constr) * int list * int list
| NotEnoughArgumentsForFixCall of int
- (* CoFixpoints *)
+ (** CoFixpoints *)
| CodomainNotInductiveType of constr
| NestedRecursiveOccurrences
| UnguardedRecursiveCall of constr
@@ -52,7 +48,7 @@ type type_error =
| CaseNotInductive of unsafe_judgment
| WrongCaseInfo of inductive * case_info
| NumberBranches of unsafe_judgment * int
- | IllFormedBranch of constr * int * constr * constr
+ | IllFormedBranch of constr * constructor * constr * constr
| Generalization of (name * types) * unsafe_judgment
| ActualType of unsafe_judgment * types
| CantApplyBadType of
@@ -82,7 +78,7 @@ val error_case_not_inductive : env -> unsafe_judgment -> 'a
val error_number_branches : env -> unsafe_judgment -> int -> 'a
-val error_ill_formed_branch : env -> constr -> int -> constr -> constr -> 'a
+val error_ill_formed_branch : env -> constr -> constructor -> constr -> constr -> 'a
val error_generalization : env -> name * types -> unsafe_judgment -> 'a
@@ -101,3 +97,4 @@ val error_ill_formed_rec_body :
val error_ill_typed_rec_body :
env -> int -> name array -> unsafe_judgment array -> types array -> 'a
+val error_elim_explain : sorts_family -> sorts_family -> arity_error
diff --git a/kernel/typeops.ml b/kernel/typeops.ml
index 2fd02063..49106c91 100644
--- a/kernel/typeops.ml
+++ b/kernel/typeops.ml
@@ -1,13 +1,11 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: typeops.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
open Util
open Names
open Univ
@@ -20,8 +18,7 @@ open Reduction
open Inductive
open Type_errors
-let conv = default_conv CONV
-let conv_leq = default_conv CUMUL
+let conv_leq l2r = default_conv CUMUL ~l2r
let conv_leq_vecti env v1 v2 =
array_fold_left2_i
@@ -29,8 +26,8 @@ let conv_leq_vecti env v1 v2 =
let c' =
try default_conv CUMUL env t1 t2
with NotConvertible -> raise (NotConvertibleVect i) in
- Constraint.union c c')
- Constraint.empty
+ union_constraints c c')
+ empty_constraint
v1
v2
@@ -47,8 +44,6 @@ let assumption_of_judgment env j =
with TypeError _ ->
error_assumption env j
-let sort_judgment env j = (type_judgment env j).utj_type
-
(************************************************)
(* Incremental typing rules: builds a typing judgement given the *)
(* judgements for the subterms. *)
@@ -206,8 +201,8 @@ let judge_of_apply env funj argjv =
(match kind_of_term (whd_betadeltaiota env typ) with
| Prod (_,c1,c2) ->
(try
- let c = conv_leq env hj.uj_type c1 in
- let cst' = Constraint.union cst c in
+ let c = conv_leq false env hj.uj_type c1 in
+ let cst' = union_constraints cst c in
apply_rec (n+1) (subst1 hj.uj_val c2) cst' restjl
with NotConvertible ->
error_cant_apply_bad_type env
@@ -219,7 +214,7 @@ let judge_of_apply env funj argjv =
in
apply_rec 1
funj.uj_type
- Constraint.empty
+ empty_constraint
(Array.to_list argjv)
(* Type of product *)
@@ -270,11 +265,18 @@ let judge_of_product env name t1 t2 =
let judge_of_cast env cj k tj =
let expected_type = tj.utj_val in
try
- let cst =
+ let c, cst =
match k with
- | VMcast -> vm_conv CUMUL env cj.uj_type expected_type
- | DEFAULTcast -> conv_leq env cj.uj_type expected_type in
- { uj_val = mkCast (cj.uj_val, k, expected_type);
+ | VMcast ->
+ mkCast (cj.uj_val, k, expected_type),
+ vm_conv CUMUL env cj.uj_type expected_type
+ | DEFAULTcast ->
+ mkCast (cj.uj_val, k, expected_type),
+ conv_leq false env cj.uj_type expected_type
+ | REVERTcast ->
+ cj.uj_val,
+ conv_leq true env cj.uj_type expected_type in
+ { uj_val = c;
uj_type = expected_type },
cst
with NotConvertible ->
@@ -318,11 +320,11 @@ let judge_of_constructor env c =
(* Case. *)
-let check_branch_types env cj (lfj,explft) =
+let check_branch_types env ind cj (lfj,explft) =
try conv_leq_vecti env (Array.map j_type lfj) explft
with
NotConvertibleVect i ->
- error_ill_formed_branch env cj.uj_val i lfj.(i).uj_type explft.(i)
+ error_ill_formed_branch env cj.uj_val (ind,i+1) lfj.(i).uj_type explft.(i)
| Invalid_argument _ ->
error_number_branches env cj (Array.length explft)
@@ -333,11 +335,11 @@ let judge_of_case env ci pj cj lfj =
let _ = check_case_info env (fst indspec) ci in
let (bty,rslty,univ) =
type_case_branches env indspec pj cj.uj_val in
- let univ' = check_branch_types env cj (lfj,bty) in
+ let univ' = check_branch_types env (fst indspec) cj (lfj,bty) in
({ uj_val = mkCase (ci, (*nf_betaiota*) pj.uj_val, cj.uj_val,
Array.map j_val lfj);
uj_type = rslty },
- Constraint.union univ univ')
+ union_constraints univ univ')
(* Fixpoints. *)
@@ -359,7 +361,7 @@ let type_fixpoint env lna lar vdefj =
graph and in the universes of the environment. This is to ensure
that the infered local graph is satisfiable. *)
let univ_combinator (cst,univ) (j,c') =
- (j,(Constraint.union cst c', merge_constraints c' univ))
+ (j,(union_constraints cst c', merge_constraints c' univ))
(* The typing machine. *)
(* ATTENTION : faudra faire le typage du contexte des Const,
@@ -476,23 +478,21 @@ and execute_recdef env (names,lar,vdef) i cu =
and execute_array env = array_fold_map' (execute env)
-and execute_list env = list_fold_map' (execute env)
-
(* Derived functions *)
let infer env constr =
let (j,(cst,_)) =
- execute env constr (Constraint.empty, universes env) in
- assert (j.uj_val = constr);
- ({ j with uj_val = constr }, cst)
+ execute env constr (empty_constraint, universes env) in
+ assert (eq_constr j.uj_val constr);
+ (j, cst)
let infer_type env constr =
let (j,(cst,_)) =
- execute_type env constr (Constraint.empty, universes env) in
+ execute_type env constr (empty_constraint, universes env) in
(j, cst)
let infer_v env cv =
let (jv,(cst,_)) =
- execute_array env cv (Constraint.empty, universes env) in
+ execute_array env cv (empty_constraint, universes env) in
(jv, cst)
(* Typing of several terms. *)
@@ -510,8 +510,8 @@ let infer_local_decls env decls =
| (id, d) :: l ->
let env, l, cst1 = inferec env l in
let d, cst2 = infer_local_decl env id d in
- push_rel d env, add_rel_decl d l, Constraint.union cst1 cst2
- | [] -> env, empty_rel_context, Constraint.empty in
+ push_rel d env, add_rel_decl d l, union_constraints cst1 cst2
+ | [] -> env, empty_rel_context, empty_constraint in
inferec env decls
(* Exported typing functions *)
diff --git a/kernel/typeops.mli b/kernel/typeops.mli
index 6e922041..c1c805f3 100644
--- a/kernel/typeops.mli
+++ b/kernel/typeops.mli
@@ -1,23 +1,19 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: typeops.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(*i*)
open Names
open Univ
open Term
open Environ
open Entries
open Declarations
-(*i*)
-(*s Typing functions (not yet tagged as safe) *)
+(** {6 Typing functions (not yet tagged as safe) } *)
val infer : env -> constr -> unsafe_judgment * constraints
val infer_v : env -> constr array -> unsafe_judgment array * constraints
@@ -27,56 +23,56 @@ val infer_local_decls :
env -> (identifier * local_entry) list
-> env * rel_context * constraints
-(*s Basic operations of the typing machine. *)
+(** {6 Basic operations of the typing machine. } *)
-(* If [j] is the judgement $c:t$, then [assumption_of_judgement env j]
- returns the type $c$, checking that $t$ is a sort. *)
+(** If [j] is the judgement {% $ %}c:t{% $ %}, then [assumption_of_judgement env j]
+ returns the type {% $ %}c{% $ %}, checking that {% $ %}t{% $ %} is a sort. *)
val assumption_of_judgment : env -> unsafe_judgment -> types
val type_judgment : env -> unsafe_judgment -> unsafe_type_judgment
-(*s Type of sorts. *)
+(** {6 Type of sorts. } *)
val judge_of_prop_contents : contents -> unsafe_judgment
val judge_of_type : universe -> unsafe_judgment
-(*s Type of a bound variable. *)
+(** {6 Type of a bound variable. } *)
val judge_of_relative : env -> int -> unsafe_judgment
-(*s Type of variables *)
+(** {6 Type of variables } *)
val judge_of_variable : env -> variable -> unsafe_judgment
-(*s type of a constant *)
+(** {6 type of a constant } *)
val judge_of_constant : env -> constant -> unsafe_judgment
val judge_of_constant_knowing_parameters :
env -> constant -> unsafe_judgment array -> unsafe_judgment
-(*s Type of application. *)
+(** {6 Type of application. } *)
val judge_of_apply :
env -> unsafe_judgment -> unsafe_judgment array
-> unsafe_judgment * constraints
-(*s Type of an abstraction. *)
+(** {6 Type of an abstraction. } *)
val judge_of_abstraction :
env -> name -> unsafe_type_judgment -> unsafe_judgment
-> unsafe_judgment
-(*s Type of a product. *)
+(** {6 Type of a product. } *)
val judge_of_product :
env -> name -> unsafe_type_judgment -> unsafe_type_judgment
-> unsafe_judgment
-(* s Type of a let in. *)
+(** s Type of a let in. *)
val judge_of_letin :
env -> name -> unsafe_judgment -> unsafe_type_judgment -> unsafe_judgment
-> unsafe_judgment
-(*s Type of a cast. *)
+(** {6 Type of a cast. } *)
val judge_of_cast :
env -> unsafe_judgment -> cast_kind -> unsafe_type_judgment ->
unsafe_judgment * constraints
-(*s Inductive types. *)
+(** {6 Inductive types. } *)
val judge_of_inductive : env -> inductive -> unsafe_judgment
@@ -85,16 +81,16 @@ val judge_of_inductive_knowing_parameters :
val judge_of_constructor : env -> constructor -> unsafe_judgment
-(*s Type of Cases. *)
+(** {6 Type of Cases. } *)
val judge_of_case : env -> case_info
-> unsafe_judgment -> unsafe_judgment -> unsafe_judgment array
-> unsafe_judgment * constraints
-(* Typecheck general fixpoint (not checking guard conditions) *)
+(** Typecheck general fixpoint (not checking guard conditions) *)
val type_fixpoint : env -> name array -> types array
-> unsafe_judgment array -> constraints
-(* Kernel safe typing but applicable to partial proofs *)
+(** Kernel safe typing but applicable to partial proofs *)
val typing : env -> constr -> unsafe_judgment
val type_of_constant : env -> constant -> types
@@ -104,7 +100,7 @@ val type_of_constant_type : env -> constant_type -> types
val type_of_constant_knowing_parameters :
env -> constant_type -> constr array -> types
-(* Make a type polymorphic if an arity *)
+(** Make a type polymorphic if an arity *)
val make_polymorphic_if_constant_for_ind : env -> unsafe_judgment ->
constant_type
diff --git a/kernel/univ.ml b/kernel/univ.ml
index 0646a501..a8934544 100644
--- a/kernel/univ.ml
+++ b/kernel/univ.ml
@@ -1,17 +1,21 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: univ.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
-(* Initial Caml version originates from CoC 4.8 [Dec 1988] *)
-(* Extension with algebraic universes by HH [Sep 2001] *)
+(* Created in Caml by Gérard Huet for CoC 4.8 [Dec 1988] *)
+(* Functional code by Jean-Christophe Filliâtre for Coq V7.0 [1999] *)
+(* Extension with algebraic universes by HH for Coq V7.0 [Sep 2001] *)
(* Additional support for sort-polymorphic inductive types by HH [Mar 2006] *)
+(* Revisions by Bruno Barras, Hugo Herbelin, Pierre Letouzey *)
+
+open Pp
+open Util
+
(* Universes are stratified by a partial ordering $\le$.
Let $\~{}$ be the associated equivalence. We also have a strict ordering
$<$ between equivalence classes, and we maintain that $<$ is acyclic,
@@ -24,11 +28,40 @@
union-find algorithm. The assertions $<$ and $\le$ are represented by
adjacency lists *)
-open Pp
-open Util
+module UniverseLevel = struct
+
+ type t =
+ | Set
+ | Level of Names.dir_path * int
+
+ (* A specialized comparison function: we compare the [int] part
+ first (this property is used by the [check_sorted] function
+ below). This way, most of the time, the [dir_path] part is not
+ considered. *)
+
+ let compare u v = match u,v with
+ | Set, Set -> 0
+ | Set, _ -> -1
+ | _, Set -> 1
+ | Level (dp1, i1), Level (dp2, i2) ->
+ if i1 < i2 then -1
+ else if i1 > i2 then 1
+ else compare dp1 dp2
+
+ let to_string = function
+ | Set -> "Set"
+ | Level (d,n) -> Names.string_of_dirpath d^"."^string_of_int n
+end
+
+module UniverseLMap = Map.Make (UniverseLevel)
+module UniverseLSet = Set.Make (UniverseLevel)
+
+type universe_level = UniverseLevel.t
+
+let compare_levels = UniverseLevel.compare
(* An algebraic universe [universe] is either a universe variable
- [universe_level] or a formal universe known to be greater than some
+ [UniverseLevel.t] or a formal universe known to be greater than some
universe variables and strictly greater than some (other) universe
variables
@@ -37,38 +70,21 @@ open Util
universes inferred while type-checking: it is either the successor
of a universe present in the initial term to type-check or the
maximum of two algebraic universes
- *)
-
-type universe_level =
- | Set
- | Level of Names.dir_path * int
-
-(* A specialized comparison function: we compare the [int] part first.
- This way, most of the time, the [dir_path] part is not considered. *)
-
-let cmp_univ_level u v = match u,v with
- | Set, Set -> 0
- | Set, _ -> -1
- | _, Set -> 1
- | Level (dp1,i1), Level (dp2,i2) ->
- if i1 < i2 then -1
- else if i1 > i2 then 1
- else compare dp1 dp2
-
-let string_of_univ_level = function
- | Set -> "Set"
- | Level (d,n) -> Names.string_of_dirpath d^"."^string_of_int n
-
-module UniverseLMap =
- Map.Make (struct type t = universe_level let compare = cmp_univ_level end)
+*)
type universe =
- | Atom of universe_level
- | Max of universe_level list * universe_level list
+ | Atom of UniverseLevel.t
+ | Max of UniverseLevel.t list * UniverseLevel.t list
+
+let make_universe_level (m,n) = UniverseLevel.Level (m,n)
+let make_universe l = Atom l
+let make_univ c = Atom (make_universe_level c)
-let make_univ (m,n) = Atom (Level (m,n))
+let universe_level = function
+ | Atom l -> Some l
+ | Max _ -> None
-let pr_uni_level u = str (string_of_univ_level u)
+let pr_uni_level u = str (UniverseLevel.to_string u)
let pr_uni = function
| Atom u ->
@@ -97,7 +113,7 @@ let super = function
let sup u v =
match u,v with
| Atom u, Atom v ->
- if cmp_univ_level u v = 0 then Atom u else Max ([u;v],[])
+ if UniverseLevel.compare u v = 0 then Atom u else Max ([u;v],[])
| u, Max ([],[]) -> u
| Max ([],[]), v -> v
| Atom u, Max (gel,gtl) -> Max (list_add_set u gel,gtl)
@@ -109,16 +125,16 @@ let sup u v =
(* Comparison on this type is pointer equality *)
type canonical_arc =
- { univ: universe_level; lt: universe_level list; le: universe_level list }
+ { univ: UniverseLevel.t; lt: UniverseLevel.t list; le: UniverseLevel.t list }
let terminal u = {univ=u; lt=[]; le=[]}
-(* A universe_level is either an alias for another one, or a canonical one,
+(* A UniverseLevel.t is either an alias for another one, or a canonical one,
for which we know the universes that are above *)
type univ_entry =
Canonical of canonical_arc
- | Equiv of universe_level
+ | Equiv of UniverseLevel.t
type universes = univ_entry UniverseLMap.t
@@ -129,12 +145,6 @@ let enter_equiv_arc u v g =
let enter_arc ca g =
UniverseLMap.add ca.univ (Canonical ca) g
-let declare_univ u g =
- if not (UniverseLMap.mem u g) then
- enter_arc (terminal u) g
- else
- g
-
(* The lower predicative level of the hierarchy that contains (impredicative)
Prop and singleton inductive types *)
let type0m_univ = Max ([],[])
@@ -144,28 +154,30 @@ let is_type0m_univ = function
| _ -> false
(* The level of predicative Set *)
-let type0_univ = Atom Set
+let type0_univ = Atom UniverseLevel.Set
let is_type0_univ = function
- | Atom Set -> true
- | Max ([Set],[]) -> warning "Non canonical Set"; true
+ | Atom UniverseLevel.Set -> true
+ | Max ([UniverseLevel.Set], []) -> warning "Non canonical Set"; true
| u -> false
let is_univ_variable = function
- | Atom a when a<>Set -> true
+ | Atom a when a<>UniverseLevel.Set -> true
| _ -> false
(* When typing [Prop] and [Set], there is no constraint on the level,
hence the definition of [type1_univ], the type of [Prop] *)
-let type1_univ = Max ([],[Set])
+let type1_univ = Max ([], [UniverseLevel.Set])
let initial_universes = UniverseLMap.empty
+let is_initial_universes = UniverseLMap.is_empty
-(* Every universe_level has a unique canonical arc representative *)
+(* Every UniverseLevel.t has a unique canonical arc representative *)
-(* repr : universes -> universe_level -> canonical_arc *)
+(* repr : universes -> UniverseLevel.t -> canonical_arc *)
(* canonical representative : we follow the Equiv links *)
+
let repr g u =
let rec repr_rec u =
let a =
@@ -181,6 +193,20 @@ let repr g u =
let can g = List.map (repr g)
+(* [safe_repr] also search for the canonical representative, but
+ if the graph doesn't contain the searched universe, we add it. *)
+
+let safe_repr g u =
+ let rec safe_repr_rec u =
+ match UniverseLMap.find u g with
+ | Equiv v -> safe_repr_rec v
+ | Canonical arc -> arc
+ in
+ try g, safe_repr_rec u
+ with Not_found ->
+ let can = terminal u in
+ enter_arc can g, can
+
(* reprleq : canonical_arc -> canonical_arc list *)
(* All canonical arcv such that arcu<=arcv with arcv#arcu *)
let reprleq g arcu =
@@ -196,11 +222,11 @@ let reprleq g arcu =
searchrec [] arcu.le
-(* between : universe_level -> canonical_arc -> canonical_arc list *)
+(* between : UniverseLevel.t -> canonical_arc -> canonical_arc list *)
(* between u v = {w|u<=w<=v, w canonical} *)
(* between is the most costly operation *)
-let between g u arcv =
+let between g arcu arcv =
(* good are all w | u <= w <= v *)
(* bad are all w | u <= w ~<= v *)
(* find good and bad nodes in {w | u <= w} *)
@@ -221,7 +247,7 @@ let between g u arcv =
else
good, arcu::bad, b (* b or false *)
in
- let good,_,_ = explore ([arcv],[],false) (repr g u) in
+ let good,_,_ = explore ([arcv],[],false) arcu in
good
(* We assume compare(u,v) = LE with v canonical (see compare below).
@@ -272,9 +298,7 @@ let compare_neq g arcu arcv =
in
cmp [] [] ([],[arcu])
-let compare g u v =
- let arcu = repr g u
- and arcv = repr g v in
+let compare g arcu arcv =
if arcu == arcv then EQ else compare_neq g arcu arcv
(* Invariants : compare(u,v) = EQ <=> compare(v,u) = EQ
@@ -286,11 +310,12 @@ let compare g u v =
Adding u>v is consistent iff compare(v,u) = NLE
and then it is redundant iff compare(u,v) = LT *)
-let compare_eq g u v =
- let g = declare_univ u g in
- let g = declare_univ v g in
- repr g u == repr g v
+(** * Universe checks [check_eq] and [check_geq], used in coqchk *)
+let compare_eq g u v =
+ let g, arcu = safe_repr g u in
+ let _, arcv = safe_repr g v in
+ arcu == arcv
type check_function = universes -> universe -> universe -> bool
@@ -310,10 +335,10 @@ let rec check_eq g u v =
| _ -> anomaly "check_eq" (* not complete! (Atom(u) = Max([u],[]) *)
let compare_greater g strict u v =
- let g = declare_univ u g in
- let g = declare_univ v g in
- if not strict && compare_eq g v Set then true else
- match compare g v u with
+ let g, arcu = safe_repr g u in
+ let g, arcv = safe_repr g v in
+ if not strict && arcv == snd (safe_repr g UniverseLevel.Set) then true else
+ match compare g arcv arcu with
| (EQ|LE) -> not strict
| LT -> true
| NLE -> false
@@ -323,44 +348,50 @@ let compare_greater g strict u v =
ppnl(str (if b then if strict then ">" else ">=" else "NOT >="));
b
*)
-let rec check_greater g strict u v =
+let check_geq g u v =
match u, v with
- | Atom ul, Atom vl -> compare_greater g strict ul vl
+ | Atom ul, Atom vl -> compare_greater g false ul vl
| Atom ul, Max(le,lt) ->
- List.for_all (fun vl -> compare_greater g strict ul vl) le &&
+ List.for_all (fun vl -> compare_greater g false ul vl) le &&
List.for_all (fun vl -> compare_greater g true ul vl) lt
| _ -> anomaly "check_greater"
-let check_geq g = check_greater g false
+(** Enforcing new constraints : [setlt], [setleq], [merge], [merge_disc] *)
-(* setlt : universe_level -> universe_level -> unit *)
+(* setlt : UniverseLevel.t -> UniverseLevel.t -> unit *)
(* forces u > v *)
-let setlt g u v =
- let arcu = repr g u in
- enter_arc {arcu with lt=v::arcu.lt} g
+(* this is normally an update of u in g rather than a creation. *)
+let setlt g arcu arcv =
+ let arcu' = {arcu with lt=arcv.univ::arcu.lt} in
+ enter_arc arcu' g, arcu'
(* checks that non-redundant *)
-let setlt_if g u v = match compare g u v with
- | LT -> g
- | _ -> setlt g u v
+let setlt_if (g,arcu) v =
+ let arcv = repr g v in
+ match compare g arcu arcv with
+ | LT -> g, arcu
+ | _ -> setlt g arcu arcv
-(* setleq : universe_level -> universe_level -> unit *)
+(* setleq : UniverseLevel.t -> UniverseLevel.t -> unit *)
(* forces u >= v *)
-let setleq g u v =
- let arcu = repr g u in
- enter_arc {arcu with le=v::arcu.le} g
+(* this is normally an update of u in g rather than a creation. *)
+let setleq g arcu arcv =
+ let arcu' = {arcu with le=arcv.univ::arcu.le} in
+ enter_arc arcu' g, arcu'
(* checks that non-redundant *)
-let setleq_if g u v = match compare g u v with
- | NLE -> setleq g u v
- | _ -> g
+let setleq_if (g,arcu) v =
+ let arcv = repr g v in
+ match compare g arcu arcv with
+ | NLE -> setleq g arcu arcv
+ | _ -> g, arcu
-(* merge : universe_level -> universe_level -> unit *)
+(* merge : UniverseLevel.t -> UniverseLevel.t -> unit *)
(* we assume compare(u,v) = LE *)
(* merge u v forces u ~ v with repr u as canonical repr *)
-let merge g u v =
- match between g u (repr g v) with
+let merge g arcu arcv =
+ match between g arcu arcv with
| arcu::v -> (* arcu is chosen as canonical and all others (v) are *)
(* redirected to it *)
let redirect (g,w,w') arcv =
@@ -368,87 +399,84 @@ let merge g u v =
(g',list_unionq arcv.lt w,arcv.le@w')
in
let (g',w,w') = List.fold_left redirect (g,[],[]) v in
- let g'' = List.fold_left (fun g -> setlt_if g arcu.univ) g' w in
- let g''' = List.fold_left (fun g -> setleq_if g arcu.univ) g'' w' in
- g'''
+ let g_arcu = (g',arcu) in
+ let g_arcu = List.fold_left setlt_if g_arcu w in
+ let g_arcu = List.fold_left setleq_if g_arcu w' in
+ fst g_arcu
| [] -> anomaly "Univ.between"
-(* merge_disc : universe_level -> universe_level -> unit *)
+(* merge_disc : UniverseLevel.t -> UniverseLevel.t -> unit *)
(* we assume compare(u,v) = compare(v,u) = NLE *)
(* merge_disc u v forces u ~ v with repr u as canonical repr *)
-let merge_disc g u v =
- let arcu = repr g u in
- let arcv = repr g v in
+let merge_disc g arcu arcv =
let g' = enter_equiv_arc arcv.univ arcu.univ g in
- let g'' = List.fold_left (fun g -> setlt_if g arcu.univ) g' arcv.lt in
- let g''' = List.fold_left (fun g -> setleq_if g arcu.univ) g'' arcv.le in
- g'''
+ let g_arcu = (g',arcu) in
+ let g_arcu = List.fold_left setlt_if g_arcu arcv.lt in
+ let g_arcu = List.fold_left setleq_if g_arcu arcv.le in
+ fst g_arcu
(* Universe inconsistency: error raised when trying to enforce a relation
that would create a cycle in the graph of universes. *)
-type order_request = Lt | Le | Eq
+type constraint_type = Lt | Le | Eq
-exception UniverseInconsistency of order_request * universe * universe
+exception UniverseInconsistency of constraint_type * universe * universe
let error_inconsistency o u v = raise (UniverseInconsistency (o,Atom u,Atom v))
-(* enforce_univ_leq : universe_level -> universe_level -> unit *)
+(* enforce_univ_leq : UniverseLevel.t -> UniverseLevel.t -> unit *)
(* enforce_univ_leq u v will force u<=v if possible, will fail otherwise *)
let enforce_univ_leq u v g =
- let g = declare_univ u g in
- let g = declare_univ v g in
- match compare g u v with
+ let g,arcu = safe_repr g u in
+ let g,arcv = safe_repr g v in
+ match compare g arcu arcv with
| NLE ->
- (match compare g v u with
+ (match compare g arcv arcu with
| LT -> error_inconsistency Le u v
- | LE -> merge g v u
- | NLE -> setleq g u v
+ | LE -> merge g arcv arcu
+ | NLE -> fst (setleq g arcu arcv)
| EQ -> anomaly "Univ.compare")
| _ -> g
-(* enforc_univ_eq : universe_level -> universe_level -> unit *)
+(* enforc_univ_eq : UniverseLevel.t -> UniverseLevel.t -> unit *)
(* enforc_univ_eq u v will force u=v if possible, will fail otherwise *)
let enforce_univ_eq u v g =
- let g = declare_univ u g in
- let g = declare_univ v g in
- match compare g u v with
+ let g,arcu = safe_repr g u in
+ let g,arcv = safe_repr g v in
+ match compare g arcu arcv with
| EQ -> g
| LT -> error_inconsistency Eq u v
- | LE -> merge g u v
+ | LE -> merge g arcu arcv
| NLE ->
- (match compare g v u with
+ (match compare g arcv arcu with
| LT -> error_inconsistency Eq u v
- | LE -> merge g v u
- | NLE -> merge_disc g u v
+ | LE -> merge g arcv arcu
+ | NLE -> merge_disc g arcu arcv
| EQ -> anomaly "Univ.compare")
(* enforce_univ_lt u v will force u<v if possible, will fail otherwise *)
let enforce_univ_lt u v g =
- let g = declare_univ u g in
- let g = declare_univ v g in
- match compare g u v with
+ let g,arcu = safe_repr g u in
+ let g,arcv = safe_repr g v in
+ match compare g arcu arcv with
| LT -> g
- | LE -> setlt g u v
+ | LE -> fst (setlt g arcu arcv)
| EQ -> error_inconsistency Lt u v
| NLE ->
- (match compare g v u with
- | NLE -> setlt g u v
+ (match compare g arcv arcu with
+ | NLE -> fst (setlt g arcu arcv)
| _ -> error_inconsistency Lt u v)
(* Constraints and sets of consrtaints. *)
-type constraint_type = Lt | Leq | Eq
-
-type univ_constraint = universe_level * constraint_type * universe_level
+type univ_constraint = UniverseLevel.t * constraint_type * UniverseLevel.t
let enforce_constraint cst g =
match cst with
| (u,Lt,v) -> enforce_univ_lt u v g
- | (u,Leq,v) -> enforce_univ_leq u v g
+ | (u,Le,v) -> enforce_univ_leq u v g
| (u,Eq,v) -> enforce_univ_eq u v g
-
module Constraint = Set.Make(
struct
type t = univ_constraint
@@ -457,11 +485,16 @@ module Constraint = Set.Make(
type constraints = Constraint.t
+let empty_constraint = Constraint.empty
+let is_empty_constraint = Constraint.is_empty
+
+let union_constraints = Constraint.union
+
type constraint_function =
universe -> universe -> constraints -> constraints
let constraint_add_leq v u c =
- if v = Set then c else Constraint.add (v,Leq,u) c
+ if v = UniverseLevel.Set then c else Constraint.add (v,Le,u) c
let enforce_geq u v c =
match u, v with
@@ -479,13 +512,207 @@ let enforce_eq u v c =
let merge_constraints c g =
Constraint.fold enforce_constraint c g
+(* Normalization *)
+
+let lookup_level u g =
+ try Some (UniverseLMap.find u g) with Not_found -> None
+
+(** [normalize_universes g] returns a graph where all edges point
+ directly to the canonical representent of their target. The output
+ graph should be equivalent to the input graph from a logical point
+ of view, but optimized. We maintain the invariant that the key of
+ a [Canonical] element is its own name, by keeping [Equiv] edges
+ (see the assertion)... I (Stéphane Glondu) am not sure if this
+ plays a role in the rest of the module. *)
+let normalize_universes g =
+ let rec visit u arc cache = match lookup_level u cache with
+ | Some x -> x, cache
+ | None -> match Lazy.force arc with
+ | None ->
+ u, UniverseLMap.add u u cache
+ | Some (Canonical {univ=v; lt=_; le=_}) ->
+ v, UniverseLMap.add u v cache
+ | Some (Equiv v) ->
+ let v, cache = visit v (lazy (lookup_level v g)) cache in
+ v, UniverseLMap.add u v cache
+ in
+ let cache = UniverseLMap.fold
+ (fun u arc cache -> snd (visit u (Lazy.lazy_from_val (Some arc)) cache))
+ g UniverseLMap.empty
+ in
+ let repr x = UniverseLMap.find x cache in
+ let lrepr us = List.fold_left
+ (fun e x -> UniverseLSet.add (repr x) e) UniverseLSet.empty us
+ in
+ let canonicalize u = function
+ | Equiv _ -> Equiv (repr u)
+ | Canonical {univ=v; lt=lt; le=le} ->
+ assert (u == v);
+ (* avoid duplicates and self-loops *)
+ let lt = lrepr lt and le = lrepr le in
+ let le = UniverseLSet.filter
+ (fun x -> x != u && not (UniverseLSet.mem x lt)) le
+ in
+ UniverseLSet.iter (fun x -> assert (x != u)) lt;
+ Canonical {
+ univ = v;
+ lt = UniverseLSet.elements lt;
+ le = UniverseLSet.elements le;
+ }
+ in
+ UniverseLMap.mapi canonicalize g
+
+(** [check_sorted g sorted]: [g] being a universe graph, [sorted]
+ being a map to levels, checks that all constraints in [g] are
+ satisfied in [sorted]. *)
+let check_sorted g sorted =
+ let get u = try UniverseLMap.find u sorted with
+ | Not_found -> assert false
+ in UniverseLMap.iter (fun u arc -> let lu = get u in match arc with
+ | Equiv v -> assert (lu = get v)
+ | Canonical {univ=u'; lt=lt; le=le} ->
+ assert (u == u');
+ List.iter (fun v -> assert (lu <= get v)) le;
+ List.iter (fun v -> assert (lu < get v)) lt) g
+
+(**
+ Bellman-Ford algorithm with a few customizations:
+ - [weight(eq|le) = 0], [weight(lt) = -1]
+ - a [le] edge is initially added from [bottom] to all other
+ vertices, and [bottom] is used as the source vertex
+*)
+let bellman_ford bottom g =
+ assert (lookup_level bottom g = None);
+ let ( << ) a b = match a, b with
+ | _, None -> true
+ | None, _ -> false
+ | Some x, Some y -> x < y
+ and ( ++ ) a y = match a with
+ | None -> None
+ | Some x -> Some (x-y)
+ and push u x m = match x with
+ | None -> m
+ | Some y -> UniverseLMap.add u y m
+ in
+ let relax u v uv distances =
+ let x = lookup_level u distances ++ uv in
+ if x << lookup_level v distances then push v x distances
+ else distances
+ in
+ let init = UniverseLMap.add bottom 0 UniverseLMap.empty in
+ let vertices = UniverseLMap.fold (fun u arc res ->
+ let res = UniverseLSet.add u res in
+ match arc with
+ | Equiv e -> UniverseLSet.add e res
+ | Canonical {univ=univ; lt=lt; le=le} ->
+ assert (u == univ);
+ let add res v = UniverseLSet.add v res in
+ let res = List.fold_left add res le in
+ let res = List.fold_left add res lt in
+ res) g UniverseLSet.empty
+ in
+ let g =
+ let node = Canonical {
+ univ = bottom;
+ lt = [];
+ le = UniverseLSet.elements vertices
+ } in UniverseLMap.add bottom node g
+ in
+ let rec iter count accu =
+ if count <= 0 then
+ accu
+ else
+ let accu = UniverseLMap.fold (fun u arc res -> match arc with
+ | Equiv e -> relax e u 0 (relax u e 0 res)
+ | Canonical {univ=univ; lt=lt; le=le} ->
+ assert (u == univ);
+ let res = List.fold_left (fun res v -> relax u v 0 res) res le in
+ let res = List.fold_left (fun res v -> relax u v 1 res) res lt in
+ res) g accu
+ in iter (count-1) accu
+ in
+ let distances = iter (UniverseLSet.cardinal vertices) init in
+ let () = UniverseLMap.iter (fun u arc ->
+ let lu = lookup_level u distances in match arc with
+ | Equiv v ->
+ let lv = lookup_level v distances in
+ assert (not (lu << lv) && not (lv << lu))
+ | Canonical {univ=univ; lt=lt; le=le} ->
+ assert (u == univ);
+ List.iter (fun v -> assert (not (lu ++ 0 << lookup_level v distances))) le;
+ List.iter (fun v -> assert (not (lu ++ 1 << lookup_level v distances))) lt) g
+ in distances
+
+(** [sort_universes g] builds a map from universes in [g] to natural
+ numbers. It outputs a graph containing equivalence edges from each
+ level appearing in [g] to [Type.n], and [lt] edges between the
+ [Type.n]s. The output graph should imply the input graph (and the
+ implication will be strict most of the time), but is not
+ necessarily minimal. Note: the result is unspecified if the input
+ graph already contains [Type.n] nodes (calling a module Type is
+ probably a bad idea anyway). *)
+let sort_universes orig =
+ let mp = Names.make_dirpath [Names.id_of_string "Type"] in
+ let rec make_level accu g i =
+ let type0 = UniverseLevel.Level (mp, i) in
+ let distances = bellman_ford type0 g in
+ let accu, continue = UniverseLMap.fold (fun u x (accu, continue) ->
+ let continue = continue || x < 0 in
+ let accu =
+ if x = 0 && u != type0 then UniverseLMap.add u i accu
+ else accu
+ in accu, continue) distances (accu, false)
+ in
+ let filter x = not (UniverseLMap.mem x accu) in
+ let push g u =
+ if UniverseLMap.mem u g then g else UniverseLMap.add u (Equiv u) g
+ in
+ let g = UniverseLMap.fold (fun u arc res -> match arc with
+ | Equiv v as x ->
+ begin match filter u, filter v with
+ | true, true -> UniverseLMap.add u x res
+ | true, false -> push res u
+ | false, true -> push res v
+ | false, false -> res
+ end
+ | Canonical {univ=v; lt=lt; le=le} ->
+ assert (u == v);
+ if filter u then
+ let lt = List.filter filter lt in
+ let le = List.filter filter le in
+ UniverseLMap.add u (Canonical {univ=u; lt=lt; le=le}) res
+ else
+ let res = List.fold_left (fun g u -> if filter u then push g u else g) res lt in
+ let res = List.fold_left (fun g u -> if filter u then push g u else g) res le in
+ res) g UniverseLMap.empty
+ in
+ if continue then make_level accu g (i+1) else i, accu
+ in
+ let max, levels = make_level UniverseLMap.empty orig 0 in
+ (* defensively check that the result makes sense *)
+ check_sorted orig levels;
+ let types = Array.init (max+1) (fun x -> UniverseLevel.Level (mp, x)) in
+ let g = UniverseLMap.map (fun x -> Equiv types.(x)) levels in
+ let g =
+ let rec aux i g =
+ if i < max then
+ let u = types.(i) in
+ let g = UniverseLMap.add u (Canonical {
+ univ = u;
+ le = [];
+ lt = [types.(i+1)]
+ }) g in aux (i+1) g
+ else g
+ in aux 0 g
+ in g
+
(**********************************************************************)
(* Tools for sort-polymorphic inductive types *)
(* Temporary inductive type levels *)
let fresh_level =
- let n = ref 0 in fun () -> incr n; Level (Names.make_dirpath [],!n)
+ let n = ref 0 in fun () -> incr n; UniverseLevel.Level (Names.make_dirpath [],!n)
let fresh_local_univ () = Atom (fresh_level ())
@@ -559,16 +786,6 @@ let no_upper_constraints u cst =
(* Pretty-printing *)
-let num_universes g =
- UniverseLMap.fold (fun _ _ -> succ) g 0
-
-let num_edges g =
- let reln_len = function
- | Equiv _ -> 1
- | Canonical {lt=lt;le=le} -> List.length lt + List.length le
- in
- UniverseLMap.fold (fun _ a n -> n + (reln_len a)) g 0
-
let pr_arc = function
| _, Canonical {univ=u; lt=[]; le=[]} ->
mt ()
@@ -590,7 +807,7 @@ let pr_constraints c =
Constraint.fold (fun (u1,op,u2) pp_std ->
let op_str = match op with
| Lt -> " < "
- | Leq -> " <= "
+ | Le -> " <= "
| Eq -> " = "
in pp_std ++ pr_uni_level u1 ++ str op_str ++
pr_uni_level u2 ++ fnl () ) c (str "")
@@ -600,37 +817,40 @@ let pr_constraints c =
let dump_universes output g =
let dump_arc u = function
| Canonical {univ=u; lt=lt; le=le} ->
- let u_str = string_of_univ_level u in
- List.iter
- (fun v ->
- Printf.fprintf output "%s < %s ;\n" u_str
- (string_of_univ_level v))
- lt;
- List.iter
- (fun v ->
- Printf.fprintf output "%s <= %s ;\n" u_str
- (string_of_univ_level v))
- le
+ let u_str = UniverseLevel.to_string u in
+ List.iter (fun v -> output Lt u_str (UniverseLevel.to_string v)) lt;
+ List.iter (fun v -> output Le u_str (UniverseLevel.to_string v)) le
| Equiv v ->
- Printf.fprintf output "%s = %s ;\n"
- (string_of_univ_level u) (string_of_univ_level v)
+ output Eq (UniverseLevel.to_string u) (UniverseLevel.to_string v)
in
UniverseLMap.iter dump_arc g
(* Hash-consing *)
+module Hunivlevel =
+ Hashcons.Make(
+ struct
+ type t = universe_level
+ type u = Names.dir_path -> Names.dir_path
+ let hash_sub hdir = function
+ | UniverseLevel.Set -> UniverseLevel.Set
+ | UniverseLevel.Level (d,n) -> UniverseLevel.Level (hdir d,n)
+ let equal l1 l2 = match l1,l2 with
+ | UniverseLevel.Set, UniverseLevel.Set -> true
+ | UniverseLevel.Level (d,n), UniverseLevel.Level (d',n') ->
+ n == n' && d == d'
+ | _ -> false
+ let hash = Hashtbl.hash
+ end)
+
module Huniv =
Hashcons.Make(
struct
type t = universe
- type u = Names.dir_path -> Names.dir_path
- let hash_aux hdir = function
- | Set -> Set
- | Level (d,n) -> Level (hdir d,n)
+ type u = universe_level -> universe_level
let hash_sub hdir = function
- | Atom u -> Atom (hash_aux hdir u)
- | Max (gel,gtl) ->
- Max (List.map (hash_aux hdir) gel, List.map (hash_aux hdir) gtl)
+ | Atom u -> Atom (hdir u)
+ | Max (gel,gtl) -> Max (List.map hdir gel, List.map hdir gtl)
let equal u v =
match u, v with
| Atom u, Atom v -> u == v
@@ -641,7 +861,33 @@ module Huniv =
let hash = Hashtbl.hash
end)
-let hcons1_univ u =
- let _,_,hdir,_,_,_ = Names.hcons_names() in
- Hashcons.simple_hcons Huniv.f hdir u
+let hcons_univlevel = Hashcons.simple_hcons Hunivlevel.f Names.hcons_dirpath
+let hcons_univ = Hashcons.simple_hcons Huniv.f hcons_univlevel
+
+module Hconstraint =
+ Hashcons.Make(
+ struct
+ type t = univ_constraint
+ type u = universe_level -> universe_level
+ let hash_sub hul (l1,k,l2) = (hul l1, k, hul l2)
+ let equal (l1,k,l2) (l1',k',l2') =
+ l1 == l1' && k = k' && l2 == l2'
+ let hash = Hashtbl.hash
+ end)
+
+module Hconstraints =
+ Hashcons.Make(
+ struct
+ type t = constraints
+ type u = univ_constraint -> univ_constraint
+ let hash_sub huc s =
+ Constraint.fold (fun x -> Constraint.add (huc x)) s Constraint.empty
+ let equal s s' =
+ list_for_all2eq (==)
+ (Constraint.elements s)
+ (Constraint.elements s')
+ let hash = Hashtbl.hash
+ end)
+let hcons_constraint = Hashcons.simple_hcons Hconstraint.f hcons_univlevel
+let hcons_constraints = Hashcons.simple_hcons Hconstraints.f hcons_constraint
diff --git a/kernel/univ.mli b/kernel/univ.mli
index 4cb6dec1..8b3f6291 100644
--- a/kernel/univ.mli
+++ b/kernel/univ.mli
@@ -1,37 +1,43 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: univ.mli 14641 2011-11-06 11:59:10Z herbelin $ i*)
-
-(* Universes. *)
+(** Universes. *)
+type universe_level
type universe
-(* The universes hierarchy: Type 0- = Prop <= Type 0 = Set <= Type 1 <= ... *)
-(* Typing of universes: Type 0-, Type 0 : Type 1; Type i : Type (i+1) if i>0 *)
+module UniverseLSet : Set.S with type elt = universe_level
+
+(** The universes hierarchy: Type 0- = Prop <= Type 0 = Set <= Type 1 <= ...
+ Typing of universes: Type 0-, Type 0 : Type 1; Type i : Type (i+1) if i>0 *)
-val type0m_univ : universe (* image of Prop in the universes hierarchy *)
-val type0_univ : universe (* image of Set in the universes hierarchy *)
-val type1_univ : universe (* the universe of the type of Prop/Set *)
+val type0m_univ : universe (** image of Prop in the universes hierarchy *)
+val type0_univ : universe (** image of Set in the universes hierarchy *)
+val type1_univ : universe (** the universe of the type of Prop/Set *)
+val make_universe_level : Names.dir_path * int -> universe_level
+val make_universe : universe_level -> universe
val make_univ : Names.dir_path * int -> universe
val is_type0_univ : universe -> bool
val is_type0m_univ : universe -> bool
val is_univ_variable : universe -> bool
-(* The type of a universe *)
+val universe_level : universe -> universe_level option
+val compare_levels : universe_level -> universe_level -> int
+
+(** The type of a universe *)
val super : universe -> universe
-(* The max of 2 universes *)
+(** The max of 2 universes *)
val sup : universe -> universe -> universe
-(*s Graphs of universes. *)
+(** {6 Graphs of universes. } *)
type universes
@@ -39,32 +45,39 @@ type check_function = universes -> universe -> universe -> bool
val check_geq : check_function
val check_eq : check_function
-(* The empty graph of universes *)
+(** The empty graph of universes *)
val initial_universes : universes
+val is_initial_universes : universes -> bool
-(*s Constraints. *)
+(** {6 Constraints. } *)
-module Constraint : Set.S
+type constraints
-type constraints = Constraint.t
+val empty_constraint : constraints
+val union_constraints : constraints -> constraints -> constraints
+
+val is_empty_constraint : constraints -> bool
type constraint_function = universe -> universe -> constraints -> constraints
val enforce_geq : constraint_function
val enforce_eq : constraint_function
-(*s Merge of constraints in a universes graph.
+(** {6 ... } *)
+(** Merge of constraints in a universes graph.
The function [merge_constraints] merges a set of constraints in a given
universes graph. It raises the exception [UniverseInconsistency] if the
constraints are not satisfiable. *)
-type order_request = Lt | Le | Eq
+type constraint_type = Lt | Le | Eq
-exception UniverseInconsistency of order_request * universe * universe
+exception UniverseInconsistency of constraint_type * universe * universe
val merge_constraints : constraints -> universes -> universes
+val normalize_universes : universes -> universes
+val sort_universes : universes -> universes
-(*s Support for sort-polymorphic inductive types *)
+(** {6 Support for sort-polymorphic inductive types } *)
val fresh_local_univ : unit -> universe
@@ -78,14 +91,21 @@ val subst_large_constraints :
val no_upper_constraints : universe -> constraints -> bool
-(*s Pretty-printing of universes. *)
+(** {6 Pretty-printing of universes. } *)
+val pr_uni_level : universe_level -> Pp.std_ppcmds
val pr_uni : universe -> Pp.std_ppcmds
val pr_universes : universes -> Pp.std_ppcmds
val pr_constraints : constraints -> Pp.std_ppcmds
-(*s Dumping to a file *)
+(** {6 Dumping to a file } *)
+
+val dump_universes :
+ (constraint_type -> string -> string -> unit) ->
+ universes -> unit
-val dump_universes : out_channel -> universes -> unit
+(** {6 Hash-consing } *)
-val hcons1_univ : universe -> universe
+val hcons_univlevel : universe_level -> universe_level
+val hcons_univ : universe -> universe
+val hcons_constraints : constraints -> constraints
diff --git a/kernel/vconv.ml b/kernel/vconv.ml
index a35d1d88..4d0edc68 100644
--- a/kernel/vconv.ml
+++ b/kernel/vconv.ml
@@ -74,6 +74,8 @@ and conv_whd pb k whd1 whd2 cu =
else raise NotConvertible
| Vatom_stk(a1,stk1), Vatom_stk(a2,stk2) ->
conv_atom pb k a1 stk1 a2 stk2 cu
+ | Vfun _, _ | _, Vfun _ ->
+ conv_val CONV (k+1) (eta_whd k whd1) (eta_whd k whd2) cu
| _, Vatom_stk(Aiddef(_,v),stk) ->
conv_whd pb k whd1 (force_whd v stk) cu
| Vatom_stk(Aiddef(_,v),stk), _ ->
@@ -98,7 +100,7 @@ and conv_atom pb k a1 stk1 a2 stk2 cu =
conv_stack k stk1 stk2 cu
else raise NotConvertible
with NotConvertible ->
- if oracle_order ik1 ik2 then
+ if oracle_order false ik1 ik2 then
conv_whd pb k (whd_stack v1 stk1) (Vatom_stk(a2,stk2)) cu
else conv_whd pb k (Vatom_stk(a1,stk1)) (whd_stack v2 stk2) cu
end
@@ -219,12 +221,12 @@ and conv_eq_vect vt1 vt2 cu =
let vconv pb env t1 t2 =
let cu =
- try conv_eq pb t1 t2 Constraint.empty
+ try conv_eq pb t1 t2 empty_constraint
with NotConvertible ->
infos := create_clos_infos betaiotazeta env;
let v1 = val_of_constr env t1 in
let v2 = val_of_constr env t2 in
- let cu = conv_val pb (nb_rel env) v1 v2 Constraint.empty in
+ let cu = conv_val pb (nb_rel env) v1 v2 empty_constraint in
cu
in cu
@@ -234,8 +236,8 @@ let use_vm = ref false
let set_use_vm b =
use_vm := b;
- if b then Reduction.set_default_conv vconv
- else Reduction.set_default_conv Reduction.conv_cmp
+ if b then Reduction.set_default_conv (fun cv_pb ?(l2r=false) -> vconv cv_pb)
+ else Reduction.set_default_conv (fun cv_pb ?(l2r=false) -> Reduction.conv_cmp cv_pb)
let use_vm _ = !use_vm
diff --git a/kernel/vconv.mli b/kernel/vconv.mli
index e23aaf79..2d65170c 100644
--- a/kernel/vconv.mli
+++ b/kernel/vconv.mli
@@ -1,20 +1,18 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i*)
open Names
open Term
open Environ
open Reduction
-(*i*)
-(***********************************************************************)
-(*s conversion functions *)
+(**********************************************************************
+ s conversion functions *)
val use_vm : unit -> bool
val set_use_vm : bool -> unit
val vconv : conv_pb -> types conversion_function
diff --git a/kernel/vm.ml b/kernel/vm.ml
index c24de162..86aed5d9 100644
--- a/kernel/vm.ml
+++ b/kernel/vm.ml
@@ -1,13 +1,11 @@
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2011 *)
+(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010 *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: vm.ml 14641 2011-11-06 11:59:10Z herbelin $ *)
-
open Names
open Term
open Conv_oracle
@@ -462,7 +460,7 @@ let current_cofix vcf =
else find_cofix (pos+1)
else raise Not_found in
try find_cofix 0
- with _ -> assert false
+ with Not_found -> assert false
let check_cofix vcf1 vcf2 =
(current_cofix vcf1 = current_cofix vcf2) &&
@@ -538,13 +536,8 @@ let branch_of_switch k sw =
Array.map eval_branch sw.sw_annot.rtbl
-(* Evaluation *)
-
-let is_accu v =
- let o = Obj.repr v in
- Obj.is_block o && Obj.tag o = accu_tag &&
- fun_code v == accumulate && Obj.tag (Obj.field o 1) < cofix_tag
+(* Evaluation *)
let rec whd_stack v stk =
match stk with
@@ -594,6 +587,55 @@ let rec force_whd v stk =
| res -> res
+let rec eta_stack a stk v =
+ match stk with
+ | [] -> apply_vstack a [|v|]
+ | Zapp args :: stk -> eta_stack (apply_arguments a args) stk v
+ | Zfix(f,args) :: stk ->
+ let a,stk =
+ match stk with
+ | Zapp args' :: stk ->
+ push_ra stop;
+ push_arguments args';
+ push_val a;
+ push_arguments args;
+ let a =
+ interprete (fun_code f) (Obj.magic f) (Obj.magic f)
+ (nargs args+ nargs args') in
+ a, stk
+ | _ ->
+ push_ra stop;
+ push_val a;
+ push_arguments args;
+ let a =
+ interprete (fun_code f) (Obj.magic f) (Obj.magic f)
+ (nargs args) in
+ a, stk in
+ eta_stack a stk v
+ | Zswitch sw :: stk ->
+ eta_stack (apply_switch sw a) stk v
+
+let eta_whd k whd =
+ let v = val_of_rel k in
+ match whd with
+ | Vsort _ | Vprod _ | Vconstr_const _ | Vconstr_block _ -> assert false
+ | Vfun f -> body_of_vfun k f
+ | Vfix(f, None) ->
+ push_ra stop;
+ push_val v;
+ interprete (fun_code f) (Obj.magic f) (Obj.magic f) 0
+ | Vfix(f, Some args) ->
+ push_ra stop;
+ push_val v;
+ push_arguments args;
+ interprete (fun_code f) (Obj.magic f) (Obj.magic f) (nargs args)
+ | Vcofix(_,to_up,_) ->
+ push_ra stop;
+ push_val v;
+ interprete (fun_code to_up) (Obj.magic to_up) (Obj.magic to_up) 0
+ | Vatom_stk(a,stk) ->
+ eta_stack (val_of_atom a) stk v
-
+
+
diff --git a/kernel/vm.mli b/kernel/vm.mli
index 5ecc8d99..58228eb8 100644
--- a/kernel/vm.mli
+++ b/kernel/vm.mli
@@ -3,15 +3,18 @@ open Term
open Cbytecodes
open Cemitcodes
+(** Efficient Virtual Machine *)
val set_drawinstr : unit -> unit
val transp_values : unit -> bool
val set_transp_values : bool -> unit
-(* le code machine *)
+
+(** Machine code *)
+
type tcode
-(* Les valeurs ***********)
+(** Values *)
type vprod
type vfun
@@ -26,11 +29,11 @@ type atom =
| Aiddef of id_key * values
| Aind of inductive
-(* Les zippers *)
+(** Zippers *)
type zipper =
| Zapp of arguments
- | Zfix of vfix*arguments (* Peut-etre vide *)
+ | Zfix of vfix * arguments (** might be empty *)
| Zswitch of vswitch
type stack = zipper list
@@ -48,6 +51,7 @@ type whd =
| Vatom_stk of atom * stack
(** Constructors *)
+
val val_of_str_const : structured_constant -> values
val val_of_rel : int -> values
@@ -62,45 +66,56 @@ val val_of_constant_def : int -> constant -> values -> values
external val_of_annot_switch : annot_switch -> values = "%identity"
(** Destructors *)
+
val whd_val : values -> whd
-(* Arguments *)
+(** Arguments *)
+
val nargs : arguments -> int
val arg : arguments -> int -> values
-(* Product *)
+(** Product *)
+
val dom : vprod -> values
val codom : vprod -> vfun
-(* Function *)
+(** Function *)
+
val body_of_vfun : int -> vfun -> values
val decompose_vfun2 : int -> vfun -> vfun -> int * values * values
-(* Fix *)
+(** Fix *)
+
val current_fix : vfix -> int
val check_fix : vfix -> vfix -> bool
val rec_args : vfix -> int array
val reduce_fix : int -> vfix -> vfun array * values array
- (* bodies , types *)
+ (** bodies , types *)
+
+(** CoFix *)
-(* CoFix *)
val current_cofix : vcofix -> int
val check_cofix : vcofix -> vcofix -> bool
val reduce_cofix : int -> vcofix -> values array * values array
- (* bodies , types *)
-(* Block *)
+ (** bodies , types *)
+
+(** Block *)
+
val btag : vblock -> int
val bsize : vblock -> int
val bfield : vblock -> int -> values
-(* Switch *)
+(** Switch *)
+
val check_switch : vswitch -> vswitch -> bool
val case_info : vswitch -> case_info
val type_of_switch : vswitch -> values
val branch_of_switch : int -> vswitch -> (int * values) array
-(* Evaluation *)
+(** Evaluation *)
+
val whd_stack : values -> stack -> whd
val force_whd : values -> stack -> whd
+val eta_whd : int -> whd -> values