diff options
Diffstat (limited to 'kernel')
64 files changed, 3727 insertions, 3202 deletions
diff --git a/kernel/byterun/coq_instruct.h b/kernel/byterun/coq_instruct.h index 8a45e973..e224a108 100644 --- a/kernel/byterun/coq_instruct.h +++ b/kernel/byterun/coq_instruct.h @@ -11,6 +11,10 @@ #ifndef _COQ_INSTRUCT_ #define _COQ_INSTRUCT_ +/* Nota: this list of instructions is parsed to produce derived files */ +/* coq_jumptbl.h and copcodes.ml. Instructions should be uppercase */ +/* and alone on lines starting by two spaces. */ + enum instructions { ACC0, ACC1, ACC2, ACC3, ACC4, ACC5, ACC6, ACC7, ACC, PUSH, diff --git a/kernel/byterun/int64_emul.h b/kernel/byterun/int64_emul.h index 0a61ad79..04e38656 100644 --- a/kernel/byterun/int64_emul.h +++ b/kernel/byterun/int64_emul.h @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: int64_emul.h 10739 2008-04-01 14:45:20Z herbelin $ */ +/* $Id$ */ /* 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..f5bef4a6 100644 --- a/kernel/byterun/int64_native.h +++ b/kernel/byterun/int64_native.h @@ -11,7 +11,7 @@ /* */ /***********************************************************************/ -/* $Id: int64_native.h 10739 2008-04-01 14:45:20Z herbelin $ */ +/* $Id$ */ /* Wrapper macros around native 64-bit integer arithmetic, so that it has the same interface as the software emulation diff --git a/kernel/byterun/libcoqrun.clib b/kernel/byterun/libcoqrun.clib new file mode 100644 index 00000000..c06e4086 --- /dev/null +++ b/kernel/byterun/libcoqrun.clib @@ -0,0 +1,4 @@ +coq_fix_code.o +coq_memory.o +coq_values.o +coq_interp.o diff --git a/kernel/cbytecodes.ml b/kernel/cbytecodes.ml index ceba6e82..f4d0bb2b 100644 --- a/kernel/cbytecodes.ml +++ b/kernel/cbytecodes.ml @@ -1,7 +1,7 @@ open Names open Term -type tag = int +type tag = int let id_tag = 0 let iddef_tag = 1 @@ -14,22 +14,22 @@ let cofix_evaluated_tag = 6 type structured_constant = | Const_sorts of sorts | Const_ind of inductive - | Const_b0 of tag + | Const_b0 of tag | Const_bn of tag * structured_constant array -type reloc_table = (tag * int) array +type reloc_table = (tag * int) array -type annot_switch = +type annot_switch = {ci : case_info; rtbl : reloc_table; tailcall : bool} - -module Label = + +module Label = struct type t = int let no = -1 let counter = ref no let create () = incr counter; !counter - let reset_label_counter () = counter := no + let reset_label_counter () = counter := no end @@ -49,24 +49,24 @@ type instruction = | 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 + | Kclosurerec of int * int * Label.t array * Label.t array (* nb fv, init, lbl types, lbl bodies *) - | Kclosurecofix of int * int * Label.t array * Label.t array + | Kclosurecofix of int * int * Label.t array * Label.t array (* nb fv, init, lbl types, lbl bodies *) | Kgetglobal of constant | Kconst of structured_constant | Kmakeblock of int * tag (* size, tag *) - | Kmakeprod + | Kmakeprod | Kmakeswitchblock of Label.t * Label.t * annot_switch * int | Kswitch of Label.t array * Label.t array (* consts,blocks *) - | Kpushfields of int + | 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 *) - | Kaddint31 (* adds the int31 in the accu + | 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 *) @@ -77,10 +77,10 @@ type instruction = | Kmulcint31 (* multiplication, result in two int31, for exact computation *) | Kdiv21int31 (* divides a double size integer - (represented by an int31 in the - accumulator and one on the top of + (represented by an int31 in the + accumulator and one on the top of the stack) by an int31. The result - is a pair of the quotient and the + is a pair of the quotient and the rest. If the divisor is 0, it returns 0. *) @@ -90,11 +90,11 @@ type instruction = cycling. Takes 3 int31 i j and s, and returns x*2^s+y/(2^(31-s) *) | Kcompareint31 (* unsigned comparison of int31 - cf COMPAREINT31 in + 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 + | 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 *) @@ -118,19 +118,19 @@ exception NotClosed type vm_env = { size : int; (* longueur de la liste [n] *) fv_rev : fv_elem list (* [fvn; ... ;fv1] *) - } - - -type comp_env = { + } + + +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 *) - offset : int; - in_env : vm_env ref - } + offset : int; + in_env : vm_env ref + } @@ -176,7 +176,7 @@ let rec instruction ppf = function | Kmakeprod -> fprintf ppf "\tmakeprod" | Kmakeswitchblock(lblt,lbls,_,sz) -> fprintf ppf "\tmakeswitchblock %i, %i, %i" lblt lbls sz - | Kswitch(lblc,lblb) -> + | Kswitch(lblc,lblb) -> fprintf ppf "\tswitch"; Array.iter (fun lbl -> fprintf ppf " %i" lbl) lblc; Array.iter (fun lbl -> fprintf ppf " %i" lbl) lblb; @@ -185,7 +185,7 @@ let rec instruction ppf = function | Kfield n -> fprintf ppf "\tgetfield %i" n | Kstop -> fprintf ppf "\tstop" | Ksequence (c1,c2) -> - fprintf ppf "%a@ %a" instruction_list c1 instruction_list c2 + fprintf ppf "%a@ %a" instruction_list c1 instruction_list c2 (* spiwack *) | Kbranch lbl -> fprintf ppf "\tbranch %i" lbl | Kaddint31 -> fprintf ppf "\taddint31" @@ -218,9 +218,9 @@ and instruction_list ppf = function fprintf ppf "%a@ %a" instruction instr instruction_list il -(*spiwack: moved this type in this file because I needed it for +(*spiwack: moved this type in this file because I needed it for retroknowledge which can't depend from cbytegen *) -type block = +type block = | Bconstr of constr | Bstrconst of structured_constant | Bmakeblock of int * block array @@ -228,10 +228,10 @@ type block = (* tag , nparams, arity *) | Bspecial of (comp_env -> block array -> int -> bytecodes -> bytecodes) * block array (* spiwack: compilation given by a function *) - (* 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 *) - + let draw_instr c = fprintf std_formatter "@[<v 0>%a@]" instruction_list c diff --git a/kernel/cbytecodes.mli b/kernel/cbytecodes.mli index c24b5a53..f4dc0b14 100644 --- a/kernel/cbytecodes.mli +++ b/kernel/cbytecodes.mli @@ -1,7 +1,7 @@ open Names open Term -type tag = int +type tag = int val id_tag : tag val iddef_tag : tag @@ -14,21 +14,21 @@ val cofix_evaluated_tag : tag type structured_constant = | Const_sorts of sorts | Const_ind of inductive - | Const_b0 of tag + | Const_b0 of tag | Const_bn of tag * structured_constant array -type reloc_table = (tag * int) array +type reloc_table = (tag * int) array -type annot_switch = +type annot_switch = {ci : case_info; rtbl : reloc_table; tailcall : bool} -module Label : +module Label : sig type t = int val no : t val create : unit -> t val reset_label_counter : unit -> unit - end + end type instruction = | Klabel of Label.t @@ -46,24 +46,24 @@ type instruction = | 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 + | Kclosurerec of int * int * Label.t array * Label.t array (* nb fv, init, lbl types, lbl bodies *) - | Kclosurecofix of int * int * Label.t array * Label.t array + | Kclosurecofix of int * int * Label.t array * Label.t array (* nb fv, init, lbl types, lbl bodies *) | Kgetglobal of constant | Kconst of structured_constant | Kmakeblock of int * tag (* size, tag *) - | Kmakeprod + | Kmakeprod | Kmakeswitchblock of Label.t * Label.t * annot_switch * int | Kswitch of Label.t array * Label.t array (* consts,blocks *) - | Kpushfields of int + | 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 + | 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 *) @@ -74,10 +74,10 @@ type instruction = | Kmulcint31 (* multiplication, result in two int31, for exact computation *) | Kdiv21int31 (* divides a double size integer - (represented by an int31 in the - accumulator and one on the top of + (represented by an int31 in the + accumulator and one on the top of the stack) by an int31. The result - is a pair of the quotient and the + is a pair of the quotient and the rest. If the divisor is 0, it returns 0. *) @@ -87,11 +87,11 @@ type instruction = cycling. Takes 3 int31 i j and s, and returns x*2^s+y/(2^(31-s) *) | Kcompareint31 (* unsigned comparison of int31 - cf COMPAREINT31 in + 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 + | 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 *) @@ -116,31 +116,31 @@ exception NotClosed type vm_env = { size : int; (* longueur de la liste [n] *) fv_rev : fv_elem list (* [fvn; ... ;fv1] *) - } - - -type comp_env = { + } + + +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 *) - offset : int; - in_env : vm_env ref - } + offset : int; + in_env : vm_env ref + } val draw_instr : bytecodes -> unit (*spiwack: moved this here because I needed it for retroknowledge *) -type block = +type block = | Bconstr of constr | Bstrconst of structured_constant | Bmakeblock of int * block array | Bconstruct_app of int * int * int * block array (* 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 72113425..e7859962 100644 --- a/kernel/cbytegen.ml +++ b/kernel/cbytegen.ml @@ -80,71 +80,71 @@ open Pre_env (* [a1] est mis a jour : *) (* a1 = [A_t | accumulate | [Cfxe_t | fcofix1 | [cons_t | 1 | a1]] ] *) (* Le cycle est cree ... *) - + (* On conserve la fct de cofix pour la conversion *) - - + + let empty_fv = { size= 0; fv_rev = [] } - + let fv r = !(r.in_env) - -let empty_comp_env ()= - { nb_stack = 0; + +let empty_comp_env ()= + { nb_stack = 0; in_stack = []; nb_rec = 0; pos_rec = []; - offset = 0; + offset = 0; in_env = ref empty_fv; - } + } (*i Creation functions for comp_env *) let rec add_param n sz l = - if n = 0 then l else add_param (n - 1) sz (n+sz::l) - -let comp_env_fun arity = - { nb_stack = arity; + if n = 0 then l else add_param (n - 1) sz (n+sz::l) + +let comp_env_fun arity = + { nb_stack = arity; in_stack = add_param arity 0 []; nb_rec = 0; pos_rec = []; - offset = 1; - in_env = ref empty_fv - } - + offset = 1; + in_env = ref empty_fv + } -let comp_env_type rfv = - { nb_stack = 0; + +let comp_env_type rfv = + { nb_stack = 0; in_stack = []; nb_rec = 0; pos_rec = []; - offset = 1; - in_env = rfv + offset = 1; + in_env = rfv } - + let comp_env_fix ndef curr_pos arity rfv = let prec = ref [] in for i = ndef downto 1 do - prec := Koffsetclosure (2 * (ndef - curr_pos - i)) :: !prec + prec := Koffsetclosure (2 * (ndef - curr_pos - i)) :: !prec done; - { nb_stack = arity; + { nb_stack = arity; in_stack = add_param arity 0 []; - nb_rec = ndef; + nb_rec = ndef; pos_rec = !prec; offset = 2 * (ndef - curr_pos - 1)+1; - in_env = rfv - } + in_env = rfv + } let comp_env_cofix ndef arity rfv = let prec = ref [] in for i = 1 to ndef do prec := Kenvacc i :: !prec done; - { nb_stack = arity; + { nb_stack = arity; in_stack = add_param arity 0 []; - nb_rec = ndef; + nb_rec = ndef; pos_rec = !prec; offset = ndef+1; - in_env = rfv + in_env = rfv } (* [push_param ] ajoute les parametres de fonction dans la pile *) @@ -155,15 +155,15 @@ let push_param n sz r = (* [push_local e sz] ajoute une nouvelle variable dans la pile a la *) (* position [sz] *) -let push_local sz r = - { r with +let push_local sz r = + { r with nb_stack = r.nb_stack + 1; in_stack = (sz + 1) :: r.in_stack } (*i Compilation of variables *) -let find_at el l = +let find_at el l = let rec aux n = function | [] -> raise Not_found | hd :: tl -> if hd = el then n else aux (n+1) tl @@ -178,12 +178,12 @@ let pos_named id r = r.in_env := { size = pos+1; fv_rev = cid:: env.fv_rev}; Kenvacc (r.offset + pos) -let pos_rel i r sz = +let pos_rel i r sz = if i <= r.nb_stack then Kacc(sz - (List.nth r.in_stack (i-1))) else let i = i - r.nb_stack in - if i <= r.nb_rec then + if i <= r.nb_rec then try List.nth r.pos_rec (i-1) with _ -> assert false else @@ -223,7 +223,7 @@ let label_code = function when executed, branches to the continuation or performs what the continuation performs. We avoid generating branches to returns. *) (* spiwack: make_branch was only used once. Changed it back to the ZAM - one to match the appropriate semantics (old one avoided the + one to match the appropriate semantics (old one avoided the introduction of an unconditional branch operation, which seemed appropriate for the 31-bit integers' code). As a memory, I leave the former version in this comment. @@ -259,7 +259,7 @@ let rec is_tailcall = function | _ -> None (* Extention of the continuation *) - + (* Add a Kpop n instruction in front of a continuation *) let rec add_pop n = function | Kpop m :: cont -> add_pop (n+m) cont @@ -269,9 +269,9 @@ let rec add_pop n = function let add_grab arity lbl cont = if arity = 1 then Klabel lbl :: cont else Krestart :: Klabel lbl :: Kgrab (arity - 1) :: cont - + let add_grabrec rec_arg arity lbl cont = - if arity = 1 then + if arity = 1 then Klabel lbl :: Kgrabrec 0 :: Krestart :: cont else Krestart :: Klabel lbl :: Kgrabrec rec_arg :: @@ -288,11 +288,11 @@ let cont_cofix arity = Kacc 2; Kfield 1; Kfield 0; - Kmakeblock(2, cofix_evaluated_tag); + Kmakeblock(2, cofix_evaluated_tag); Kpush; (* stk = [Cfxe_t|fcofix|res]::res::ai::args::ra::...*) Kacc 2; Ksetfield 1; (* ai = [At|accumulate|[Cfxe_t|fcofix|res]|args] *) - (* stk = res::ai::args::ra::... *) + (* stk = res::ai::args::ra::... *) Kacc 0; (* accu = res *) Kreturn (arity+2) ] @@ -315,24 +315,24 @@ let init_fun_code () = fun_code := [] let code_construct tag nparams arity cont = let f_cont = add_pop nparams - (if arity = 0 then + (if arity = 0 then [Kconst (Const_b0 tag); Kreturn 0] else [Kacc 0; Kpop 1; Kmakeblock(arity, tag); Kreturn 0]) - in + in let lbl = Label.create() in fun_code := [Ksequence (add_grab (nparams+arity) lbl f_cont,!fun_code)]; Kclosure(lbl,0) :: cont let get_strcst = function | Bstrconst sc -> sc - | _ -> raise Not_found + | _ -> raise Not_found -let rec str_const c = +let rec str_const c = match kind_of_term c with | Sort s -> Bstrconst (Const_sorts s) - | Cast(c,_,_) -> str_const c - | App(f,args) -> + | Cast(c,_,_) -> str_const c + | App(f,args) -> begin match kind_of_term f with | Construct((kn,j),i) -> (* arnaud: Construct(((kn,j),i) as cstr) -> *) @@ -345,32 +345,32 @@ let rec str_const c = (* spiwack: *) (* 1/ tries to compile the constructor in an optimal way, it is supposed to work only if the arguments are - all fully constructed, fails with Cbytecodes.NotClosed. + all fully constructed, fails with Cbytecodes.NotClosed. it can also raise Not_found when there is no special - treatment for this constructor - for instance: tries to to compile an integer of the - form I31 D1 D2 ... D31 to [D1D2...D31] as + treatment for this constructor + for instance: tries to to compile an integer of the + form I31 D1 D2 ... D31 to [D1D2...D31] as a processor number (a caml number actually) *) - try + try try - Bstrconst (Retroknowledge.get_vm_constant_static_info + Bstrconst (Retroknowledge.get_vm_constant_static_info (!global_env).retroknowledge (kind_of_term f) args) with NotClosed -> - (* 2/ if the arguments are not all closed (this is - expectingly (and it is currently the case) the only - reason why this exception is raised) tries to + (* 2/ if the arguments are not all closed (this is + expectingly (and it is currently the case) the only + reason why this exception is raised) tries to give a clever, run-time behavior to the constructor. Raises Not_found if there is no special treatment for this integer. this is done in a lazy fashion, using the constructor Bspecial because it needs to know the continuation and such, which can't be done at this time. - for instance, for int31: if one of the digit is + for instance, for int31: if one of the digit is not closed, it's not impossible that the number gets fully instanciated at run-time, thus to ensure uniqueness of the representation in the vm - it is necessary to try and build a caml integer + it is necessary to try and build a caml integer during the execution *) let rargs = Array.sub args nparams arity in let b_args = Array.map str_const rargs in @@ -385,16 +385,16 @@ let rec str_const c = else let rargs = Array.sub args nparams arity in let b_args = Array.map str_const rargs in - try + try let sc_args = Array.map get_strcst b_args in Bstrconst(Const_bn(num, sc_args)) with Not_found -> Bmakeblock(num,b_args) - else + else let b_args = Array.map str_const args in (* spiwack: tries first to apply the run-time compilation behavior of the constructor, as in 2/ above *) - try + try Bspecial ((Retroknowledge.get_vm_constant_dynamic_info (!global_env).retroknowledge (kind_of_term f)), @@ -407,7 +407,7 @@ let rec str_const c = | Ind ind -> Bstrconst (Const_ind ind) | Construct ((kn,j),i) -> (*arnaud: Construct ((kn,j),i as cstr) -> *) begin - (* spiwack: tries first to apply the run-time compilation + (* spiwack: tries first to apply the run-time compilation behavior of the constructor, as in 2/ above *) try Bspecial ((Retroknowledge.get_vm_constant_dynamic_info @@ -415,7 +415,7 @@ let rec str_const c = (kind_of_term c)), [| |]) with Not_found -> - let oib = lookup_mind kn !global_env in + let oib = lookup_mind kn !global_env in let oip = oib.mind_packets.(j) in let num,arity = oip.mind_reloc_tbl.(i-1) in let nparams = oib.mind_nparams in @@ -426,17 +426,17 @@ let rec str_const c = (* compilation des applications *) let comp_args comp_expr reloc args sz cont = - let nargs_m_1 = Array.length args - 1 in + let nargs_m_1 = Array.length args - 1 in let c = ref (comp_expr reloc args.(0) (sz + nargs_m_1) cont) in for i = 1 to nargs_m_1 do c := comp_expr reloc args.(i) (sz + nargs_m_1 - i) (Kpush :: !c) - done; + done; !c - + let comp_app comp_fun comp_arg reloc f args sz cont = let nargs = Array.length args in match is_tailcall cont with - | Some k -> + | Some k -> comp_args comp_arg reloc args sz (Kpush :: comp_fun reloc f (sz + nargs) @@ -445,14 +445,14 @@ let comp_app comp_fun comp_arg reloc f args sz cont = if nargs < 4 then comp_args comp_arg reloc args sz (Kpush :: (comp_fun reloc f (sz+nargs) (Kapply nargs :: cont))) - else + else let lbl,cont1 = label_code cont in Kpush_retaddr lbl :: (comp_args comp_arg reloc args (sz + 3) (Kpush :: (comp_fun reloc f (sz+3+nargs) (Kapply nargs :: cont1)))) (* Compilation des variables libres *) - + let compile_fv_elem reloc fv sz cont = match fv with | FVrel i -> pos_rel i reloc sz :: cont @@ -463,7 +463,7 @@ let rec compile_fv reloc l sz cont = | [] -> cont | [fvn] -> compile_fv_elem reloc fvn sz cont | fvn :: tl -> - compile_fv_elem reloc fvn sz + compile_fv_elem reloc fvn sz (Kpush :: compile_fv reloc tl (sz + 1) cont) (* compilation des constantes *) @@ -474,14 +474,14 @@ let rec get_allias env kn = | BCallias kn' -> get_allias env kn' | _ -> kn - + (* compilation des expressions *) - + let rec compile_constr reloc c sz cont = match kind_of_term c with | Meta _ -> raise (Invalid_argument "Cbytegen.compile_constr : Meta") | Evar _ -> raise (Invalid_argument "Cbytegen.compile_constr : Evar") - + | Cast(c,_,_) -> compile_constr reloc c sz cont | Rel i -> pos_rel i reloc sz :: cont @@ -489,13 +489,13 @@ let rec compile_constr reloc c sz cont = | Const kn -> compile_const reloc kn [||] sz cont | Sort _ | Ind _ | Construct _ -> compile_str_cst reloc (str_const c) sz cont - + | LetIn(_,xb,_,body) -> - compile_constr reloc xb sz - (Kpush :: + compile_constr reloc xb sz + (Kpush :: (compile_constr (push_local sz reloc) body (sz+1) (add_pop 1 cont))) | Prod(id,dom,codom) -> - let cont1 = + let cont1 = Kpush :: compile_constr reloc dom (sz+1) (Kmakeprod :: cont) in compile_constr reloc (mkLambda(id,dom,codom)) sz cont1 | Lambda _ -> @@ -503,18 +503,18 @@ let rec compile_constr reloc c sz cont = let arity = List.length params in let r_fun = comp_env_fun arity in let lbl_fun = Label.create() in - let cont_fun = + let cont_fun = compile_constr r_fun body arity [Kreturn arity] in fun_code := [Ksequence(add_grab arity lbl_fun cont_fun,!fun_code)]; let fv = fv r_fun in compile_fv reloc fv.fv_rev sz (Kclosure(lbl_fun,fv.size) :: cont) - - | App(f,args) -> - begin + + | App(f,args) -> + begin match kind_of_term f with | Construct _ -> compile_str_cst reloc (str_const c) sz cont | Const kn -> compile_const reloc kn args sz cont - | _ -> comp_app compile_constr compile_constr reloc f args sz cont + | _ -> comp_app compile_constr compile_constr reloc f args sz cont end | Fix ((rec_args,init),(_,type_bodies,rec_bodies)) -> let ndef = Array.length type_bodies in @@ -524,10 +524,10 @@ let rec compile_constr reloc c sz cont = (* Compilation des types *) let env_type = comp_env_type rfv in for i = 0 to ndef - 1 do - let lbl,fcode = - label_code - (compile_constr env_type type_bodies.(i) 0 [Kstop]) in - lbl_types.(i) <- lbl; + let lbl,fcode = + label_code + (compile_constr env_type type_bodies.(i) 0 [Kstop]) in + lbl_types.(i) <- lbl; fun_code := [Ksequence(fcode,!fun_code)] done; (* Compilation des corps *) @@ -535,7 +535,7 @@ let rec compile_constr reloc c sz cont = let params,body = decompose_lam rec_bodies.(i) in let arity = List.length params in let env_body = comp_env_fix ndef i arity rfv in - let cont1 = + let cont1 = compile_constr env_body body arity [Kreturn arity] in let lbl = Label.create () in lbl_bodies.(i) <- lbl; @@ -543,9 +543,9 @@ let rec compile_constr reloc c sz cont = fun_code := [Ksequence(fcode,!fun_code)] done; let fv = !rfv in - compile_fv reloc fv.fv_rev sz + compile_fv reloc fv.fv_rev sz (Kclosurerec(fv.size,init,lbl_types,lbl_bodies) :: cont) - + | CoFix(init,(_,type_bodies,rec_bodies)) -> let ndef = Array.length type_bodies in let lbl_types = Array.create ndef Label.no in @@ -554,10 +554,10 @@ let rec compile_constr reloc c sz cont = let rfv = ref empty_fv in let env_type = comp_env_type rfv in for i = 0 to ndef - 1 do - let lbl,fcode = - label_code + let lbl,fcode = + label_code (compile_constr env_type type_bodies.(i) 0 [Kstop]) in - lbl_types.(i) <- lbl; + lbl_types.(i) <- lbl; fun_code := [Ksequence(fcode,!fun_code)] done; (* Compilation des corps *) @@ -566,17 +566,17 @@ let rec compile_constr reloc c sz cont = let arity = List.length params in let env_body = comp_env_cofix ndef arity rfv in let lbl = Label.create () in - let cont1 = + let cont1 = compile_constr env_body body (arity+1) (cont_cofix arity) in - let cont2 = + let cont2 = add_grab (arity+1) lbl cont1 in lbl_bodies.(i) <- lbl; fun_code := [Ksequence(cont2,!fun_code)]; done; let fv = !rfv in - compile_fv reloc fv.fv_rev sz + compile_fv reloc fv.fv_rev sz (Kclosurecofix(fv.size, init, lbl_types, lbl_bodies) :: cont) - + | Case(ci,t,a,branchs) -> let ind = ci.ci_ind in let mib = lookup_mind (fst ind) !global_env in @@ -586,20 +586,20 @@ let rec compile_constr reloc c sz cont = let lbl_blocks = Array.create (oib.mind_nb_args+1) Label.no in let branch1,cont = make_branch cont in (* Compilation du type *) - let lbl_typ,fcode = + let lbl_typ,fcode = label_code (compile_constr reloc t sz [Kpop sz; Kstop]) in fun_code := [Ksequence(fcode,!fun_code)]; - (* Compilation des branches *) + (* Compilation des branches *) let lbl_sw = Label.create () in let sz_b,branch,is_tailcall = - match branch1 with + match branch1 with | Kreturn k -> assert (k = sz); sz, branch1, true | _ -> sz+3, Kjump, false in let annot = {ci = ci; rtbl = tbl; tailcall = is_tailcall} in (* Compilation de la branche accumulate *) - let lbl_accu, code_accu = - label_code(Kmakeswitchblock(lbl_typ,lbl_sw,annot,sz) :: branch::cont) + let lbl_accu, code_accu = + label_code(Kmakeswitchblock(lbl_typ,lbl_sw,annot,sz) :: branch::cont) in lbl_blocks.(0) <- lbl_accu; let c = ref code_accu in @@ -607,14 +607,14 @@ let rec compile_constr reloc c sz cont = for i = 0 to Array.length tbl - 1 do let tag, arity = tbl.(i) in if arity = 0 then - let lbl_b,code_b = + let lbl_b,code_b = label_code(compile_constr reloc branchs.(i) sz_b (branch :: !c)) in - lbl_consts.(tag) <- lbl_b; + lbl_consts.(tag) <- lbl_b; c := code_b - else + else let args, body = decompose_lam branchs.(i) in let nargs = List.length args in - let lbl_b,code_b = + let lbl_b,code_b = label_code( if nargs = arity then Kpushfields arity :: @@ -622,7 +622,7 @@ let rec compile_constr reloc c sz cont = body (sz_b+arity) (add_pop arity (branch :: !c)) else let sz_appterm = if is_tailcall then sz_b + arity else arity in - Kpushfields arity :: + Kpushfields arity :: compile_constr reloc branchs.(i) (sz_b+arity) (Kappterm(arity,sz_appterm) :: !c)) in @@ -630,21 +630,21 @@ let rec compile_constr reloc c sz cont = c := code_b done; c := Klabel lbl_sw :: Kswitch(lbl_consts,lbl_blocks) :: !c; - let code_sw = - match branch1 with - (* spiwack : branch1 can't be a lbl anymore it's a Branch instead + let code_sw = + match branch1 with + (* spiwack : branch1 can't be a lbl anymore it's a Branch instead | Klabel lbl -> Kpush_retaddr lbl :: !c *) | Kbranch lbl -> Kpush_retaddr lbl :: !c - | _ -> !c + | _ -> !c in - compile_constr reloc a sz - (try + compile_constr reloc a sz + (try let entry = Term.Ind ind in Retroknowledge.get_vm_before_match_info (!global_env).retroknowledge entry code_sw with Not_found -> code_sw) - + and compile_str_cst reloc sc sz cont = match sc with | Bconstr c -> compile_constr reloc c sz cont @@ -655,25 +655,25 @@ and compile_str_cst reloc sc sz cont = | Bconstruct_app(tag,nparams,arity,args) -> if Array.length args = 0 then code_construct tag nparams arity cont else - comp_app - (fun _ _ _ cont -> code_construct tag nparams arity cont) + comp_app + (fun _ _ _ cont -> code_construct tag nparams arity cont) compile_str_cst reloc () args sz cont | Bspecial (comp_fx, args) -> comp_fx reloc args sz cont -(* spiwack : compilation of constants with their arguments. +(* 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 = +(*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 + in + let lbl = Label.create () in fun_code := [Ksequence (add_grab 2 lbl f_cont, !fun_code)]; Kclosure(lbl, 0)::cont in *) @@ -685,14 +685,14 @@ and compile_const = try Retroknowledge.get_vm_compiling_info (!global_env).retroknowledge (kind_of_term (mkConst kn)) reloc args sz cont - with Not_found -> + with Not_found -> if nargs = 0 then Kgetglobal (get_allias !global_env kn) :: cont else - comp_app (fun _ _ _ cont -> + comp_app (fun _ _ _ cont -> Kgetglobal (get_allias !global_env kn) :: cont) compile_constr reloc () args sz cont - + let compile env c = set_global_env env; init_fun_code (); @@ -723,8 +723,11 @@ let compile_constant_body env body opaque boxed = BCdefined(true, to_patch) else match kind_of_term body with - | Const kn' -> BCallias (get_allias env kn') - | _ -> + | Const kn' -> + (* we use the canonical name of the constant*) + let con= constant_of_kn (canonical_con kn') in + BCallias (get_allias env con) + | _ -> let res = compile env body in let to_patch = to_memory res in BCdefined (false, to_patch) @@ -743,9 +746,9 @@ let make_areconst n else_lbl cont = (* try to compile int31 as a const_b0. Succeed if all the arguments are closed fails otherwise by raising NotClosed*) let compile_structured_int31 fc args = - if not fc then raise Not_found else + if not fc then raise Not_found else Const_b0 - (Array.fold_left + (Array.fold_left (fun temp_i -> fun t -> match kind_of_term t with | Construct (_,d) -> 2*temp_i+d-1 | _ -> raise NotClosed) @@ -753,7 +756,7 @@ let compile_structured_int31 fc args = ) (* this function is used for the compilation of the constructor of - the int31, it is used when it appears not fully applied, or + the int31, it is used when it appears not fully applied, or applied to at least one non-closed digit *) let dynamic_int31_compilation fc reloc args sz cont = if not fc then raise Not_found else @@ -761,32 +764,32 @@ let dynamic_int31_compilation fc reloc args sz cont = if nargs = 31 then let (escape,labeled_cont) = make_branch cont in let else_lbl = Label.create() in - comp_args compile_str_cst reloc args sz + comp_args compile_str_cst reloc args sz ( Kisconst else_lbl::Kareconst(30,else_lbl)::Kcompint31::escape::Klabel else_lbl::Kmakeblock(31, 1)::labeled_cont) - else + else let code_construct cont = (* spiwack: variant of the global code_construct - which handles dynamic compilation of + which handles dynamic compilation of integers *) - let f_cont = + let f_cont = let else_lbl = Label.create () in [Kacc 0; Kpop 1; Kisconst else_lbl; Kareconst(30,else_lbl); Kcompint31; Kreturn 0; Klabel else_lbl; Kmakeblock(31, 1); Kreturn 0] - in + in let lbl = Label.create() in fun_code := [Ksequence (add_grab 31 lbl f_cont,!fun_code)]; Kclosure(lbl,0) :: cont - in + in if nargs = 0 then code_construct cont else comp_app (fun _ _ _ cont -> code_construct cont) compile_str_cst reloc () args sz cont - + (*(* template compilation for 2ary operation, it probably possible to make a generic such function with arity abstracted *) let op2_compilation op = let code_construct normal cont = (*kn cont =*) - let f_cont = + let f_cont = let else_lbl = Label.create () in Kareconst(2, else_lbl):: Kacc 0:: Kpop 1:: op:: Kreturn 0:: Klabel else_lbl:: @@ -795,7 +798,7 @@ let op2_compilation op = normal:: Kappterm(2, 2):: [] (* = discard_dead_code [Kreturn 0] *) in - let lbl = Label.create () in + let lbl = Label.create () in fun_code := [Ksequence (add_grab 2 lbl f_cont, !fun_code)]; Kclosure(lbl, 0)::cont in @@ -805,8 +808,8 @@ let op2_compilation op = if nargs=2 then (*if it is a fully applied addition*) let (escape, labeled_cont) = make_branch cont in let else_lbl = Label.create () in - comp_args compile_constr reloc args sz - (Kisconst else_lbl::(make_areconst 1 else_lbl + comp_args compile_constr reloc args sz + (Kisconst else_lbl::(make_areconst 1 else_lbl (*Kaddint31::escape::Klabel else_lbl::Kpush::*) (op::escape::Klabel else_lbl::Kpush:: (* works as comp_app with nargs = 2 and non-tailcall cont*) @@ -820,14 +823,14 @@ let op2_compilation op = compile_constr reloc () args sz cont *) (*template for n-ary operation, invariant: n>=1, - the operations does the following : - 1/ checks if all the arguments are constants (i.e. non-block values) + the operations does the following : + 1/ checks if all the arguments are constants (i.e. non-block values) 2/ if they are, uses the "op" instruction to execute - 3/ if at least one is not, branches to the normal behavior: + 3/ if at least one is not, branches to the normal behavior: Kgetglobal (get_allias !global_env kn) *) let op_compilation n op = - let code_construct kn cont = - let f_cont = + let code_construct kn cont = + let f_cont = let else_lbl = Label.create () in Kareconst(n, else_lbl):: Kacc 0:: Kpop 1:: op:: Kreturn 0:: Klabel else_lbl:: @@ -835,7 +838,7 @@ let op_compilation n op = Kgetglobal (get_allias !global_env kn):: Kappterm(n, n):: [] (* = discard_dead_code [Kreturn 0] *) in - let lbl = Label.create () in + let lbl = Label.create () in fun_code := [Ksequence (add_grab n lbl f_cont, !fun_code)]; Kclosure(lbl, 0)::cont in @@ -845,8 +848,8 @@ let op_compilation n op = if nargs=n then (*if it is a fully applied addition*) let (escape, labeled_cont) = make_branch cont in let else_lbl = Label.create () in - comp_args compile_constr reloc args sz - (Kisconst else_lbl::(make_areconst (n-1) else_lbl + comp_args compile_constr reloc args sz + (Kisconst else_lbl::(make_areconst (n-1) else_lbl (*Kaddint31::escape::Klabel else_lbl::Kpush::*) (op::escape::Klabel else_lbl::Kpush:: (* works as comp_app with nargs = n and non-tailcall cont*) diff --git a/kernel/cbytegen.mli b/kernel/cbytegen.mli index dfdcb074..f33fd6cb 100644 --- a/kernel/cbytegen.mli +++ b/kernel/cbytegen.mli @@ -1,6 +1,6 @@ open Names open Cbytecodes -open Cemitcodes +open Cemitcodes open Term open Declarations open Pre_env @@ -9,7 +9,7 @@ open Pre_env val compile : env -> constr -> bytecodes * bytecodes * fv (* init, fun, fv *) -val compile_constant_body : +val compile_constant_body : env -> constr_substituted option -> bool -> bool -> body_code (* opaque *) (* boxed *) @@ -17,15 +17,15 @@ val compile_constant_body : (* 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 -> +val compile_structured_int31 : bool -> constr array -> structured_constant (* 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 *) -val dynamic_int31_compilation : bool -> comp_env -> - block array -> +val dynamic_int31_compilation : bool -> comp_env -> + block array -> int -> bytecodes -> bytecodes (*spiwack: template for the compilation n-ary operation, invariant: n>=1. @@ -35,6 +35,6 @@ val dynamic_int31_compilation : bool -> comp_env -> val op_compilation : int -> instruction -> constant -> bool -> comp_env -> constr array -> int -> bytecodes-> bytecodes -(*spiwack: compiling function to insert dynamic decompilation before +(*spiwack: compiling function to insert dynamic decompilation before matching integers (in case they are in processor representation) *) val int31_escape_before_match : bool -> bytecodes -> bytecodes diff --git a/kernel/cemitcodes.ml b/kernel/cemitcodes.ml index 7617c454..4a9c7da2 100644 --- a/kernel/cemitcodes.ml +++ b/kernel/cemitcodes.ml @@ -6,11 +6,11 @@ open Mod_subst (* Relocation information *) type reloc_info = - | Reloc_annot of annot_switch + | Reloc_annot of annot_switch | Reloc_const of structured_constant | Reloc_getglobal of constant -type patch = reloc_info * int +type patch = reloc_info * int let patch_int buff pos n = String.unsafe_set buff pos (Char.unsafe_chr n); @@ -76,10 +76,10 @@ type label_definition = | Label_undefined of (int * int) list let label_table = ref ([| |] : label_definition array) -(* le ieme element de la table = Label_defined n signifie que l'on a +(* le ieme element de la table = Label_defined n signifie que l'on a deja rencontrer le label i et qu'il est a l'offset n. - = Label_undefined l signifie que l'on a - pas encore rencontrer ce label, le premier entier indique ou est l'entier + = Label_undefined l signifie que l'on a + pas encore rencontrer ce label, le premier entier indique ou est l'entier a patcher dans la string, le deuxieme son origine *) let extend_label_table needed = @@ -156,11 +156,11 @@ let emit_instr = function if ofs = -2 || ofs = 0 || ofs = 2 then out (opOFFSETCLOSURE0 + ofs / 2) else (out opOFFSETCLOSURE; out_int ofs) - | Kpush -> + | Kpush -> out opPUSH - | Kpop n -> + | Kpop n -> out opPOP; out_int n - | Kpush_retaddr lbl -> + | Kpush_retaddr lbl -> out opPUSH_RETADDR; out_label lbl | Kapply n -> if n < 4 then out(opAPPLY1 + n - 1) else (out opAPPLY; out_int n) @@ -173,11 +173,11 @@ let emit_instr = function out opRETURN; out_int 0 | Krestart -> out opRESTART - | Kgrab n -> + | Kgrab n -> out opGRAB; out_int n - | Kgrabrec(rec_arg) -> + | Kgrabrec(rec_arg) -> out opGRABREC; out_int rec_arg - | Kclosure(lbl, n) -> + | Kclosure(lbl, n) -> out opCLOSURE; out_int n; out_label lbl | Kclosurerec(nfv,init,lbl_types,lbl_bodies) -> out opCLOSUREREC;out_int (Array.length lbl_bodies); @@ -193,12 +193,12 @@ let emit_instr = function Array.iter (out_label_with_orig org) lbl_types; let org = !out_position in Array.iter (out_label_with_orig org) lbl_bodies - | Kgetglobal q -> + | Kgetglobal q -> out opGETGLOBAL; slot_for_getglobal q - | Kconst((Const_b0 i)) -> + | Kconst((Const_b0 i)) -> if i >= 0 && i <= 3 then out (opCONST0 + i) - else (out opCONSTINT; out_int i) + else (out opCONSTINT; out_int i) | Kconst c -> out opGETGLOBAL; slot_for_const c | Kmakeblock(n, t) -> @@ -223,7 +223,7 @@ let emit_instr = function if n <= 1 then out (opGETFIELD0+n) else (out opGETFIELD;out_int n) | Ksetfield n -> - if n <= 1 then out (opSETFIELD0+n) + if n <= 1 then out (opSETFIELD0+n) else (out opSETFIELD;out_int n) | Ksequence _ -> raise (Invalid_argument "Cemitcodes.emit_instr") (* spiwack *) @@ -247,7 +247,7 @@ let emit_instr = function | Kcompint31 -> out opCOMPINT31 | Kdecompint31 -> out opDECOMPINT31 (*/spiwack *) - | Kstop -> + | Kstop -> out opSTOP (* Emission of a list of instructions. Include some peephole optimization. *) @@ -258,26 +258,26 @@ let rec emit = function | Kpush :: Kacc n :: c -> if n < 8 then out(opPUSHACC0 + n) else (out opPUSHACC; out_int n); emit c - | Kpush :: Kenvacc n :: c -> + | Kpush :: Kenvacc n :: c -> if n >= 1 && n <= 4 then out(opPUSHENVACC1 + n - 1) else (out opPUSHENVACC; out_int n); emit c - | Kpush :: Koffsetclosure ofs :: c -> + | Kpush :: Koffsetclosure ofs :: c -> if ofs = -2 || ofs = 0 || ofs = 2 then out(opPUSHOFFSETCLOSURE0 + ofs / 2) else (out opPUSHOFFSETCLOSURE; out_int ofs); emit c | Kpush :: Kgetglobal id :: c -> - out opPUSHGETGLOBAL; slot_for_getglobal id; emit c - | Kpush :: Kconst (Const_b0 i) :: c -> + out opPUSHGETGLOBAL; slot_for_getglobal id; emit c + | Kpush :: Kconst (Const_b0 i) :: c -> if i >= 0 && i <= 3 then out (opPUSHCONST0 + i) else (out opPUSHCONSTINT; out_int i); emit c | Kpush :: Kconst const :: c -> out opPUSHGETGLOBAL; slot_for_const const; - emit c + emit c | Kpop n :: Kjump :: c -> out opRETURN; out_int n; emit c | Ksequence(c1,c2)::c -> @@ -304,18 +304,18 @@ let rec subst_strcst s sc = match sc with | Const_sorts _ | Const_b0 _ -> sc | Const_bn(tag,args) -> Const_bn(tag,Array.map (subst_strcst s) args) - | Const_ind(ind) -> let kn,i = ind in Const_ind((subst_kn s kn, i)) + | Const_ind(ind) -> let kn,i = ind in Const_ind((subst_ind s kn, i)) -let subst_patch s (ri,pos) = +let subst_patch s (ri,pos) = match ri with | Reloc_annot a -> let (kn,i) = a.ci.ci_ind in - let ci = {a.ci with ci_ind = (subst_kn s kn,i)} in + let ci = {a.ci with ci_ind = (subst_ind s kn,i)} in (Reloc_annot {a with ci = ci},pos) | Reloc_const sc -> (Reloc_const (subst_strcst s sc), pos) | Reloc_getglobal kn -> (Reloc_getglobal (fst (subst_con s kn)), pos) -let subst_to_patch s (code,pl,fv) = +let subst_to_patch s (code,pl,fv) = code,List.rev_map (subst_patch s) pl,fv type body_code = @@ -334,7 +334,7 @@ let from_val = from_val let force = force subst_body_code -let subst_to_patch_subst = subst_substituted +let subst_to_patch_subst = subst_substituted let is_boxed tps = match force tps with @@ -348,10 +348,10 @@ let to_memory (init_code, fun_code, fv) = let code = String.create !out_position in String.unsafe_blit !out_buffer 0 code 0 !out_position; let reloc = List.rev !reloc_info in - Array.iter (fun lbl -> + Array.iter (fun lbl -> (match lbl with Label_defined _ -> assert true - | Label_undefined patchlist -> + | Label_undefined patchlist -> assert (patchlist = []))) !label_table; (code, reloc, fv) diff --git a/kernel/cemitcodes.mli b/kernel/cemitcodes.mli index ca6da65e..965228fa 100644 --- a/kernel/cemitcodes.mli +++ b/kernel/cemitcodes.mli @@ -2,17 +2,17 @@ open Names open Cbytecodes type reloc_info = - | Reloc_annot of annot_switch + | Reloc_annot of annot_switch | Reloc_const of structured_constant | Reloc_getglobal of constant -type patch = reloc_info * int +type patch = reloc_info * int (* A virer *) val subst_patch : Mod_subst.substitution -> patch -> patch - -type emitcodes -val length : emitcodes -> int +type emitcodes + +val length : emitcodes -> int val patch_int : emitcodes -> (*pos*)int -> int -> unit @@ -26,9 +26,9 @@ type body_code = | BCconstant -type to_patch_substituted +type to_patch_substituted -val from_val : body_code -> to_patch_substituted +val from_val : body_code -> to_patch_substituted val force : to_patch_substituted -> body_code @@ -37,4 +37,4 @@ val is_boxed : to_patch_substituted -> bool val subst_to_patch_subst : Mod_subst.substitution -> to_patch_substituted -> to_patch_substituted 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 a184c128..93788ed4 100644 --- a/kernel/closure.ml +++ b/kernel/closure.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: closure.ml 11897 2009-02-09 19:28:02Z barras $ *) +(* $Id$ *) open Util open Pp @@ -40,7 +40,7 @@ let incr_cnt red cnt = if red then begin if !stats then incr cnt; true - end else + end else false let with_stats c = @@ -126,13 +126,13 @@ module RedFlags = (struct { red with r_const = Idpred.remove id l1, l2 } let red_add_transparent red tr = - { red with r_const = tr } + { red with r_const = tr } let mkflags = List.fold_left red_add no_red let red_set red = function | BETA -> incr_cnt red.r_beta beta - | CONST kn -> + | CONST kn -> let (_,l) = red.r_const in let c = Cpred.mem kn l in incr_cnt c delta @@ -168,7 +168,7 @@ let betaiotazeta = mkflags [fBETA;fIOTA;fZETA] (* Removing fZETA for finer behaviour would break many developments *) let unfold_side_flags = [fBETA;fIOTA;fZETA] let unfold_side_red = mkflags [fBETA;fIOTA;fZETA] -let unfold_red kn = +let unfold_red kn = let flag = match kn with | EvalVarRef id -> fVAR id | EvalConstRef kn -> fCONST kn in @@ -196,6 +196,8 @@ let unfold_red kn = type table_key = id_key +let eq_table_key = Names.eq_id_key + type 'a infos = { i_flags : reds; i_repr : 'a infos -> constr -> 'a; @@ -208,7 +210,7 @@ type 'a infos = { let info_flags info = info.i_flags let ref_value_cache info ref = - try + try Some (Hashtbl.find info.i_tab ref) with Not_found -> try @@ -232,7 +234,7 @@ let evar_value info ev = let defined_vars flags env = (* if red_local_const (snd flags) then*) - Sign.fold_named_context + Sign.fold_named_context (fun (id,b,_) e -> match b with | None -> e @@ -242,7 +244,7 @@ let defined_vars flags env = let defined_rels flags env = (* if red_local_const (snd flags) then*) - Sign.fold_rel_context + Sign.fold_rel_context (fun (id,b,t) (i,subs) -> match b with | None -> (i+1, subs) @@ -250,18 +252,6 @@ let defined_rels flags env = (rel_context env) ~init:(0,[]) (* else (0,[])*) -let rec mind_equiv env (kn1,i1) (kn2,i2) = - let rec equiv kn1 kn2 = - kn1 = kn2 || - match (lookup_mind kn1 env).mind_equiv with - Some kn1' -> equiv kn2 kn1' - | None -> match (lookup_mind kn2 env).mind_equiv with - Some kn2' -> equiv kn2' kn1 - | None -> false in - i1 = i2 && equiv kn1 kn2 - -let mind_equiv_infos info = mind_equiv info.i_env - let create mk_cl flgs env evars = { i_flags = flgs; i_repr = mk_cl; @@ -300,8 +290,8 @@ let neutr = function | (Whnf|Norm) -> Whnf | (Red|Cstr) -> Red -type fconstr = { - mutable norm: red_state; +type fconstr = { + mutable norm: red_state; mutable term: fterm } and fterm = @@ -339,7 +329,7 @@ let update v1 (no,t) = else {norm=no;term=t} (**********************************************************************) -(* The type of (machine) stacks (= lambda-bar-calculus' contexts) *) +(* The type of (machine) stacks (= lambda-bar-calculus' contexts) *) type stack_member = | Zapp of fconstr array @@ -379,9 +369,6 @@ let rec decomp_stack = function | _ -> Some (v.(0), (Zapp (Array.sub v 1 (Array.length v - 1)) :: s))) | _ -> None -let rec decomp_stackn = function - | Zapp v :: s -> if Array.length v = 0 then decomp_stackn s else (v, s) - | _ -> assert false let array_of_stack s = let rec stackrec = function | [] -> [] @@ -390,7 +377,7 @@ let array_of_stack s = in Array.concat (stackrec s) let rec stack_assign s p c = match s with | Zapp args :: s -> - let q = Array.length args in + let q = Array.length args in if p >= q then Zapp args :: stack_assign s (p-q) c else @@ -398,7 +385,7 @@ let rec stack_assign s p c = match s with nargs.(p) <- c; Zapp nargs :: s) | _ -> s -let rec stack_tail p s = +let rec stack_tail p s = if p = 0 then s else match s with | Zapp args :: s -> @@ -430,8 +417,6 @@ let lift_fconstr k f = if k=0 then f else lft_fconstr k f let lift_fconstr_vect k v = if k=0 then v else Array.map (fun f -> lft_fconstr k f) v -let lift_fconstr_list k l = - if k=0 then l else List.map (fun f -> lft_fconstr k f) l let clos_rel e i = match expand_rel i e with @@ -664,7 +649,7 @@ let term_of_fconstr = (* fstrong applies unfreeze_fun recursively on the (freeze) term and * yields a term. Assumes that the unfreeze_fun never returns a - * FCLOS term. + * FCLOS term. let rec fstrong unfreeze_fun lfts v = to_constr (fstrong unfreeze_fun) lfts (unfreeze_fun v) *) @@ -741,12 +726,6 @@ let get_nth_arg 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 *) -let get_arg h stk = - let (depth,stk') = strip_update_shift h stk in - match decomp_stack stk' with - Some (v, s') -> (Some (depth,v), s') - | None -> (None, zshift depth stk') - let rec get_args n tys f e stk = match stk with Zupdate r :: s -> @@ -863,7 +842,7 @@ let rec knr info m stk = | FLambda(n,tys,f,e) when red_set info.i_flags fBETA -> (match get_args n tys f e stk with Inl e', s -> knit info e' f s - | Inr lam, s -> (lam,s)) + | Inr lam, s -> (lam,s)) | FFlex(ConstKey kn) when red_set info.i_flags (fCONST kn) -> (match ref_value_cache info (ConstKey kn) with Some v -> kni info v stk @@ -942,7 +921,7 @@ let rec kl info m = zip_term (kl info) (norm_head info nm) s (* no redex: go up for atoms and already normalized terms, go down - otherwise. *) + otherwise. *) and norm_head info m = if is_val m then (incr prune; term_of_fconstr m) else match m.term with diff --git a/kernel/closure.mli b/kernel/closure.mli index a80f7a62..5cb6fc97 100644 --- a/kernel/closure.mli +++ b/kernel/closure.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: closure.mli 11897 2009-02-09 19:28:02Z barras $ i*) +(*i $Id$ i*) (*i*) open Pp @@ -24,7 +24,7 @@ val with_stats: 'a Lazy.t -> 'a (*s 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 + Rem: reduction of a Rel/Var bound to a term is Delta, but reduction of a LetIn expression is Letin reduction *) @@ -102,7 +102,7 @@ type fconstr type fterm = | FRel of int | FAtom of constr (* Metas and Sorts *) - | FCast of fconstr * cast_kind * fconstr + | FCast of fconstr * cast_kind * fconstr | FFlex of table_key | FInd of inductive | FConstruct of constructor @@ -179,9 +179,7 @@ val whd_stack : (* [unfold_reference] unfolds references in a [fconstr] *) val unfold_reference : clos_infos -> table_key -> fconstr option -(* [mind_equiv] checks whether two inductive types are intentionally equal *) -val mind_equiv : env -> inductive -> inductive -> bool -val mind_equiv_infos : clos_infos -> inductive -> inductive -> bool +val eq_table_key : table_key -> table_key -> bool (************************************************************************) (*i This is for lazy debug *) diff --git a/kernel/conv_oracle.ml b/kernel/conv_oracle.ml index 898a1ab3..0851c7a5 100644 --- a/kernel/conv_oracle.ml +++ b/kernel/conv_oracle.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: conv_oracle.ml 10961 2008-05-21 23:26:23Z barras $ *) +(* $Id$ *) open Names @@ -45,14 +45,6 @@ let set_strategy k l = else Cmap.add c l !cst_opacity | RelKey _ -> Util.error "set_strategy: RelKey" -let set_transparent_const kn = - cst_opacity := Cmap.remove kn !cst_opacity -let set_transparent_var id = - var_opacity := Idmap.remove id !var_opacity - -let set_opaque_const kn = set_strategy (ConstKey kn) Opaque -let set_opaque_var id = set_strategy (VarKey id) Opaque - let get_transp_state () = (Idmap.fold (fun id l ts -> if l=Opaque then Idpred.remove id ts else ts) diff --git a/kernel/conv_oracle.mli b/kernel/conv_oracle.mli index 6a774b4b..86e108c6 100644 --- a/kernel/conv_oracle.mli +++ b/kernel/conv_oracle.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: conv_oracle.mli 10961 2008-05-21 23:26:23Z barras $ i*) +(*i $Id$ i*) open Names diff --git a/kernel/cooking.ml b/kernel/cooking.ml index e5a97897..c971ed29 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: cooking.ml 10877 2008-04-30 21:58:41Z herbelin $ i*) +(*i $Id$ i*) open Pp open Util @@ -19,19 +19,19 @@ open Reduction (*s Cooking the constants. *) -type work_list = identifier array Cmap.t * identifier array KNmap.t +type work_list = identifier array Cmap.t * identifier array Mindmap.t -let dirpath_prefix p = match repr_dirpath p with +let pop_dirpath p = match repr_dirpath p with | [] -> anomaly "dirpath_prefix: empty dirpath" | _::l -> make_dirpath l -let pop_kn kn = - let (mp,dir,l) = Names.repr_kn kn in - Names.make_kn mp (dirpath_prefix dir) l +let pop_mind kn = + let (mp,dir,l) = Names.repr_mind kn in + Names.make_mind mp (pop_dirpath dir) l -let pop_con con = +let pop_con con = let (mp,dir,l) = Names.repr_con con in - Names.make_con mp (dirpath_prefix dir) l + Names.make_con mp (pop_dirpath dir) l type my_global_reference = | ConstRef of constant @@ -47,10 +47,10 @@ let share r (cstl,knl) = with Not_found -> let f,l = match r with - | IndRef (kn,i) -> - mkInd (pop_kn kn,i), KNmap.find kn knl - | ConstructRef ((kn,i),j) -> - mkConstruct ((pop_kn kn,i),j), KNmap.find kn knl + | IndRef (kn,i) -> + mkInd (pop_mind kn,i), Mindmap.find kn knl + | ConstructRef ((kn,i),j) -> + mkConstruct ((pop_mind kn,i),j), Mindmap.find kn knl | ConstRef cst -> mkConst (pop_con cst), Cmap.find cst cstl in let c = mkApp (f, Array.map mkVar l) in @@ -60,7 +60,7 @@ let share r (cstl,knl) = let update_case_info ci modlist = try - let ind, n = + let ind, n = match kind_of_term (share (IndRef ci.ci_ind) modlist) with | App (f,l) -> (destInd f, Array.length l) | Ind ind -> ind, 0 @@ -69,7 +69,7 @@ let update_case_info ci modlist = with Not_found -> ci -let empty_modlist = (Cmap.empty, KNmap.empty) +let empty_modlist = (Cmap.empty, Mindmap.empty) let expmod_constr modlist c = let rec substrec c = @@ -80,19 +80,19 @@ let expmod_constr modlist c = | Ind ind -> (try share (IndRef ind) modlist - with + with | Not_found -> map_constr substrec c) - + | Construct cstr -> (try share (ConstructRef cstr) modlist - with + with | Not_found -> map_constr substrec c) - + | Const cst -> (try share (ConstRef cst) modlist - with + with | Not_found -> map_constr substrec c) | _ -> map_constr substrec c @@ -112,7 +112,7 @@ type recipe = { d_abstract : named_context; d_modlist : work_list } -let on_body f = +let on_body f = Option.map (fun c -> Declarations.from_val (f (Declarations.force c))) let cook_constant env r = @@ -120,7 +120,7 @@ let cook_constant env r = 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) + abstract_constant_body (expmod_constr r.d_modlist c) hyps) cb.const_body in let typ = match cb.const_type with | NonPolymorphicType t -> diff --git a/kernel/cooking.mli b/kernel/cooking.mli index 7596bce6..db35031d 100644 --- a/kernel/cooking.mli +++ b/kernel/cooking.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: cooking.mli 9795 2007-04-25 15:13:45Z soubiran $ i*) +(*i $Id$ i*) open Names open Term @@ -16,7 +16,7 @@ open Univ (*s Cooking the constants. *) -type work_list = identifier array Cmap.t * identifier array KNmap.t +type work_list = identifier array Cmap.t * identifier array Mindmap.t type recipe = { d_from : constant_body; @@ -24,8 +24,8 @@ type recipe = { d_modlist : work_list } val cook_constant : - env -> recipe -> - constr_substituted option * constant_type * constraints * bool * bool + env -> recipe -> + constr_substituted option * constant_type * constraints * bool * bool * bool (*s Utility functions used in module [Discharge]. *) diff --git a/kernel/csymtable.ml b/kernel/csymtable.ml index d81b98ac..145ca27d 100644 --- a/kernel/csymtable.ml +++ b/kernel/csymtable.ml @@ -11,15 +11,15 @@ 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" - + (*******************) (* Linkage du code *) (*******************) (* Table des globaux *) -(* [global_data] contient les valeurs des constantes globales - (axiomes,definitions), les annotations des switch et les structured +(* [global_data] contient les valeurs des constantes globales + (axiomes,definitions), les annotations des switch et les structured constant *) external global_data : unit -> values array = "get_coq_global_data" @@ -28,18 +28,18 @@ external realloc_global_data : int -> unit = "realloc_coq_global_data" let check_global_data n = if n >= Array.length (global_data()) then realloc_global_data n - + let num_global = ref 0 -let set_global v = +let set_global v = let n = !num_global in check_global_data n; (global_data()).(n) <- v; incr num_global; n -(* [global_transp],[global_boxed] contiennent les valeurs des - definitions gelees. Les deux versions sont maintenues en //. +(* [global_transp],[global_boxed] contiennent les valeurs des + definitions gelees. Les deux versions sont maintenues en //. [global_transp] contient la version transparente. [global_boxed] contient la version gelees. *) @@ -50,7 +50,7 @@ external realloc_global_boxed : int -> unit = "realloc_coq_global_boxed" let check_global_boxed n = if n >= Array.length (global_boxed()) then realloc_global_boxed n - + let num_boxed = ref 0 let boxed_tbl = Hashtbl.create 53 @@ -59,7 +59,7 @@ let cst_opaque = ref Cpred.full let is_opaque kn = Cpred.mem kn !cst_opaque -let set_global_boxed kn v = +let set_global_boxed kn v = let n = !num_boxed in check_global_boxed n; (global_boxed()).(n) <- (is_opaque kn); @@ -91,18 +91,18 @@ let key rk = (* slot_for_*, calcul la valeur de l'objet, la place dans la table global, rend sa position dans la table *) - + let slot_for_str_cst key = - try Hashtbl.find str_cst_tbl key - with Not_found -> + try Hashtbl.find str_cst_tbl key + with Not_found -> let n = set_global (val_of_str_const key) in Hashtbl.add str_cst_tbl key n; n let slot_for_annot key = - try Hashtbl.find annot_tbl key - with Not_found -> - let n = set_global (Obj.magic key) in + try Hashtbl.find annot_tbl key + with Not_found -> + let n = set_global (val_of_annot_switch key) in Hashtbl.add annot_tbl key n; n @@ -112,25 +112,25 @@ let rec slot_for_getglobal env kn = with NotEvaluated -> let pos = match Cemitcodes.force cb.const_body_code with - | BCdefined(boxed,(code,pl,fv)) -> + | BCdefined(boxed,(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 - | BCallias kn' -> slot_for_getglobal env kn' + if boxed then set_global_boxed kn v + else set_global v + | BCallias kn' -> slot_for_getglobal env kn' | BCconstant -> set_global (val_of_constant kn) in rk := Some pos; pos and slot_for_fv env fv = match fv with - | FVnamed id -> + | FVnamed id -> let nv = Pre_env.lookup_named_val id env in begin match !nv with | VKvalue (v,_) -> v - | VKnone -> + | VKnone -> let (_, b, _) = Sign.lookup_named id env.env_named_context in - let v,d = + let v,d = match b with | None -> (val_of_named id, Idset.empty) | Some c -> (val_of_constr env c, Environ.global_vars_set (Environ.env_of_pre_env env) c) @@ -142,43 +142,43 @@ and slot_for_fv env fv = begin match !rv with | VKvalue (v, _) -> v - | VKnone -> - let (_, b, _) = Sign.lookup_rel i env.env_rel_context in + | VKnone -> + let (_, b, _) = lookup_rel i env.env_rel_context in let (v, d) = - match b with + match b with | None -> (val_of_rel i, Idset.empty) | Some c -> let renv = env_of_rel i env in (val_of_constr renv c, Environ.global_vars_set (Environ.env_of_pre_env renv) c) in rv := VKvalue (v,d); v end - -and eval_to_patch env (buff,pl,fv) = + +and eval_to_patch env (buff,pl,fv) = let patch = function | Reloc_annot a, pos -> patch_int buff pos (slot_for_annot a) | Reloc_const sc, pos -> patch_int buff pos (slot_for_str_cst sc) - | Reloc_getglobal kn, pos -> + | Reloc_getglobal kn, pos -> patch_int buff pos (slot_for_getglobal env kn) - in + in List.iter patch pl; - let vm_env = Array.map (slot_for_fv env) fv in + let vm_env = Array.map (slot_for_fv env) fv in let tc = tcode_of_code buff (length buff) in eval_tcode tc vm_env -and val_of_constr env c = - let (_,fun_code,_ as ccfv) = - try compile env c +and val_of_constr env c = + let (_,fun_code,_ as ccfv) = + try compile env c with e -> print_string "can not compile \n";Format.print_flush();raise e in eval_to_patch env (to_memory ccfv) - + let set_transparent_const kn = cst_opaque := Cpred.remove kn !cst_opaque; - List.iter (fun n -> (global_boxed()).(n) <- false) + List.iter (fun n -> (global_boxed()).(n) <- false) (Hashtbl.find_all boxed_tbl kn) let set_opaque_const kn = cst_opaque := Cpred.add kn !cst_opaque; - List.iter (fun n -> (global_boxed()).(n) <- true) + List.iter (fun n -> (global_boxed()).(n) <- true) (Hashtbl.find_all boxed_tbl kn) diff --git a/kernel/csymtable.mli b/kernel/csymtable.mli index 2640a4df..894a33ef 100644 --- a/kernel/csymtable.mli +++ b/kernel/csymtable.mli @@ -2,7 +2,7 @@ open Names open Term open Pre_env -val val_of_constr : env -> constr -> values +val val_of_constr : env -> constr -> values val set_opaque_const : constant -> unit val set_transparent_const : constant -> unit diff --git a/kernel/declarations.ml b/kernel/declarations.ml index f4827029..51500979 100644 --- a/kernel/declarations.ml +++ b/kernel/declarations.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: declarations.ml 11417 2008-09-17 15:06:57Z soubiran $ i*) +(*i $Id$ i*) (*i*) open Util @@ -38,7 +38,7 @@ type constr_substituted = constr substituted let from_val = from_val -let force = force subst_mps +let force = force subst_mps let subst_constr_subst = subst_substituted @@ -49,7 +49,7 @@ type constant_body = { const_body_code : Cemitcodes.to_patch_substituted; (* const_type_code : Cemitcodes.to_patch; *) const_constraints : constraints; - const_opaque : bool; + const_opaque : bool; const_inline : bool} (*s Inductive types (internal representation with redundant @@ -62,14 +62,14 @@ let subst_rel_declaration sub (id,copt,t as x) = let subst_rel_context sub = list_smartmap (subst_rel_declaration sub) -type recarg = - | Norec - | Mrec of int +type recarg = + | Norec + | Mrec of int | Imbr of inductive let subst_recarg sub r = match r with | Norec | Mrec _ -> r - | Imbr (kn,i) -> let kn' = subst_kn sub kn in + | Imbr (kn,i) -> let kn' = subst_ind sub kn in if kn==kn' then r else Imbr (kn',i) type wf_paths = recarg Rtree.t @@ -86,7 +86,7 @@ let dest_subterms p = let (_,cstrs) = Rtree.dest_node p in Array.map (fun t -> Array.to_list (snd (Rtree.dest_node t))) cstrs -let recarg_length p j = +let recarg_length p j = let (_,cstrs) = Rtree.dest_node p in Array.length (snd (Rtree.dest_node cstrs.(j-1))) @@ -105,7 +105,7 @@ type monomorphic_inductive_arity = { mind_sort : sorts; } -type inductive_arity = +type inductive_arity = | Monomorphic of monomorphic_inductive_arity | Polymorphic of polymorphic_arity @@ -135,6 +135,9 @@ type one_inductive_body = { (* Number of expected real arguments of the type (no let, no params) *) mind_nrealargs : int; + (* Length of realargs context (with let, no params) *) + mind_nrealargs_ctxt : int; + (* List of allowed elimination sorts *) mind_kelim : sorts_family list; @@ -155,7 +158,7 @@ type one_inductive_body = { (* number of no constant constructor *) mind_nb_args : int; - mind_reloc_tbl : Cbytecodes.reloc_table; + mind_reloc_tbl : Cbytecodes.reloc_table; } type mutual_inductive_body = { @@ -187,25 +190,25 @@ type mutual_inductive_body = { (* Universes constraints enforced by the inductive declaration *) mind_constraints : constraints; - (* Source of the inductive block when aliased in a module *) - mind_equiv : kernel_name option } -let subst_arity sub = function -| NonPolymorphicType s -> NonPolymorphicType (subst_mps sub s) -| PolymorphicArity (ctx,s) -> PolymorphicArity (subst_rel_context sub ctx,s) - +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} - + 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 | Monomorphic s -> Monomorphic { @@ -214,7 +217,7 @@ let subst_arity sub = function } | Polymorphic s as x -> x -let subst_mind_packet sub mbp = +let subst_mind_packet sub mbp = { mind_consnames = mbp.mind_consnames; mind_consnrealdecls = mbp.mind_consnrealdecls; mind_typename = mbp.mind_typename; @@ -223,61 +226,61 @@ let subst_mind_packet sub mbp = mind_arity = subst_arity 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; mind_kelim = mbp.mind_kelim; - mind_recargs = subst_wf_paths sub mbp.mind_recargs (*wf_paths*); + mind_recargs = subst_wf_paths sub mbp.mind_recargs (*wf_paths*); mind_nb_constant = mbp.mind_nb_constant; mind_nb_args = mbp.mind_nb_args; mind_reloc_tbl = mbp.mind_reloc_tbl } -let subst_mind sub mib = - { mind_record = mib.mind_record ; +let subst_mind sub mib = + { mind_record = mib.mind_record ; mind_finite = mib.mind_finite ; mind_ntypes = mib.mind_ntypes ; mind_hyps = (assert (mib.mind_hyps=[]); []) ; mind_nparams = mib.mind_nparams; mind_nparams_rec = mib.mind_nparams_rec; - mind_params_ctxt = + mind_params_ctxt = map_rel_context (subst_mps sub) mib.mind_params_ctxt; mind_packets = array_smartmap (subst_mind_packet sub) mib.mind_packets ; - mind_constraints = mib.mind_constraints ; - mind_equiv = Option.map (subst_kn sub) mib.mind_equiv } + mind_constraints = mib.mind_constraints } (*s Modules: signature component specifications, module types, and module declarations *) -type structure_field_body = +type structure_field_body = | SFBconst of constant_body | SFBmind of mutual_inductive_body | SFBmodule of module_body - | SFBalias of module_path * struct_expr_body option - * constraints option | SFBmodtype of module_type_body and structure_body = (label * structure_field_body) list and struct_expr_body = | SEBident of module_path - | SEBfunctor of mod_bound_id * module_type_body * struct_expr_body - | SEBstruct of mod_self_id * structure_body - | SEBapply of struct_expr_body * struct_expr_body - * constraints + | SEBfunctor of mod_bound_id * module_type_body * struct_expr_body + | SEBapply of struct_expr_body * struct_expr_body * constraints + | SEBstruct of structure_body | SEBwith of struct_expr_body * with_declaration_body and with_declaration_body = - With_module_body of identifier list * module_path - * struct_expr_body option * constraints + With_module_body of identifier list * module_path | With_definition_body of identifier list * constant_body - -and module_body = - { mod_expr : struct_expr_body option; - mod_type : struct_expr_body option; + +and module_body = + { mod_mp : module_path; + mod_expr : struct_expr_body option; + mod_type : struct_expr_body; + mod_type_alg : struct_expr_body option; mod_constraints : constraints; - mod_alias : substitution; + mod_delta : delta_resolver; mod_retroknowledge : Retroknowledge.action list} -and module_type_body = - { typ_expr : struct_expr_body; - typ_strength : module_path option; - typ_alias : substitution} +and module_type_body = + { typ_mp : module_path; + typ_expr : struct_expr_body; + typ_expr_alg : struct_expr_body option ; + typ_constraints : constraints; + typ_delta :delta_resolver} diff --git a/kernel/declarations.mli b/kernel/declarations.mli index b4f5f1f7..adf1d14e 100644 --- a/kernel/declarations.mli +++ b/kernel/declarations.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: declarations.mli 11417 2008-09-17 15:06:57Z soubiran $ i*) +(*i $Id$ i*) (*i*) open Names @@ -55,9 +55,9 @@ val subst_const_body : substitution -> constant_body -> constant_body (**********************************************************************) (*s Representation of mutual inductive types in the kernel *) -type recarg = - | Norec - | Mrec of int +type recarg = + | Norec + | Mrec of int | Imbr of inductive val subst_recarg : substitution -> recarg -> recarg @@ -85,7 +85,7 @@ type monomorphic_inductive_arity = { mind_sort : sorts; } -type inductive_arity = +type inductive_arity = | Monomorphic of monomorphic_inductive_arity | Polymorphic of polymorphic_arity @@ -115,13 +115,17 @@ type one_inductive_body = { (* Number of expected real arguments of the type (no let, no params) *) mind_nrealargs : int; + (* Length of realargs context (with let, no params) *) + mind_nrealargs_ctxt : int; + (* List of allowed elimination sorts *) mind_kelim : sorts_family list; (* Head normalized constructor types so that their conclusion is atomic *) mind_nf_lc : types array; - (* Length of the signature of the constructors (with let, w/o params) *) + (* Length of the signature of the constructors (with let, w/o params) + (not used in the kernel) *) mind_consnrealdecls : int array; (* Signature of recursive arguments in the constructors *) @@ -135,7 +139,7 @@ type one_inductive_body = { (* number of no constant constructor *) mind_nb_args : int; - mind_reloc_tbl : Cbytecodes.reloc_table; + mind_reloc_tbl : Cbytecodes.reloc_table; } type mutual_inductive_body = { @@ -167,8 +171,6 @@ type mutual_inductive_body = { (* Universes constraints enforced by the inductive declaration *) mind_constraints : constraints; - (* Source of the inductive block when aliased in a module *) - mind_equiv : kernel_name option } val subst_mind : substitution -> mutual_inductive_body -> mutual_inductive_body @@ -177,37 +179,49 @@ val subst_mind : substitution -> mutual_inductive_body -> mutual_inductive_body (*s Modules: signature component specifications, module types, and module declarations *) -type structure_field_body = +type structure_field_body = | SFBconst of constant_body | SFBmind of mutual_inductive_body | SFBmodule of module_body - | SFBalias of module_path * struct_expr_body option - *constraints option | SFBmodtype of module_type_body and structure_body = (label * structure_field_body) list and struct_expr_body = | SEBident of module_path - | SEBfunctor of mod_bound_id * module_type_body * struct_expr_body - | SEBstruct of mod_self_id * structure_body - | SEBapply of struct_expr_body * struct_expr_body - * constraints + | SEBfunctor of mod_bound_id * module_type_body * struct_expr_body + | SEBapply of struct_expr_body * struct_expr_body * constraints + | SEBstruct of structure_body | SEBwith of struct_expr_body * with_declaration_body and with_declaration_body = - With_module_body of identifier list * module_path - * struct_expr_body option * constraints + With_module_body of identifier list * module_path | With_definition_body of identifier list * constant_body - -and module_body = - { mod_expr : struct_expr_body option; - mod_type : struct_expr_body option; + +and module_body = + { (*absolute path of the module*) + mod_mp : module_path; + (* Implementation *) + mod_expr : struct_expr_body option; + (* Signature *) + mod_type : struct_expr_body; + (* 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 *) mod_constraints : constraints; - mod_alias : substitution; + (* quotiented set of equivalent constant and inductive name *) + mod_delta : delta_resolver; mod_retroknowledge : Retroknowledge.action list} - -and module_type_body = - { typ_expr : struct_expr_body; - typ_strength : module_path option; - typ_alias : substitution} + +and module_type_body = + { + (*Path of the module type*) + typ_mp : module_path; + typ_expr : struct_expr_body; + (* 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 *) + typ_delta :delta_resolver} diff --git a/kernel/entries.ml b/kernel/entries.ml index b6b09c64..938d1c60 100644 --- a/kernel/entries.ml +++ b/kernel/entries.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: entries.ml 10664 2008-03-14 11:27:37Z soubiran $ i*) +(*i $Id$ i*) (*i*) open Names @@ -62,34 +62,33 @@ type definition_entry = { const_entry_opaque : bool; const_entry_boxed : bool} -type parameter_entry = types*bool +(* type and the inlining flag *) +type parameter_entry = types * bool -type constant_entry = +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 - | SPEalias of module_path | SPEmodtype of module_struct_entry - + and 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 | MSEapply of module_struct_entry * module_struct_entry -and with_declaration = +and with_declaration = With_Module of identifier list * module_path | With_Definition of identifier list * constr -and module_structure = (label * specification_entry) list - -and module_entry = +and module_entry = { mod_entry_type : module_struct_entry option; mod_entry_expr : module_struct_entry option} diff --git a/kernel/entries.mli b/kernel/entries.mli index ed315ab8..20fbbb8e 100644 --- a/kernel/entries.mli +++ b/kernel/entries.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: entries.mli 10664 2008-03-14 11:27:37Z soubiran $ i*) +(*i $Id$ i*) (*i*) open Names @@ -61,34 +61,32 @@ type definition_entry = { const_entry_opaque : bool; const_entry_boxed : bool } -type parameter_entry = types*bool (*inline flag*) +type parameter_entry = types * bool (*inline flag*) -type constant_entry = +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 - | SPEalias of module_path | SPEmodtype of module_struct_entry -and module_struct_entry = +and 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 | MSEapply of module_struct_entry * module_struct_entry -and with_declaration = +and with_declaration = With_Module of identifier list * module_path | With_Definition of identifier list * constr -and module_structure = (label * specification_entry) list - -and module_entry = +and module_entry = { mod_entry_type : module_struct_entry option; mod_entry_expr : module_struct_entry option} diff --git a/kernel/environ.ml b/kernel/environ.ml index cd4efe27..8f6a619a 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: environ.ml 12187 2009-06-13 19:36:59Z msozeau $ *) +(* $Id$ *) open Util open Names @@ -35,49 +35,40 @@ let named_context env = env.env_named_context let named_context_val env = env.env_named_context,env.env_named_vals let rel_context env = env.env_rel_context -let empty_context env = - env.env_rel_context = empty_rel_context +let empty_context env = + env.env_rel_context = empty_rel_context && env.env_named_context = empty_named_context (* Rel context *) let lookup_rel n env = - Sign.lookup_rel n env.env_rel_context + lookup_rel n env.env_rel_context let evaluable_rel n env = - try - match lookup_rel n env with - (_,Some _,_) -> true - | _ -> false - with Not_found -> - false + match lookup_rel n env with + | (_,Some _,_) -> true + | _ -> false let nb_rel env = env.env_nb_rel let push_rel = push_rel let push_rel_context ctxt x = Sign.fold_rel_context push_rel ctxt ~init:x - + let push_rec_types (lna,typarray,_) env = let ctxt = array_map2_i (fun i na t -> (na, None, lift i t)) lna typarray in Array.fold_left (fun e assum -> push_rel assum e) env ctxt - -let reset_rel_context env = - { env with - env_rel_context = empty_rel_context; - env_rel_val = []; - env_nb_rel = 0 } let fold_rel_context f env ~init = let rec fold_right env = match env.env_rel_context with | [] -> init | rd::rc -> - let env = + let env = { env with env_rel_context = rc; env_rel_val = List.tl env.env_rel_val; env_nb_rel = env.env_nb_rel - 1 } in - f env rd (fold_right env) + f env rd (fold_right env) in fold_right env (* Named context *) @@ -87,13 +78,13 @@ let named_vals_of_val = snd (* [map_named_val f ctxt] apply [f] to the body and the type of each declarations. - *** /!\ *** [f t] should be convertible with t *) -let map_named_val f (ctxt,ctxtv) = + *** /!\ *** [f t] should be convertible with t *) +let map_named_val f (ctxt,ctxtv) = let ctxt = List.map (fun (id,body,typ) -> (id, Option.map f body, f typ)) ctxt in (ctxt,ctxtv) -let empty_named_context = empty_named_context +let empty_named_context = empty_named_context let push_named = push_named let push_named_context_val = push_named_context_val @@ -117,12 +108,10 @@ let named_body id env = let (_,b,_) = lookup_named id env in b let evaluable_named id env = - try - match named_body id env with - |Some _ -> true - | _ -> false - with Not_found -> false - + match named_body id env with + | Some _ -> true + | _ -> false + let reset_with_named_context (ctxt,ctxtv) env = { env with env_named_context = ctxt; @@ -132,36 +121,36 @@ let reset_with_named_context (ctxt,ctxtv) env = env_nb_rel = 0 } let reset_context = reset_with_named_context empty_named_context_val - + let fold_named_context f env ~init = let rec fold_right env = match env.env_named_context with | [] -> init | d::ctxt -> - let env = + let env = reset_with_named_context (ctxt,List.tl env.env_named_vals) env in - f env d (fold_right env) + f env d (fold_right env) in fold_right env let fold_named_context_reverse f ~init env = Sign.fold_named_context_reverse f ~init:init (named_context env) - + (* Global constants *) let lookup_constant = lookup_constant let add_constant kn cs env = - let new_constants = - Cmap.add kn (cs,ref None) env.env_globals.env_constants in - let new_globals = - { env.env_globals with - env_constants = new_constants } in + let new_constants = + Cmap_env.add kn (cs,ref None) env.env_globals.env_constants in + let new_globals = + { env.env_globals with + env_constants = new_constants } in { env with env_globals = new_globals } (* constant_type gives the type of a constant *) let constant_type env kn = let cb = lookup_constant kn env in - cb.const_type + cb.const_type type const_evaluation_result = NoBody | Opaque @@ -181,17 +170,15 @@ let constant_opt_value env cst = (* A global const is evaluable if it is defined and not opaque *) let evaluable_constant cst env = try let _ = constant_value env cst in true - with Not_found | NotEvaluableConst _ -> false + with NotEvaluableConst _ -> false (* Mutual Inductives *) let lookup_mind = lookup_mind -let scrape_mind = scrape_mind - - + let add_mind kn mib env = - let new_inds = KNmap.add kn mib env.env_globals.env_inductives in - let new_globals = - { env.env_globals with + let new_inds = Mindmap_env.add kn mib env.env_globals.env_inductives in + let new_globals = + { env.env_globals with env_inductives = new_inds } in { env with env_globals = new_globals } @@ -199,15 +186,15 @@ let add_mind kn mib env = let set_universes g env = if env.env_stratification.env_universes == g then env else - { env with env_stratification = + { env with env_stratification = { env.env_stratification with env_universes = g } } let add_constraints c env = - if c == Constraint.empty then - env + if c == Constraint.empty then + env else let s = env.env_stratification in - { env with env_stratification = + { env with env_stratification = { s with env_universes = merge_constraints c s.env_universes } } let set_engagement c env = (* Unsafe *) @@ -234,19 +221,23 @@ let vars_of_global env constr = | Const kn -> lookup_constant_variables kn env | Ind ind -> lookup_inductive_variables ind env | Construct cstr -> lookup_constructor_variables cstr env - | _ -> [] + | _ -> raise Not_found -let global_vars_set env constr = +let global_vars_set env constr = let rec filtrec acc c = - let vl = vars_of_global env c in - let acc = List.fold_right Idset.add vl acc in - fold_constr filtrec acc c - in + let acc = + match kind_of_term c with + | Var _ | Const _ | Ind _ | Construct _ -> + List.fold_right Idset.add (vars_of_global env c) acc + | _ -> + acc in + fold_constr filtrec acc c + in filtrec Idset.empty constr -(* [keep_hyps env ids] keeps the part of the section context of [env] which - contains the variables of the set [ids], and recursively the variables +(* [keep_hyps env ids] keeps the part of the section context of [env] which + contains the variables of the set [ids], and recursively the variables contained in the types of the needed variables. *) let keep_hyps env needed = @@ -254,12 +245,12 @@ let keep_hyps env needed = Sign.fold_named_context_reverse (fun need (id,copt,t) -> if Idset.mem id need then - let globc = + let globc = match copt with | None -> Idset.empty | Some c -> global_vars_set env c in Idset.union - (global_vars_set env t) + (global_vars_set env t) (Idset.union globc need) else need) ~init:needed @@ -273,48 +264,30 @@ let keep_hyps env needed = (* Modules *) -let add_modtype ln mtb env = +let add_modtype ln mtb env = let new_modtypes = MPmap.add ln mtb env.env_globals.env_modtypes in - let new_globals = - { env.env_globals with + let new_globals = + { env.env_globals with env_modtypes = new_modtypes } in { env with env_globals = new_globals } -let shallow_add_module mp mb env = +let shallow_add_module mp mb env = let new_mods = MPmap.add mp mb env.env_globals.env_modules in - let new_globals = - { env.env_globals with + let new_globals = + { env.env_globals with env_modules = new_mods } in { env with env_globals = new_globals } -let rec scrape_alias mp env = - try - let mp1 = MPmap.find mp env.env_globals.env_alias in - scrape_alias mp1 env - with - Not_found -> mp - -let lookup_module mp env = - let mp = scrape_alias mp env in +let lookup_module mp env = MPmap.find mp env.env_globals.env_modules -let lookup_modtype ln env = - let mp = scrape_alias ln env in - MPmap.find mp env.env_globals.env_modtypes -let register_alias mp1 mp2 env = - let new_alias = MPmap.add mp1 mp2 env.env_globals.env_alias in - let new_globals = - { env.env_globals with - env_alias = new_alias } in - { env with env_globals = new_globals } - -let lookup_alias mp env = - MPmap.find mp env.env_globals.env_alias +let lookup_modtype mp env = + MPmap.find mp env.env_globals.env_modtypes (*s Judgments. *) - -type unsafe_judgment = { + +type unsafe_judgment = { uj_val : constr; uj_type : types } @@ -325,13 +298,13 @@ let make_judge v tj = let j_val j = j.uj_val let j_type j = j.uj_type -type unsafe_type_judgment = { +type unsafe_type_judgment = { utj_val : constr; utj_type : sorts } (*s Compilation of global declaration *) -let compile_constant_body = Cbytegen.compile_constant_body +let compile_constant_body = Cbytegen.compile_constant_body exception Hyp_not_found @@ -341,7 +314,7 @@ let rec apply_to_hyp (ctxt,vals) id f = | (idc,c,ct as d)::ctxt, v::vals -> if idc = id then (f ctxt d rtail)::ctxt, v::vals - else + else let ctxt',vals' = aux (d::rtail) ctxt vals in d::ctxt', v::vals' | [],[] -> raise Hyp_not_found @@ -354,8 +327,8 @@ let rec apply_to_hyp_and_dependent_on (ctxt,vals) id f g = | (idc,c,ct as d)::ctxt, v::vals -> if idc = id then let sign = ctxt,vals in - push_named_context_val (f d sign) sign - else + push_named_context_val (f d sign) sign + else let (ctxt,vals as sign) = aux ctxt vals in push_named_context_val (g d sign) sign | [],[] -> raise Hyp_not_found @@ -367,9 +340,9 @@ let insert_after_hyp (ctxt,vals) id d check = match ctxt, vals with | (idc,c,ct)::ctxt', v::vals' -> if idc = id then begin - check ctxt; - push_named_context_val d (ctxt,vals) - end else + check ctxt; + push_named_context_val d (ctxt,vals) + end else let ctxt,vals = aux ctxt vals in d::ctxt, v::vals | [],[] -> raise Hyp_not_found @@ -380,9 +353,9 @@ let insert_after_hyp (ctxt,vals) id d check = (* To be used in Logic.clear_hyps *) let remove_hyps ids check_context check_value (ctxt, vals) = List.fold_right2 (fun (id,_,_ as d) (id',v) (ctxt,vals) -> - if List.mem id ids then + if List.mem id ids then (ctxt,vals) - else + else let nd = check_context d in let nv = check_value v in (nd::ctxt,(id',nv)::vals)) @@ -413,25 +386,25 @@ let registered env field = unregister function *) let unregister env field = match field with - | KInt31 (_,Int31Type) -> + | KInt31 (_,Int31Type) -> (*there is only one matching kind due to the fact that Environ.env is abstract, and that the only function which add elements to the retroknowledge is Environ.register which enforces this shape *) - (match retroknowledge find env field with + (match retroknowledge find env field with | Ind i31t -> let i31c = Construct (i31t, 1) in - {env with retroknowledge = + {env with retroknowledge = remove (retroknowledge clear_info env i31c) field} | _ -> assert false) |_ -> {env with retroknowledge = - try - remove (retroknowledge clear_info env + try + remove (retroknowledge clear_info env (retroknowledge find env field)) field with Not_found -> retroknowledge remove env field} -(* the Environ.register function syncrhonizes the proactive and reactive +(* the Environ.register function syncrhonizes the proactive and reactive retroknowledge. *) let register = @@ -439,7 +412,7 @@ let register = see pretyping/vnorm.ml for more information) *) let constr_of_int31 = let nth_digit_plus_one i n = (* calculates the nth (starting with 0) - digit of i and adds 1 to it + digit of i and adds 1 to it (nth_digit_plus_one 1 3 = 2) *) if (land) i ((lsl) 1 n) = 0 then 1 @@ -456,8 +429,8 @@ let register = (* subfunction which adds the information bound to the constructor of the int31 type to the reactive retroknowledge *) - let add_int31c retroknowledge c = - let rk = add_vm_constant_static_info retroknowledge c + let add_int31c retroknowledge c = + let rk = add_vm_constant_static_info retroknowledge c Cbytegen.compile_structured_int31 in add_vm_constant_dynamic_info rk c Cbytegen.dynamic_int31_compilation @@ -475,7 +448,7 @@ fun env field value -> operators to the reactive retroknowledge. *) let add_int31_binop_from_const op = match value with - | Const kn -> retroknowledge add_int31_op env value 2 + | Const kn -> retroknowledge add_int31_op env value 2 op kn | _ -> anomaly "Environ.register: should be a constant" in @@ -487,66 +460,66 @@ fun env field value -> in (* subfunction which completes the function constr_of_int31 above by performing the actual retroknowledge operations *) - let add_int31_decompilation_from_type rk = - (* invariant : the type of bits is registered, otherwise the function + let add_int31_decompilation_from_type rk = + (* invariant : the type of bits is registered, otherwise the function would raise Not_found. The invariant is enforced in safe_typing.ml *) match field with - | KInt31 (grp, Int31Type) -> + | KInt31 (grp, Int31Type) -> (match Retroknowledge.find rk (KInt31 (grp,Int31Bits)) with - | Ind i31bit_type -> - (match value with - | Ind i31t -> + | Ind i31bit_type -> + (match value with + | Ind i31t -> Retroknowledge.add_vm_decompile_constant_info rk value (constr_of_int31 i31t i31bit_type) | _ -> anomaly "Environ.register: should be an inductive type") | _ -> anomaly "Environ.register: Int31Bits should be an inductive type") | _ -> anomaly "Environ.register: add_int31_decompilation_from_type called with an abnormal field" in - {env with retroknowledge = - let retroknowledge_with_reactive_info = + {env with retroknowledge = + let retroknowledge_with_reactive_info = match field with - | KInt31 (_, Int31Type) -> + | KInt31 (_, Int31Type) -> let i31c = match value with | Ind i31t -> (Construct (i31t, 1)) | _ -> anomaly "Environ.register: should be an inductive type" in - add_int31_decompilation_from_type - (add_vm_before_match_info - (retroknowledge add_int31c env i31c) + add_int31_decompilation_from_type + (add_vm_before_match_info + (retroknowledge add_int31c env i31c) value Cbytegen.int31_escape_before_match) | KInt31 (_, Int31Plus) -> add_int31_binop_from_const Cbytecodes.Kaddint31 | KInt31 (_, Int31PlusC) -> add_int31_binop_from_const Cbytecodes.Kaddcint31 | KInt31 (_, Int31PlusCarryC) -> add_int31_binop_from_const Cbytecodes.Kaddcarrycint31 | KInt31 (_, Int31Minus) -> add_int31_binop_from_const Cbytecodes.Ksubint31 | KInt31 (_, Int31MinusC) -> add_int31_binop_from_const Cbytecodes.Ksubcint31 - | KInt31 (_, Int31MinusCarryC) -> add_int31_binop_from_const + | KInt31 (_, Int31MinusCarryC) -> add_int31_binop_from_const Cbytecodes.Ksubcarrycint31 | KInt31 (_, Int31Times) -> add_int31_binop_from_const Cbytecodes.Kmulint31 | KInt31 (_, Int31TimesC) -> add_int31_binop_from_const Cbytecodes.Kmulcint31 | KInt31 (_, Int31Div21) -> (* this is a ternary operation *) (match value with | Const kn -> - retroknowledge add_int31_op env value 3 + retroknowledge add_int31_op env value 3 Cbytecodes.Kdiv21int31 kn | _ -> anomaly "Environ.register: should be a constant") | KInt31 (_, Int31Div) -> add_int31_binop_from_const Cbytecodes.Kdivint31 | KInt31 (_, Int31AddMulDiv) -> (* this is a ternary operation *) (match value with | Const kn -> - retroknowledge add_int31_op env value 3 + retroknowledge add_int31_op env value 3 Cbytecodes.Kaddmuldivint31 kn | _ -> anomaly "Environ.register: should be a constant") | KInt31 (_, Int31Compare) -> add_int31_binop_from_const Cbytecodes.Kcompareint31 | KInt31 (_, Int31Head0) -> add_int31_unop_from_const Cbytecodes.Khead0int31 - | KInt31 (_, Int31Tail0) -> add_int31_unop_from_const Cbytecodes.Ktail0int31 - | _ -> env.retroknowledge + | KInt31 (_, Int31Tail0) -> add_int31_unop_from_const Cbytecodes.Ktail0int31 + | _ -> env.retroknowledge in Retroknowledge.add_field retroknowledge_with_reactive_info field value } (**************************************************************) -(* spiwack: the following definitions are used by the function +(* spiwack: the following definitions are used by the function [assumptions] which gives as an output the set of all axioms and sections variables on which a given term depends in a context (expectingly the Global context) *) @@ -557,10 +530,10 @@ type context_object = | Opaque of constant (* An opaque constant. *) (* Defines a set of [assumption] *) -module OrderedContextObject = -struct +module OrderedContextObject = +struct type t = context_object - let compare x y = + let compare x y = match x , y with | Variable i1 , Variable i2 -> id_ord i1 i2 | Axiom k1 , Axiom k2 -> Pervasives.compare k1 k2 @@ -583,8 +556,8 @@ let assumptions ?(add_opaque=false) st (* t env *) = on a and a ContextObjectSet, ContextObjectMap. *) let ( ** ) f1 f2 s m = let (s',m') = f1 s m in f2 s' m' in (* This function eases memoization, by checking if an object is already - stored before trying and applying a function. - If the object is there, the function is not fired (we are in a + stored before trying and applying a function. + If the object is there, the function is not fired (we are in a particular case where memoized object don't need a treatment at all). If the object isn't there, it is stored and the function is fired*) let try_and_go o f s m = @@ -596,7 +569,7 @@ let assumptions ?(add_opaque=false) st (* t env *) = let identity2 s m = (s,m) in (* Goes recursively into the term to see if it depends on assumptions the 3 important cases are : - Const _ where we need to first unfold - the constant and return the needed assumptions of its body in the + the constant and return the needed assumptions of its body in the environment, - Rel _ which means the term is a variable which has been bound earlier by a Lambda or a Prod (returns [] ), @@ -612,30 +585,30 @@ let assumptions ?(add_opaque=false) st (* t env *) = let rec aux t env s acc = match kind_of_term t with | Var id -> aux_memoize_id id env s acc - | Meta _ | Evar _ -> + | Meta _ | Evar _ -> Util.anomaly "Environ.assumption: does not expect a meta or an evar" - | Cast (e1,_,e2) | Prod (_,e1,e2) | Lambda (_,e1,e2) -> + | Cast (e1,_,e2) | Prod (_,e1,e2) | Lambda (_,e1,e2) -> ((aux e1 env)**(aux e2 env)) s acc | LetIn (_,e1,e2,e3) -> ((aux e1 env)** (aux e2 env)** (aux e3 env)) - s acc + s acc | App (e1, e_array) -> ((aux e1 env)** - (Array.fold_right + (Array.fold_right (fun e f -> (aux e env)**f) e_array identity2)) s acc | Case (_,e1,e2,e_array) -> ((aux e1 env)** (aux e2 env)** - (Array.fold_right + (Array.fold_right (fun e f -> (aux e env)**f) e_array identity2)) s acc | Fix (_,(_, e1_array, e2_array)) | CoFix (_,(_,e1_array, e2_array)) -> - ((Array.fold_right + ((Array.fold_right (fun e f -> (aux e env)**f) e1_array identity2) ** - (Array.fold_right + (Array.fold_right (fun e f -> (aux e env)**f) e2_array identity2)) s acc @@ -665,7 +638,7 @@ let assumptions ?(add_opaque=false) st (* t env *) = let (s,acc) = if cb.Declarations.const_body <> None && (cb.Declarations.const_opaque || not (Cpred.mem kn knst)) - && add_opaque + && add_opaque then do_type (Opaque kn) else (s,acc) @@ -673,13 +646,13 @@ let assumptions ?(add_opaque=false) st (* t env *) = match cb.Declarations.const_body with | None -> do_type (Axiom kn) | Some body -> aux (Declarations.force body) env s acc - + and aux_memoize_kn kn env = try_and_go (Axiom kn) (add_kn kn env) in fun t env -> snd (aux t env (ContextObjectSet.empty) (ContextObjectMap.empty)) - + (* /spiwack *) diff --git a/kernel/environ.mli b/kernel/environ.mli index b68123f6..667a0ed4 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: environ.mli 12187 2009-06-13 19:36:59Z msozeau $ i*) +(*i $Id$ i*) (*i*) open Names @@ -15,7 +15,7 @@ open Declarations open Sign (*i*) -(*s Unsafe environments. We define here a datatype for environments. +(*s 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. *) @@ -24,7 +24,7 @@ open Sign - a context for de Bruijn variables - a context for de Bruijn variables vm values - a context for section variables and goal assumptions - - a context for section variables and goal assumptions vm values + - a context for section variables and goal assumptions vm values - a context for global constants and axioms - a context for inductive definitions - a set of universe constraints @@ -55,7 +55,7 @@ val empty_context : env -> bool (************************************************************************) (*s Context of de Bruijn variables ([rel_context]) *) -val nb_rel : env -> int +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 @@ -80,12 +80,12 @@ val empty_named_context_val : named_context_val (* [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 : + *** /!\ *** [f t] should be convertible with t *) +val map_named_val : (constr -> constr) -> named_context_val -> named_context_val val push_named : named_declaration -> env -> env -val push_named_context_val : +val push_named_context_val : named_declaration -> named_context_val -> named_context_val @@ -98,7 +98,7 @@ val lookup_named_val : variable -> named_context_val -> named_declaration 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 *) val fold_named_context : @@ -142,9 +142,6 @@ val add_mind : mutual_inductive -> mutual_inductive_body -> env -> env (* raises [Not_found] if the required path is not found *) val lookup_mind : mutual_inductive -> env -> mutual_inductive_body -(* Find the ultimate inductive in the [mind_equiv] chain *) -val scrape_mind : env -> mutual_inductive -> mutual_inductive - (************************************************************************) (*s Modules *) val add_modtype : module_path -> module_type_body -> env -> env @@ -155,10 +152,6 @@ 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 -val register_alias : module_path -> module_path -> env -> env -val lookup_alias : module_path -> env -> module_path -val scrape_alias : module_path -> env -> module_path - (************************************************************************) (*s Universe constraints *) val set_universes : Univ.universes -> env -> env @@ -168,10 +161,11 @@ val set_engagement : engagement -> env -> env (************************************************************************) (* Sets of referred section variables *) -(* [global_vars_set env c] returns the list of [id]'s occurring as - [VAR id] in [c] *) +(* [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 an atomic construction *) +(* the constr must be a global reference *) val vars_of_global : env -> constr -> identifier list val keep_hyps : env -> Idset.t -> section_context @@ -181,7 +175,7 @@ val keep_hyps : env -> Idset.t -> section_context actually only a datatype to store a term with its type and the type of its type. *) -type unsafe_judgment = { +type unsafe_judgment = { uj_val : constr; uj_type : types } @@ -189,14 +183,14 @@ val make_judge : constr -> types -> unsafe_judgment val j_val : unsafe_judgment -> constr val j_type : unsafe_judgment -> types -type unsafe_type_judgment = { +type unsafe_type_judgment = { utj_val : constr; utj_type : sorts } (*s Compilation of global declaration *) -val compile_constant_body : +val compile_constant_body : env -> constr_substituted option -> bool -> bool -> Cemitcodes.body_code (* opaque *) (* boxed *) @@ -206,7 +200,7 @@ exception Hyp_not_found return [tail::(f head (id,_,_) (rev tail))::head]. the value associated to id should not change *) -val apply_to_hyp : named_context_val -> variable -> +val apply_to_hyp : named_context_val -> variable -> (named_context -> named_declaration -> named_context -> named_declaration) -> named_context_val @@ -219,7 +213,7 @@ val apply_to_hyp_and_dependent_on : named_context_val -> variable -> named_context_val val insert_after_hyp : named_context_val -> variable -> - named_declaration -> + named_declaration -> (named_context -> unit) -> named_context_val val remove_hyps : identifier list -> (named_declaration -> named_declaration) -> (Pre_env.lazy_val -> Pre_env.lazy_val) -> named_context_val -> named_context_val @@ -250,7 +244,7 @@ type context_object = module OrderedContextObject : Set.OrderedType with type t = context_object module ContextObjectMap : Map.S with type key = context_object -(* collects all the assumptions (optionally including opaque definitions) +(* collects all the assumptions (optionally including opaque definitions) on which a term relies (together with their type) *) val assumptions : ?add_opaque:bool -> transparent_state -> constr -> env -> Term.types ContextObjectMap.t diff --git a/kernel/esubst.ml b/kernel/esubst.ml index e32fc963..c8b5fb26 100644 --- a/kernel/esubst.ml +++ b/kernel/esubst.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: esubst.ml 8799 2006-05-09 21:15:07Z barras $ *) +(* $Id$ *) open Util @@ -110,7 +110,7 @@ let rec is_subs_id = function * the result is (Inr (k+lams,p)) when the variable is just relocated * where p is None if the variable points inside subs and Some(k) if the * variable points k bindings beyond subs. - *) + *) let rec exp_rel lams k subs = match subs with | CONS (def,_) when k <= Array.length def diff --git a/kernel/esubst.mli b/kernel/esubst.mli index 3b40bdfc..bf1d2324 100644 --- a/kernel/esubst.mli +++ b/kernel/esubst.mli @@ -6,7 +6,47 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: esubst.mli 8799 2006-05-09 21:15:07Z barras $ i*) +(*i $Id$ i*) + +(*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) + (corresponds to S crossing n binders) *) +type 'a subs = + | ESID of int + | CONS of 'a array * 'a subs + | SHIFT of int * 'a subs + | LIFT of int * 'a subs + +(* Derived constructors granting basic invariants *) +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 *) +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). + *) +val expand_rel: int -> 'a subs -> (int * 'a, int * int option) Util.union + +(* 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. + *) +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]. @@ -21,23 +61,3 @@ val el_liftn : int -> lift -> lift val el_lift : lift -> lift val reloc_rel : int -> lift -> int val is_lift_id : lift -> bool - -(*s Explicit substitutions of type ['a]. *) -type 'a subs = - | ESID of int (* ESID(n) = %n END bounded identity *) - | CONS of 'a array * 'a subs - (* CONS([|t1..tn|],S) = - (S.t1...tn) parallel substitution - beware of the order *) - | SHIFT of int * 'a subs (* SHIFT(n,S) = (^n o S) terms in S are relocated *) - (* with n vars *) - | LIFT of int * 'a subs (* LIFT(n,S) = (%n S) stands for ((^n o S).n...1) *) - -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 -val subs_shift_cons: int * 'a subs * 'a array -> 'a subs -val expand_rel: int -> 'a subs -> (int * 'a, int * int option) Util.union -val is_subs_id: 'a subs -> bool -val comp : ('a subs * 'a -> 'a) -> 'a subs -> 'a subs -> 'a subs diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index 941ab046..dd9720b3 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: indtypes.ml 12616 2009-12-30 15:02:26Z herbelin $ *) +(* $Id$ *) open Util open Names @@ -58,8 +58,8 @@ exception InductiveError of inductive_error let check_constructors_names = let rec check idset = function | [] -> idset - | c::cl -> - if Idset.mem c idset then + | c::cl -> + if Idset.mem c idset then raise (InductiveError (SameNamesConstructors c)) else check (Idset.add c idset) cl @@ -73,7 +73,7 @@ let check_constructors_names = let mind_check_names mie = let rec check indset cstset = function | [] -> () - | ind::inds -> + | ind::inds -> let id = ind.mind_entry_typename in let cl = ind.mind_entry_consnames in if Idset.mem id indset then @@ -89,7 +89,7 @@ let mind_check_names mie = let mind_check_arities env mie = let check_arity id c = - if not (is_arity env c) then + if not (is_arity env c) then raise (InductiveError (NotAnArity id)) in List.iter @@ -110,12 +110,12 @@ let is_small infos = List.for_all (fun (logic,small) -> small) infos let is_logic_constr infos = List.for_all (fun (logic,small) -> logic) infos (* An inductive definition is a "unit" if it has only one constructor - and that all arguments expected by this constructor are - logical, this is the case for equality, conjunction of logical properties + and that all arguments expected by this constructor are + logical, this is the case for equality, conjunction of logical properties *) let is_unit constrsinfos = match constrsinfos with (* One info = One constructor *) - | [constrinfos] -> is_logic_constr constrinfos + | [constrinfos] -> is_logic_constr constrinfos | [] -> (* type without constructors *) true | _ -> false @@ -132,7 +132,7 @@ let rec infos_and_sort env t = | _ -> (* don't fail if not positive, it is tested later *) [] let small_unit constrsinfos = - let issmall = List.for_all is_small constrsinfos + let issmall = List.for_all is_small constrsinfos and isunit = is_unit constrsinfos in issmall, isunit @@ -154,7 +154,7 @@ let small_unit constrsinfos = w1,w2,w3 <= u1 w1,w2 <= u2 w1,w2,w3 <= u3 -*) +*) let extract_level (_,_,_,lc,lev) = (* Enforce that the level is not in Prop if more than two constructors *) @@ -173,9 +173,7 @@ let inductive_levels arities inds = let constraint_list_union = List.fold_left Constraint.union Constraint.empty -let infer_constructor_packet env_ar params lc = - (* builds the typing context "Gamma, I1:A1, ... In:An, params" *) - let env_ar_par = push_rel_context params env_ar in +let infer_constructor_packet env_ar_par params lc = (* type-check the constructors *) let jlc,cstl = List.split (List.map (infer_type env_ar_par) lc) in let cst = constraint_list_union cstl in @@ -195,7 +193,6 @@ let typecheck_inductive env mie = if mie.mind_entry_inds = [] then anomaly "empty inductive types declaration"; (* Check unicity of names *) mind_check_names mie; - mind_check_arities env mie; (* Params are typed-checked here *) let env_params, params, cst1 = infer_local_decls env mie.mind_entry_params in (* We first type arity of each inductive definition *) @@ -213,11 +210,13 @@ let typecheck_inductive env mie = let full_arity = it_mkProd_or_LetIn arity.utj_val params in let cst = Constraint.union cst cst2 in let id = ind.mind_entry_typename in - let env_ar' = push_rel (Name id, None, full_arity) env_ar in + let env_ar' = + push_rel (Name id, None, full_arity) + (add_constraints cst2 env_ar) in let lev = (* Decide that if the conclusion is not explicitly Type *) (* then the inductive type is not polymorphic *) - match kind_of_term (snd (decompose_prod_assum arity.utj_val)) with + match kind_of_term ((strip_prod_assum arity.utj_val)) with | Sort (Type u) -> Some u | _ -> None in (cst,env_ar',(id,full_arity,lev)::l)) @@ -226,12 +225,16 @@ let typecheck_inductive env mie = let arity_list = List.rev rev_arity_list in + (* builds the typing context "Gamma, I1:A1, ... In:An, params" *) + let env_ar_par = + push_rel_context params (add_constraints cst1 env_arities) in + (* Now, we type the constructors (without params) *) let inds,cst = List.fold_right2 (fun ind arity_data (inds,cst) -> let (info,lc',cstrs_univ,cst') = - infer_constructor_packet env_arities params ind.mind_entry_lc in + 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')) @@ -242,11 +245,11 @@ let typecheck_inductive env mie = let inds = Array.of_list inds in let arities = Array.of_list arity_list in let param_ccls = List.fold_left (fun l (_,b,p) -> - if b = None then + if b = None then let _,c = dest_prod_assum env p in let u = match kind_of_term c with Sort (Type u) -> Some u | _ -> None in u::l - else + else l) [] params in (* Compute/check the sorts of the inductive types *) @@ -255,7 +258,7 @@ let typecheck_inductive env mie = array_fold_map2' (fun ((id,full_arity,ar_level),cn,info,lc,_) lev cst -> let sign, s = dest_arity env full_arity in let status,cst = match s with - | Type u when ar_level <> None (* Explicitly polymorphic *) + | Type u when ar_level <> None (* Explicitly polymorphic *) && no_upper_constraints u cst -> (* The polymorphic level is a function of the level of the *) (* conclusions of the parameters *) @@ -294,20 +297,20 @@ exception IllFormedInd of ill_formed_ind let mind_extract_params = decompose_prod_n_assum -let explain_ind_err id ntyp env0 nbpar c nargs err = +let explain_ind_err id ntyp env0 nbpar c nargs err = let (lpar,c') = mind_extract_params nbpar c in let env = push_rel_context lpar env0 in match err with - | LocalNonPos kt -> + | LocalNonPos kt -> raise (InductiveError (NonPos (env,c',mkRel (kt+nbpar)))) - | LocalNotEnoughArgs kt -> - raise (InductiveError + | LocalNotEnoughArgs kt -> + raise (InductiveError (NotEnoughArgs (env,c',mkRel (kt+nbpar)))) | LocalNotConstructor -> - raise (InductiveError + raise (InductiveError (NotConstructor (env,id,c',mkRel (ntyp+nbpar),nbpar,nargs))) | LocalNonPar (n,l) -> - raise (InductiveError + raise (InductiveError (NonPar (env,c',n,mkRel (nbpar-n+1), mkRel (l+nbpar)))) let failwith_non_pos n ntypes c = @@ -327,7 +330,7 @@ let failwith_non_pos_list n ntypes l = let check_correct_par (env,n,ntypes,_) hyps l largs = let nparams = rel_context_nhyps hyps in let largs = Array.of_list largs in - if Array.length largs < nparams then + if Array.length largs < nparams then raise (IllFormedInd (LocalNotEnoughArgs l)); let (lpar,largs') = array_chop nparams largs in let nhyps = List.length hyps in @@ -339,20 +342,20 @@ let check_correct_par (env,n,ntypes,_) hyps l largs = | Rel w when w = index -> check (k-1) (index+1) hyps | _ -> raise (IllFormedInd (LocalNonPar (k+1,l))) in check (nparams-1) (n-nhyps) hyps; - if not (array_for_all (noccur_between n ntypes) largs') then + if not (array_for_all (noccur_between n ntypes) largs') then failwith_non_pos_vect n ntypes largs' -(* Computes the maximum number of recursive parameters : - the first parameters which are constant in recursive arguments - n is the current depth, nmr is the maximum number of possible +(* Computes the maximum number of recursive parameters : + the first parameters which are constant in recursive arguments + n is the current depth, nmr is the maximum number of possible recursive parameters *) -let compute_rec_par (env,n,_,_) hyps nmr largs = +let compute_rec_par (env,n,_,_) hyps nmr largs = if nmr = 0 then 0 else (* start from 0, hyps will be in reverse order *) let (lpar,_) = list_chop nmr largs in - let rec find k index = - function + let rec find k index = + function ([],_) -> nmr | (_,[]) -> assert false (* |hyps|>=nmr *) | (lp,(_,Some _,_)::hyps) -> find k (index-1) (lp,hyps) @@ -364,14 +367,14 @@ if nmr = 0 then 0 else (* This removes global parameters of the inductive types in lc (for nested inductive types only ) *) -let abstract_mind_lc env ntyps npars lc = - if npars = 0 then +let abstract_mind_lc env ntyps npars lc = + if npars = 0 then lc - else - let make_abs = + else + let make_abs = list_tabulate - (function i -> lambda_implicit_lift npars (mkRel (i+1))) ntyps - in + (function i -> lambda_implicit_lift npars (mkRel (i+1))) ntyps + in Array.map (substl make_abs) lc (* [env] is the typing environment @@ -379,7 +382,7 @@ let abstract_mind_lc env ntyps npars lc = [ntypes] is the number of inductive types in the definition (i.e. range of inductives is [n; n+ntypes-1]) [lra] is the list of recursive tree of each variable - *) + *) let ienv_push_var (env, n, ntypes, lra) (x,a,ra) = (push_rel (x,None,a) env, n+1, ntypes, (Norec,ra)::lra) @@ -389,13 +392,22 @@ let ienv_push_inductive (env, n, ntypes, ra_env) (mi,lpar) = let env' = push_rel (Anonymous,None, hnf_prod_applist env (type_of_inductive env specif) lpar) env in - let ra_env' = + let ra_env' = (Imbr mi,(Rtree.mk_rec_calls 1).(0)) :: List.map (fun (r,t) -> (r,Rtree.lift 1 t)) ra_env in (* New index of the inductive types *) let newidx = n + auxntyp in (env', newidx, ntypes, ra_env') +let rec ienv_decompose_prod (env,_,_,_ as ienv) n c = + if n=0 then (ienv,c) else + let c' = whd_betadeltaiota env c in + match kind_of_term c' with + Prod(na,a,b) -> + let ienv' = ienv_push_var ienv (na,a,mk_norec) in + ienv_decompose_prod ienv' (n-1) b + | _ -> assert false + let array_min nmr a = if nmr = 0 then 0 else Array.fold_left (fun k (nmri,_) -> min k nmri) nmr a @@ -404,8 +416,8 @@ let array_min nmr a = if nmr = 0 then 0 else let check_positivity_one (env, _,ntypes,_ as ienv) hyps i nargs lcnames indlc = let lparams = rel_context_length hyps in let nmr = rel_context_nhyps hyps in - (* check the inductive types occur positively in [c] *) - let rec check_pos (env, n, ntypes, ra_env as ienv) nmr c = + (* Checking the (strict) positivity of a constructor argument type [c] *) + let rec check_pos (env, n, ntypes, ra_env as ienv) nmr c = let x,largs = decompose_app (whd_betadeltaiota env c) in match kind_of_term x with | Prod (na,b,d) -> @@ -415,40 +427,41 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps i nargs lcnames indlc = | Some b -> check_pos (ienv_push_var ienv (na, b, mk_norec)) nmr d) | Rel k -> - (try let (ra,rarg) = List.nth ra_env (k-1) in + (try let (ra,rarg) = List.nth ra_env (k-1) in let nmr1 = (match ra with Mrec _ -> compute_rec_par ienv hyps nmr largs | _ -> nmr) - in + in if not (List.for_all (noccur_between n ntypes) largs) then failwith_non_pos_list n ntypes largs else (nmr1,rarg) with Failure _ | Invalid_argument _ -> (nmr,mk_norec)) | Ind ind_kn -> (* If the inductive type being defined appears in a - parameter, then we have an imbricated type *) + parameter, then we have a nested indtype *) if List.for_all (noccur_between n ntypes) largs then (nmr,mk_norec) - else check_positive_imbr ienv nmr (ind_kn, largs) - | err -> + else check_positive_nested ienv nmr (ind_kn, largs) + | err -> if noccur_between n ntypes x && - List.for_all (noccur_between n ntypes) largs + List.for_all (noccur_between n ntypes) largs then (nmr,mk_norec) else failwith_non_pos_list n ntypes (x::largs) (* accesses to the environment are not factorised, but is it worth? *) - and check_positive_imbr (env,n,ntypes,ra_env as ienv) nmr (mi, largs) = + and check_positive_nested (env,n,ntypes,ra_env as ienv) nmr (mi, largs) = let (mib,mip) = lookup_mind_specif env mi in let auxnpar = mib.mind_nparams_rec in + let nonrecpar = mib.mind_nparams - auxnpar in let (lpar,auxlargs) = - try list_chop auxnpar largs - with Failure _ -> raise (IllFormedInd (LocalNonPos n)) in + try list_chop auxnpar largs + 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 - raise (IllFormedInd (LocalNonPos n)); + failwith_non_pos_list n ntypes auxlargs; (* We do not deal with imbricated mutual inductive types *) - let auxntyp = mib.mind_ntypes in + let auxntyp = mib.mind_ntypes in if auxntyp <> 1 then raise (IllFormedInd (LocalNonPos n)); (* The nested inductive type with parameters removed *) let auxlcvect = abstract_mind_lc env auxntyp auxnpar mip.mind_nf_lc in @@ -457,35 +470,37 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps i nargs lcnames indlc = let (env',_,_,_ as ienv') = ienv_push_inductive ienv (mi,lpar) in (* Parameters expressed in env' *) let lpar' = List.map (lift auxntyp) lpar in - let irecargs_nmr = + let irecargs_nmr = (* fails if the inductive type occurs non positively *) - (* when substituted *) - Array.map - (function c -> - let c' = hnf_prod_applist env' c lpar' in - check_constructors ienv' false nmr c') + (* with recursive parameters substituted *) + Array.map + (function c -> + let c' = hnf_prod_applist env' c lpar' in + (* skip non-recursive parameters *) + let (ienv',c') = ienv_decompose_prod ienv' nonrecpar c' in + check_constructors ienv' false nmr c') auxlcvect in let irecargs = Array.map snd irecargs_nmr and nmr' = array_min nmr irecargs_nmr - in + in (nmr',(Rtree.mk_rec [|mk_paths (Imbr mi) irecargs|]).(0)) - + (* check the inductive types occur positively in the products of C, if check_head=true, also check the head corresponds to a constructor of - the ith type *) - - and check_constructors ienv check_head nmr c = - let rec check_constr_rec (env,n,ntypes,ra_env as ienv) nmr lrec c = + the ith type *) + + and check_constructors ienv check_head nmr c = + let rec check_constr_rec (env,n,ntypes,ra_env as ienv) nmr lrec c = let x,largs = decompose_app (whd_betadeltaiota env c) in match kind_of_term x with - | Prod (na,b,d) -> + | Prod (na,b,d) -> assert (largs = []); - let nmr',recarg = check_pos ienv nmr b in + let nmr',recarg = check_pos ienv nmr b in let ienv' = ienv_push_var ienv (na,b,mk_norec) in check_constr_rec ienv' nmr' (recarg::lrec) d - + | hd -> if check_head then if hd = Rel (n+ntypes-i-1) then @@ -504,7 +519,7 @@ let check_positivity_one (env, _,ntypes,_ as ienv) hyps i nargs lcnames indlc = let _,rawc = mind_extract_params lparams c in try check_constructors ienv true nmr rawc - with IllFormedInd err -> + with IllFormedInd err -> explain_ind_err id (ntypes-i) env lparams c nargs err) (Array.of_list lcnames) indlc in @@ -523,9 +538,9 @@ 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 i nargs lcnames lc in - let irecargs_nmr = Array.mapi check_one inds in + let irecargs_nmr = Array.mapi check_one inds in let irecargs = Array.map snd irecargs_nmr and nmr' = array_min nmr irecargs_nmr in (nmr',Rtree.mk_rec irecargs) @@ -534,14 +549,14 @@ 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 +(* 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 + in array_exists one_is_rec *) @@ -585,6 +600,7 @@ let build_inductive env env_ar params isrecord isfinite inds nmr recargs cst = (* Compute the set of used section variables *) let hyps = used_section_variables env inds in let nparamargs = rel_context_nhyps params in + let nparamdecls = rel_context_length params in (* Check one inductive *) let build_one_packet (id,cnames,lc,(ar_sign,ar_kind)) recarg = (* Type of constructors in normal form *) @@ -594,37 +610,39 @@ let build_inductive env env_ar params isrecord isfinite inds nmr recargs cst = let consnrealargs = Array.map (fun (d,_) -> rel_context_length d - rel_context_length params) splayed_lc in - (* Elimination sorts *) + (* Elimination sorts *) let arkind,kelim = match ar_kind with | Inr (param_levels,lev) -> Polymorphic { poly_param_levels = param_levels; - poly_level = lev; + poly_level = lev; }, all_sorts | Inl ((issmall,isunit),ar,s) -> let kelim = allowed_sorts issmall isunit s in Monomorphic { mind_user_arity = ar; - mind_sort = s; + mind_sort = s; }, kelim in - let nconst, nblock = ref 0, ref 0 in + (* Assigning VM tags to constructors *) + let nconst, nblock = ref 0, ref 0 in let transf num = let arity = List.length (dest_subterms recarg).(num) in - if arity = 0 then + if arity = 0 then let p = (!nconst, 0) in incr nconst; p - else + else let p = (!nblock + 1, arity) in incr nblock; p (* les tag des constructeur constant commence a 0, les tag des constructeur non constant a 1 (0 => accumulator) *) - in + in let rtbl = Array.init (List.length cnames) transf in (* Build the inductive packet *) { mind_typename = id; mind_arity = arkind; mind_arity_ctxt = ar_sign; mind_nrealargs = rel_context_nhyps ar_sign - nparamargs; + mind_nrealargs_ctxt = rel_context_length ar_sign - nparamdecls; mind_kelim = kelim; mind_consnames = Array.of_list cnames; mind_consnrealdecls = consnrealargs; @@ -642,11 +660,10 @@ let build_inductive env env_ar params isrecord isfinite inds nmr recargs cst = mind_finite = isfinite; mind_hyps = hyps; mind_nparams = nparamargs; - mind_nparams_rec = nmr; + mind_nparams_rec = nmr; mind_params_ctxt = params; mind_packets = packets; - mind_constraints = cst; - mind_equiv = None; + mind_constraints = cst } (************************************************************************) diff --git a/kernel/indtypes.mli b/kernel/indtypes.mli index 90ae70c3..0cbe1503 100644 --- a/kernel/indtypes.mli +++ b/kernel/indtypes.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: indtypes.mli 11784 2009-01-14 11:36:32Z herbelin $ i*) +(*i $Id$ i*) (*i*) open Names diff --git a/kernel/inductive.ml b/kernel/inductive.ml index 99ec1650..5bcba626 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: inductive.ml 11647 2008-12-02 10:40:11Z barras $ *) +(* $Id$ *) open Util open Names @@ -55,7 +55,7 @@ let inductive_params (mib,_) = mib.mind_nparams (* inductives *) let ind_subst mind mib = let ntypes = mib.mind_ntypes in - let make_Ik k = mkInd (mind,ntypes-k-1) in + let make_Ik k = mkInd (mind,ntypes-k-1) in list_tabulate make_Ik ntypes (* Instantiate inductives in constructor type *) @@ -64,7 +64,7 @@ let constructor_instantiate mind mib c = substl s c let instantiate_params full t args sign = - let fail () = + let fail () = anomaly "instantiate_params: type, ctxt and args mismatch" in let (rem_args, subs, ty) = Sign.fold_rel_context @@ -75,7 +75,7 @@ let instantiate_params full t args sign = | (_,[],_) -> if full then fail() else ([], subs, ty) | _ -> fail ()) sign - ~init:(args,[],t) + ~init:(args,[],t) in if rem_args <> [] then fail(); substl subs ty @@ -101,11 +101,11 @@ let full_constructor_instantiate ((mind,_),(mib,_),params) = 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: I_i: forall uniformparams:utyps, forall otherparams:otyps, Type(a) -uniformargs : utyps +uniformargs : utyps otherargs : otyps I_1:forall ...,s_1;...I_n:forall ...,s_n |- sort(C_kj(uniformargs)) = s_kj s'_k = max(..s_kj..) @@ -221,11 +221,11 @@ let type_of_constructor cstr (mib,mip) = if i > nconstr then error "Not enough constructors in the type."; constructor_instantiate (fst ind) mib specif.(i-1) -let arities_of_specif kn (mib,mip) = +let arities_of_specif kn (mib,mip) = let specif = mip.mind_nf_lc in Array.map (constructor_instantiate kn mib) specif -let arities_of_constructors ind specif = +let arities_of_constructors ind specif = arities_of_specif (fst ind) specif let type_of_constructors ind (mib,mip) = @@ -250,7 +250,7 @@ let local_rels ctxt = None -> (mkRel n :: rels, n+1) | Some _ -> (rels, n+1)) ~init:([],1) - ctxt + ctxt in rels @@ -258,7 +258,7 @@ let local_rels ctxt = let inductive_sort_family mip = match mip.mind_arity with - | Monomorphic s -> family_of_sort s.mind_sort + | Monomorphic s -> family_of_sort s.mind_sort | Polymorphic _ -> InType let mind_arity mip = @@ -270,26 +270,30 @@ let get_instantiated_arity (mib,mip) params = let elim_sorts (_,mip) = mip.mind_kelim -let rel_list n m = - let rec reln l p = - if p>m then l else reln (mkRel(n+p)::l) (p+1) - in - reln [] 1 +let extended_rel_list n hyps = + let rec reln l p = function + | (_,None,_) :: hyps -> reln (mkRel (n+p) :: l) (p+1) hyps + | (_,Some _,_) :: hyps -> reln l (p+1) hyps + | [] -> l + in + reln [] 1 hyps let build_dependent_inductive ind (_,mip) params = - let nrealargs = mip.mind_nrealargs in - applist - (mkInd ind, (List.map (lift nrealargs) params)@(rel_list 0 nrealargs)) + let realargs,_ = list_chop mip.mind_nrealargs_ctxt mip.mind_arity_ctxt in + applist + (mkInd ind, + List.map (lift mip.mind_nrealargs_ctxt) params + @ extended_rel_list 0 realargs) (* This exception is local *) 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 + 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))) -let is_correct_arity env c pj ind specif params = +let is_correct_arity env c pj ind specif params = let arsign,_ = get_instantiated_arity specif params in let rec srec env pt ar u = let pt' = whd_betadeltaiota env pt in @@ -301,20 +305,19 @@ let is_correct_arity env c pj ind specif params = srec (push_rel (na1,None,a1) env) t ar' (Constraint.union 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 + | Sort s -> family_of_sort s | _ -> raise (LocalArity None) in - let dep_ind = build_dependent_inductive ind specif params in + let dep_ind = build_dependent_inductive ind specif params in let univ = try conv env a1 dep_ind with NotConvertible -> raise (LocalArity None) in check_allowed_sort ksort specif; - (true, Constraint.union u univ) - | Sort s', [] -> - check_allowed_sort (family_of_sort s') specif; - (false, u) + Constraint.union u univ + | _, (_,Some _,_ as d)::ar' -> + srec (push_rel d env) (lift 1 pt') ar' u | _ -> raise (LocalArity None) - in + in try srec env pj.uj_type (List.rev arsign) Constraint.empty with LocalArity kinds -> error_elim_arity env ind (elim_sorts specif) c pj kinds @@ -325,7 +328,7 @@ let is_correct_arity env c pj ind specif params = (* [p] is the predicate, [i] is the constructor number (starting from 0), and [cty] is the type of the constructor (params not instantiated) *) -let build_branches_type ind (_,mip as specif) params dep p = +let build_branches_type ind (_,mip as specif) params p = let build_one_branch i cty = let typi = full_constructor_instantiate (ind,specif,params) cty in let (args,ccl) = decompose_prod_assum typi in @@ -333,50 +336,36 @@ let build_branches_type ind (_,mip as specif) params dep p = let (_,allargs) = decompose_app ccl in let (lparams,vargs) = list_chop (inductive_params specif) allargs in let cargs = - if dep then - let cstr = ith_constructor_of_inductive ind (i+1) in - let dep_cstr = applist (mkConstruct cstr,lparams@(local_rels args)) in - vargs @ [dep_cstr] - else - vargs in + let cstr = ith_constructor_of_inductive ind (i+1) in + let dep_cstr = applist (mkConstruct cstr,lparams@(local_rels args)) in + vargs @ [dep_cstr] in let base = beta_appvect (lift nargs p) (Array.of_list cargs) in it_mkProd_or_LetIn base args in Array.mapi build_one_branch mip.mind_nf_lc (* [p] is the predicate, [c] is the match object, [realargs] is the list of real args of the inductive type *) -let build_case_type dep p c realargs = - let args = if dep then realargs@[c] else realargs in - beta_appvect p (Array.of_list args) +let build_case_type n p c realargs = + whd_betaiota (betazeta_appvect (n+1) p (Array.of_list (realargs@[c]))) let type_case_branches env (ind,largs) pj c = - let specif = lookup_mind_specif env ind in + let specif = lookup_mind_specif env ind in let nparams = inductive_params specif in let (params,realargs) = list_chop nparams largs in let p = pj.uj_val in - let (dep,univ) = is_correct_arity env c pj ind specif params in - let lc = build_branches_type ind specif params dep p in - let ty = build_case_type dep p c realargs in + let univ = is_correct_arity env c pj ind specif params in + let lc = build_branches_type ind specif params p in + let ty = build_case_type (snd specif).mind_nrealargs_ctxt p c realargs in (lc, ty, univ) (************************************************************************) (* Checking the case annotation is relevent *) -let rec inductive_kn_equiv env kn1 kn2 = - match (lookup_mind kn1 env).mind_equiv with - | Some kn1' -> inductive_kn_equiv env kn2 kn1' - | None -> match (lookup_mind kn2 env).mind_equiv with - | Some kn2' -> inductive_kn_equiv env kn2' kn1 - | None -> false - -let inductive_equiv env (kn1,i1) (kn2,i2) = - i1=i2 & inductive_kn_equiv env kn1 kn2 - let check_case_info env indsp ci = let (mib,mip) = lookup_mind_specif env indsp in if - not (Closure.mind_equiv env indsp ci.ci_ind) or + not (eq_ind indsp ci.ci_ind) or (mib.mind_nparams <> ci.ci_npar) or (mip.mind_consnrealdecls <> ci.ci_cstr_nargs) then raise (TypeError(env,WrongCaseInfo(indsp,ci))) @@ -386,7 +375,7 @@ let check_case_info env indsp ci = (* Guard conditions for fix and cofix-points *) -(* Check if t is a subterm of Rel n, and gives its specification, +(* Check if t is a subterm of Rel n, and gives its specification, assuming lst already gives index of subterms with corresponding specifications of recursive arguments *) @@ -431,7 +420,7 @@ type subterm_spec = let spec_of_tree t = if Rtree.eq_rtree (=) t mk_norec then Not_subterm else Subterm(Strict,t) - + let subterm_spec_glb = let glb2 s1 s2 = match s1,s2 with @@ -444,7 +433,7 @@ let subterm_spec_glb = (* branches do not return objects with same spec *) else Not_subterm in Array.fold_left glb2 Dead_code - + type guard_env = { env : env; (* dB of last fixpoint *) @@ -468,7 +457,7 @@ let make_renv env minds recarg (kn,tyi) = genv = [Subterm(Large,mind_recvec.(tyi))] } let push_var renv (x,ty,spec) = - { renv with + { renv with env = push_rel (x,None,ty) renv.env; rel_min = renv.rel_min+1; genv = spec:: renv.genv } @@ -480,7 +469,7 @@ let push_var_renv renv (x,ty) = push_var renv (x,ty,Not_subterm) (* Fetch recursive information about a variable p *) -let subterm_var p renv = +let subterm_var p renv = try List.nth renv.genv (p-1) with Failure _ | Invalid_argument _ -> Not_subterm @@ -490,7 +479,7 @@ let add_subterm renv (x,a,spec) = let push_ctxt_renv renv ctxt = let n = rel_context_length ctxt in - { renv with + { renv with env = push_rel_context ctxt renv.env; rel_min = renv.rel_min+n; genv = iterate (fun ge -> Not_subterm::ge) n renv.genv } @@ -529,8 +518,8 @@ let lookup_subterms env ind = 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 rec push_branch_args renv lrec c = +let case_branches_specif renv c_spec ind lbr = + let rec push_branch_args renv lrec c = match lrec with ra::lr -> let c' = whd_betadeltaiota renv.env c in @@ -546,7 +535,7 @@ let case_branches_specif renv c_spec ind lbr = let sub_spec = Array.map (List.map spec_of_tree) (dest_subterms t) in assert (Array.length sub_spec = Array.length lbr); array_map2 (push_branch_args renv) sub_spec lbr - | Dead_code -> + | Dead_code -> let t = dest_subterms (lookup_subterms renv.env ind) in let sub_spec = Array.map (List.map (fun _ -> Dead_code)) t in assert (Array.length sub_spec = Array.length lbr); @@ -559,22 +548,19 @@ let case_branches_specif renv c_spec ind lbr = about variables. *) -let rec subterm_specif renv t = +let rec subterm_specif renv t = (* maybe reduction is not always necessary! *) let f,l = decompose_app (whd_betadeltaiota renv.env t) in - match kind_of_term f with + match kind_of_term f with | Rel k -> subterm_var k renv | Case (ci,_,c,lbr) -> - if Array.length lbr = 0 then Dead_code - else - let c_spec = subterm_specif renv c in - let lbr_spec = case_branches_specif renv c_spec ci.ci_ind lbr in - let stl = - Array.map (fun (renv',br') -> subterm_specif renv' br') - lbr_spec in - subterm_spec_glb stl - + 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 @@ -597,7 +583,7 @@ let rec subterm_specif renv t = (* Why Strict here ? To be general, it could also be Large... *) assign_var_spec renv' (nbfix-i, Subterm(Strict,recargs)) in - let decrArg = recindxs.(i) 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 @@ -611,7 +597,7 @@ let rec subterm_specif renv t = assign_var_spec renv'' (1, arg_spec) in subterm_specif renv'' strippedBody) - | Lambda (x,a,b) -> + | Lambda (x,a,b) -> assert (l=[]); subterm_specif (push_var_renv renv (x,a)) b @@ -621,9 +607,14 @@ let rec subterm_specif renv t = (* Other terms are not subterms *) | _ -> Not_subterm - +and case_subterm_specif renv ci c lbr = + if Array.length lbr = 0 then [||] + else + let c_spec = subterm_specif renv c in + case_branches_specif renv c_spec ci.ci_ind lbr + (* Check term c can be applied to one of the mutual fixpoints. *) -let check_is_subterm renv c = +let check_is_subterm renv c = match subterm_specif renv c with Subterm (Strict,_) | Dead_code -> true | _ -> false @@ -651,21 +642,21 @@ let error_partial_apply renv fx = given [recpos], the decreasing arguments of each mutually defined fixpoint. *) let check_one_fix renv recpos def = - let nfi = Array.length recpos in + let nfi = Array.length recpos in (* Checks if [t] only make valid recursive calls *) - let rec check_rec_call renv t = + let rec check_rec_call renv t = (* if [t] does not make recursive calls, it is guarded: *) if noccur_with_meta renv.rel_min nfi t then () else let (f,l) = decompose_app (whd_betaiotazeta t) in match kind_of_term f with - | Rel p -> - (* Test if [p] is a fixpoint (recursive call) *) + | Rel p -> + (* 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; - (* the position of the invoked fixpoint: *) + (* 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 @@ -691,31 +682,29 @@ let check_one_fix renv recpos def = List.iter (check_rec_call renv) (c_0::p::l); (* compute the recarg information for the arguments of each branch *) - let c_spec = subterm_specif renv c_0 in - let lbr = case_branches_specif renv c_spec ci.ci_ind lrest in + let lbr = case_subterm_specif renv ci c_0 lrest in Array.iter (fun (renv',br') -> check_rec_call renv' br') lbr (* Enables to traverse Fixpoint definitions in a more intelligent way, ie, the rule : - if - g = Fix g/p := [y1:T1]...[yp:Tp]e & - - f is guarded with respect to the set of pattern variables S + if - g = fix g (y1:T1)...(yp:Tp) {struct yp} := e & + - f is guarded with respect to the set of pattern variables S in a1 ... am & - - f is guarded with respect to the set of pattern variables S + - f is guarded with respect to the set of pattern variables S in T1 ... Tp & - ap is a sub-term of the formal argument of f & - f is guarded with respect to the set of pattern variables S+{yp} in e 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; let decrArg = recindxs.(i) in - let renv' = push_fix_renv renv recdef in + let renv' = push_fix_renv renv recdef in if (List.length l < (decrArg+1)) then Array.iter (check_rec_call renv') bodies - else + else Array.iteri (fun j body -> if i=j then @@ -725,8 +714,8 @@ let check_one_fix renv recpos def = else check_rec_call renv' body) bodies - | Const kn -> - if evaluable_constant kn renv.env then + | Const kn -> + if evaluable_constant kn renv.env then try List.iter (check_rec_call renv) l with (FixGuardError _ ) -> check_rec_call renv(applist(constant_value renv.env kn, l)) @@ -734,14 +723,14 @@ let check_one_fix renv recpos def = (* The cases below simply check recursively the condition on the subterms *) - | Cast (a,_, b) -> + | Cast (a,_, b) -> List.iter (check_rec_call renv) (a::b::l) | Lambda (x,a,b) -> List.iter (check_rec_call renv) (a::l); check_rec_call (push_var_renv renv (x,a)) b - | Prod (x,a,b) -> + | Prod (x,a,b) -> List.iter (check_rec_call renv) (a::l); check_rec_call (push_var_renv renv (x,a)) b @@ -787,9 +776,9 @@ let judgment_of_fixpoint (_, types, bodies) = array_map2 (fun typ body -> { uj_val = body ; uj_type = typ }) types bodies let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) = - let nbfix = Array.length bodies in + let nbfix = Array.length bodies in if nbfix = 0 - or Array.length nvect <> nbfix + or Array.length nvect <> nbfix or Array.length types <> nbfix or Array.length names <> nbfix or bodynum < 0 @@ -800,18 +789,18 @@ let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) = let raise_err env i err = error_ill_formed_rec_body env err names i fixenv vdefj in (* Check the i-th definition with recarg k *) - let find_ind i k def = - (* check fi does not appear in the k+1 first abstractions, + let find_ind i k def = + (* check fi does not appear in the k+1 first abstractions, gives the type of the k+1-eme abstraction (must be an inductive) *) - let rec check_occur env n def = + let rec check_occur env n def = match kind_of_term (whd_betadeltaiota env def) with - | Lambda (x,a,b) -> + | Lambda (x,a,b) -> if noccur_with_meta n nbfix a then let env' = push_rel (x, None, a) env in if n = k+1 then (* get the inductive type of the fixpoint *) - let (mind, _) = - try find_inductive env a + let (mind, _) = + try find_inductive env a with Not_found -> raise_err env i (RecursionNotOnInductiveType a) in (mind, (env', b)) @@ -831,7 +820,7 @@ let check_fix env ((nvect,_),(names,_,bodies as recdef) as fix) = let renv = make_renv fenv minds 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 + error_ill_formed_rec_body fixenv err names i (push_rec_types recdef env) (judgment_of_fixpoint recdef) done @@ -852,17 +841,17 @@ let rec codomain_is_coind env c = let b = whd_betadeltaiota env c in match kind_of_term b with | Prod (x,a,b) -> - codomain_is_coind (push_rel (x, None, a) env) b - | _ -> + codomain_is_coind (push_rel (x, None, a) env) b + | _ -> (try find_coinductive env b with Not_found -> raise (CoFixGuardError (env, CodomainNotInductiveType b))) -let check_one_cofix env nbfix def deftype = +let check_one_cofix env nbfix def deftype = let rec check_rec_call env alreadygrd n vlra t = if not (noccur_with_meta n nbfix t) then let c,args = decompose_app (whd_betadeltaiota env t) in - match kind_of_term c with + match kind_of_term c with | Rel p when n <= p && p < n+nbfix -> (* recursive call: must be guarded and no nested recursive call allowed *) @@ -870,14 +859,14 @@ let check_one_cofix env nbfix def deftype = raise (CoFixGuardError (env,UnguardedRecursiveCall t)) else if not(List.for_all (noccur_with_meta n nbfix) args) then raise (CoFixGuardError (env,NestedRecursiveOccurrences)) - + | Construct (_,i as cstr_kn) -> - let lra = vlra.(i-1) in + let lra = vlra.(i-1) in let mI = inductive_of_constructor cstr_kn in let (mib,mip) = lookup_mind_specif env mI in let realargs = list_skipn mib.mind_nparams args in let rec process_args_of_constr = function - | (t::lr), (rar::lrar) -> + | (t::lr), (rar::lrar) -> if rar = mk_norec then if noccur_with_meta n nbfix t then process_args_of_constr (lr, lrar) @@ -888,26 +877,26 @@ let check_one_cofix env nbfix def deftype = check_rec_call env true n spec t; process_args_of_constr (lr, lrar) | [],_ -> () - | _ -> anomaly_ill_typed () + | _ -> anomaly_ill_typed () in process_args_of_constr (realargs, lra) - + | Lambda (x,a,b) -> assert (args = []); if noccur_with_meta n nbfix a then let env' = push_rel (x, None, a) env in check_rec_call env' alreadygrd (n+1) vlra b - else + else raise (CoFixGuardError (env,RecCallInTypeOfAbstraction a)) - + | CoFix (j,(_,varit,vdefs as recdef)) -> if (List.for_all (noccur_with_meta n nbfix) args) - then + then let nbfix = Array.length vdefs in if (array_for_all (noccur_with_meta n nbfix) varit) then let env' = push_rec_types recdef env in (Array.iter (check_rec_call env' alreadygrd (n+1) vlra) vdefs; List.iter (check_rec_call env alreadygrd n vlra) args) - else + else raise (CoFixGuardError (env,RecCallInTypeOfDef c)) else raise (CoFixGuardError (env,UnguardedRecursiveCall c)) @@ -917,32 +906,32 @@ let check_one_cofix env nbfix def deftype = if (noccur_with_meta n nbfix tm) then if (List.for_all (noccur_with_meta n nbfix) args) then Array.iter (check_rec_call env alreadygrd n vlra) vrest - else + else raise (CoFixGuardError (env,RecCallInCaseFun c)) - else + else raise (CoFixGuardError (env,RecCallInCaseArg c)) - else + else raise (CoFixGuardError (env,RecCallInCasePred c)) - + | Meta _ -> () | Evar _ -> List.iter (check_rec_call env alreadygrd n vlra) args - - | _ -> raise (CoFixGuardError (env,NotGuardedForm t)) in + + | _ -> raise (CoFixGuardError (env,NotGuardedForm t)) in let (mind, _) = codomain_is_coind env deftype in let vlra = lookup_subterms env mind in check_rec_call env false 1 (dest_subterms vlra) def -(* The function which checks that the whole block of definitions +(* The function which checks that the whole block of definitions satisfies the guarded condition *) -let check_cofix env (bodynum,(names,types,bodies as recdef)) = - let nbfix = Array.length bodies in +let check_cofix env (bodynum,(names,types,bodies as recdef)) = + let nbfix = Array.length bodies in for i = 0 to nbfix-1 do let fixenv = push_rec_types recdef env in try check_one_cofix fixenv nbfix bodies.(i) types.(i) - with CoFixGuardError (errenv,err) -> - error_ill_formed_rec_body errenv err names i + with CoFixGuardError (errenv,err) -> + error_ill_formed_rec_body errenv err names i fixenv (judgment_of_fixpoint recdef) done diff --git a/kernel/inductive.mli b/kernel/inductive.mli index 8059051b..9ab78cc4 100644 --- a/kernel/inductive.mli +++ b/kernel/inductive.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: inductive.mli 11301 2008-08-04 19:41:18Z herbelin $ i*) +(*i $Id$ i*) (*i*) open Names @@ -51,8 +51,9 @@ val arities_of_constructors : inductive -> mind_specif -> types array val type_of_constructors : inductive -> mind_specif -> types array (* Transforms inductive specification into types (in nf) *) -val arities_of_specif : mutual_inductive -> mind_specif -> types array +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 about the following Cases expression: @@ -65,8 +66,12 @@ val type_case_branches : env -> inductive * constr list -> unsafe_judgment -> constr -> types array * types * constraints +val build_branches_type : + inductive -> mutual_inductive_body * one_inductive_body -> + constr list -> constr -> types array + (* Return the arity of an inductive type *) -val mind_arity : one_inductive_body -> Sign.rel_context * sorts_family +val mind_arity : one_inductive_body -> rel_context * sorts_family val inductive_sort_family : one_inductive_body -> sorts_family @@ -85,8 +90,8 @@ val type_of_inductive_knowing_parameters : val max_inductive_sort : sorts array -> universe -val instantiate_universes : env -> Sign.rel_context -> - polymorphic_arity -> types array -> Sign.rel_context * sorts +val instantiate_universes : env -> rel_context -> + polymorphic_arity -> types array -> rel_context * sorts (***************************************************************) (* Debug *) diff --git a/kernel/kernel.mllib b/kernel/kernel.mllib new file mode 100644 index 00000000..a628e5cf --- /dev/null +++ b/kernel/kernel.mllib @@ -0,0 +1,32 @@ +Names +Univ +Esubst +Term +Mod_subst +Sign +Cbytecodes +Copcodes +Cemitcodes +Declarations +Retroknowledge +Pre_env +Cbytegen +Environ +Conv_oracle +Closure +Reduction +Type_errors +Entries +Modops +Inductive +Typeops +Indtypes +Cooking +Term_typing +Subtyping +Mod_typing +Safe_typing + +Vm +Csymtable +Vconv
\ No newline at end of file diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml index 9a76922b..f85cfaaf 100644 --- a/kernel/mod_subst.ml +++ b/kernel/mod_subst.ml @@ -6,97 +6,299 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: mod_subst.ml 11924 2009-02-13 13:51:54Z soubiran $ *) +(* $Id$ *) open Pp open Util open Names open Term -(* WARNING: not every constant in the associative list domain used to exist - in the environment. This allows a simple implementation of the join - operation. However, iterating over the associative list becomes a non-sense -*) -type resolver = (constant * constr option) list -let make_resolver resolve = resolve +type delta_hint = + Inline of constr option + | Equiv of kernel_name + | Prefix_equiv of module_path -let apply_opt_resolver resolve kn = - match resolve with - None -> None - | Some resolve -> - try List.assoc kn resolve with Not_found -> None +type delta_key = + KN of kernel_name + | MP of module_path + +module Deltamap = Map.Make(struct + type t = delta_key + let compare = Pervasives.compare + end) + +type delta_resolver = delta_hint Deltamap.t + +let empty_delta_resolver = Deltamap.empty type substitution_domain = - MSI of mod_self_id | MBI of mod_bound_id | MPI of module_path let string_of_subst_domain = function - MSI msid -> debug_string_of_msid msid | MBI mbid -> debug_string_of_mbid mbid | MPI mp -> string_of_mp mp -module Umap = Map.Make(struct +module Umap = Map.Make(struct type t = substitution_domain let compare = Pervasives.compare end) -type substitution = (module_path * resolver option) Umap.t - +type substitution = (module_path * delta_resolver) Umap.t + let empty_subst = Umap.empty -let add_msid msid mp = - Umap.add (MSI msid) (mp,None) + +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 = - Umap.add (MPI mp1) (mp2,None) +let add_mp mp1 mp2 resolve = + Umap.add (MPI mp1) (mp2,resolve) -let map_msid msid mp = add_msid msid mp empty_subst let map_mbid mbid mp resolve = add_mbid mbid mp resolve empty_subst -let map_mp mp1 mp2 = add_mp mp1 mp2 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 remove_mp_delta_resolver resolver mp = + Deltamap.remove (MP mp) resolver + +exception Inline_kn + +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" + in + try + sub_mp mp + with + Not_found -> mp + +exception Change_equiv_to_inline of 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 + + +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 + +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 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 + +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 [] + +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 + +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,_) l = - (string_of_subst_domain uid, string_of_mp mp)::l + 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) -> s1^"|->"^s2) (list_contents sub) in + +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 debug_pr_subst sub = let l = list_contents sub in - let f (s1,s2) = hov 2 (str s1 ++ spc () ++ str "|-> " ++ str s2) + 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_coma f l) ++ str "}" - - + 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 - | MPself sid -> - let mp',resolve = Umap.find (MSI sid) sub in + | MPfile sid -> + let mp',resolve = Umap.find (MPI (MPfile sid)) sub in mp',resolve | MPbound bid -> - let mp',resolve = Umap.find (MBI bid) sub in - mp',resolve + 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 + end | MPdot (mp1,l) as mp2 -> begin - try + try let mp',resolve = Umap.find (MPI mp2) sub in mp',resolve - with Not_found -> + with Not_found -> let mp1',resolve = aux mp1 in MPdot (mp1',l),resolve end - | _ -> raise Not_found in try - Some (aux mp) + Some (aux mp) with Not_found -> None let subst_mp sub mp = @@ -104,39 +306,126 @@ let subst_mp sub mp = None -> mp | Some (mp',_) -> mp' +let subst_kn_delta sub kn = + let mp,dir,l = repr_kn kn in + match subst_mp0 sub mp with + Some (mp',resolve) -> + solve_delta_kn resolve (make_kn mp' dir l) + | None -> kn + -let subst_kn0 sub kn = +let subst_kn sub kn = let mp,dir,l = repr_kn kn in match subst_mp0 sub mp with Some (mp',_) -> - Some (make_kn mp' dir l) - | None -> None + (make_kn mp' dir l) + | None -> kn -let subst_kn sub kn = - match subst_kn0 sub kn with - None -> kn - | Some kn' -> kn' +exception No_subst + +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 subst_con sub con = - let mp,dir,l = repr_con con in - match subst_mp0 sub mp with - None -> con,mkConst con - | Some (mp',resolve) -> - let con' = make_con mp' dir l in - match apply_opt_resolver resolve con with - None -> con',mkConst con' - | Some t -> con',t + 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 + 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 -> con',t + with No_subst -> con , mkConst con + let subst_con0 sub con = - let mp,dir,l = repr_con con in - match subst_mp0 sub mp with - None -> None - | Some (mp',resolve) -> - let con' = make_con mp' dir l in - match apply_opt_resolver resolve con with - None -> Some (mkConst con') - | Some t -> Some t - + 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 + 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) + (* 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" @@ -148,352 +437,296 @@ let subst_evaluable_reference subst = function -let rec map_kn f f' c = +let rec map_kn f f' c = let func = map_kn f f' in match kind_of_term c with - | Const kn -> + | Const kn -> (match f' kn with None -> c | Some const ->const) - | Ind (kn,i) -> + | Ind (kn,i) -> (match f kn with None -> c | Some kn' -> mkInd (kn',i)) - | Construct ((kn,i),j) -> + | Construct ((kn,i),j) -> (match f kn with None -> c | Some kn' -> mkConstruct ((kn',i),j)) - | Case (ci,p,ct,l) -> + | 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 p' = func p in let ct' = func ct in let l' = array_smartmap func l in - if (ci.ci_ind==ci_ind && p'==p + if (ci.ci_ind==ci_ind && p'==p && l'==l && ct'==ct)then c - else + else mkCase ({ci with ci_ind = ci_ind}, - p',ct', l') - | Cast (ct,k,t) -> + p',ct', l') + | Cast (ct,k,t) -> let ct' = func ct in let t'= func t in - if (t'==t && ct'==ct) then c + if (t'==t && ct'==ct) then c else mkCast (ct', k, t') - | Prod (na,t,ct) -> + | Prod (na,t,ct) -> let ct' = func ct in let t'= func t in - if (t'==t && ct'==ct) then c + if (t'==t && ct'==ct) then c else mkProd (na, t', ct') - | Lambda (na,t,ct) -> + | Lambda (na,t,ct) -> let ct' = func ct in let t'= func t in - if (t'==t && ct'==ct) then c + if (t'==t && ct'==ct) then c else mkLambda (na, t', ct') - | LetIn (na,b,t,ct) -> + | LetIn (na,b,t,ct) -> let ct' = func ct in let t'= func t in let b'= func b in - if (t'==t && ct'==ct && b==b') then c + if (t'==t && ct'==ct && b==b') then c else mkLetIn (na, b', t', ct') - | App (ct,l) -> + | App (ct,l) -> let ct' = func ct in let l' = array_smartmap func l in if (ct'== ct && l'==l) then c else mkApp (ct',l') - | Evar (e,l) -> + | Evar (e,l) -> let l' = array_smartmap func l in if (l'==l) then c else mkEvar (e,l') | Fix (ln,(lna,tl,bl)) -> let tl' = array_smartmap func tl in let bl' = array_smartmap func bl in - if (bl == bl'&& tl == tl') then c + if (bl == bl'&& tl == tl') then c else mkFix (ln,(lna,tl',bl')) | CoFix(ln,(lna,tl,bl)) -> let tl' = array_smartmap func tl in let bl' = array_smartmap func bl in - if (bl == bl'&& tl == tl') then c + if (bl == bl'&& tl == tl') then c else mkCoFix (ln,(lna,tl',bl')) | _ -> c -let subst_mps sub = - map_kn (subst_kn0 sub) (subst_con0 sub) +let subst_mps sub = + map_kn (subst_mind0 sub) (subst_con0 sub) let rec replace_mp_in_mp mpfrom mpto mp = match mp with | _ when mp = mpfrom -> mpto - | MPdot (mp1,l) -> + | MPdot (mp1,l) -> let mp1' = replace_mp_in_mp mpfrom mpto mp1 in if mp1==mp1' then mp else MPdot (mp1',l) | _ -> mp -let replace_mp_in_con mpfrom mpto kn = - let mp,dir,l = repr_con kn in +let replace_mp_in_kn mpfrom mpto kn = + let mp,dir,l = repr_kn kn in let mp'' = replace_mp_in_mp mpfrom mpto mp in if mp==mp'' then kn - else make_con mp'' dir l + else make_kn mp'' dir l -exception BothSubstitutionsAreIdentitySubstitutions -exception ChangeDomain of resolver +let rec mp_in_mp mp mp1 = + match mp1 with + | _ 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 + in + Deltamap.fold prefixmp resolver empty_delta_resolver -let join (subst1 : substitution) (subst2 : substitution) = - let apply_subst (sub : substitution) key (mp,resolve) = - let mp',resolve' = - match subst_mp0 sub mp with - None -> mp, None - | Some (mp',resolve') -> mp',resolve' in - let resolve'' : resolver option = - try - let res = - match resolve with - |None -> begin - match resolve' with - None -> raise BothSubstitutionsAreIdentitySubstitutions - | Some res -> raise (ChangeDomain res) end - | Some res -> res - in - Some - (List.map - (fun (kn,topt) -> - kn, - match topt with - None -> - (match key with - MSI msid -> - let kn' = replace_mp_in_con (MPself msid) mp kn in - apply_opt_resolver resolve' kn' - | MBI mbid -> - let kn' = replace_mp_in_con (MPbound mbid) mp kn in - apply_opt_resolver resolve' kn' - | MPI mp1 -> - let kn' = replace_mp_in_con mp1 mp kn in - apply_opt_resolver resolve' kn') - | Some t -> Some (subst_mps sub t)) res) - with - BothSubstitutionsAreIdentitySubstitutions -> None - | ChangeDomain res -> - let rec changeDom = function - | [] -> [] - | (kn,topt)::r -> - let key' = - match key with - MSI msid -> MPself msid - | MBI mbid -> MPbound mbid - | MPI mp1 -> mp1 in - let kn' = replace_mp_in_con mp key' kn in - if kn==kn' then - (*the key does not appear in kn, we remove it - from the resolver that we are building*) - changeDom r - else - (kn',topt)::(changeDom r) - in - Some (changeDom res) - in - mp',resolve'' in - let subst = Umap.mapi (apply_subst subst2) subst1 in - (Umap.fold Umap.add subst2 subst) - -let subst_key subst1 subst2 = - let replace_in_key key (mp,resolve) sub= - let newkey = - match key with - | MPI mp1 -> - begin - match subst_mp0 subst1 mp1 with - | None -> None - | Some (mp2,_) -> Some (MPI mp2) - end - | _ -> None - in - match newkey with - | None -> Umap.add key (mp,resolve) sub - | Some mpi -> Umap.add mpi (mp,resolve) sub +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 in - Umap.fold replace_in_key subst2 empty_subst - -let update_subst_alias subst1 subst2 = - let subst_inv key (mp,resolve) sub = - let newmp = - match key with - | MBI msid -> MPbound msid - | MSI msid -> MPself msid - | MPI mp -> mp - in - match mp with - | MPbound mbid -> Umap.add (MBI mbid) (newmp,None) sub - | MPself msid -> Umap.add (MSI msid) (newmp,None) sub - | _ -> Umap.add (MPI mp) (newmp,None) sub - in - let subst_mbi = Umap.fold subst_inv subst2 empty_subst in - let alias_subst key (mp,resolve) sub= - let newkey = - match key with - | MPI mp1 -> - begin - match subst_mp0 subst_mbi mp1 with - | None -> None - | Some (mp2,_) -> Some (MPI mp2) - end - | _ -> None - in - match newkey with - | None -> Umap.add key (mp,resolve) sub - | Some mpi -> Umap.add mpi (mp,resolve) sub + Deltamap.fold apply_subst resolver empty_delta_resolver + +let subst_mp_delta sub mp key= + match subst_mp0 sub mp with + None -> empty_delta_resolver,mp + | 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 in - Umap.fold alias_subst subst1 empty_subst - -let update_subst subst1 subst2 = - let subst_inv key (mp,resolve) l = - let newmp = - match key with - | MBI msid -> MPbound msid - | MSI msid -> MPself msid - | MPI mp -> mp - in - match mp with - | MPbound mbid -> ((MBI mbid),newmp,resolve)::l - | MPself msid -> ((MSI msid),newmp,resolve)::l - | _ -> ((MPI mp),newmp,resolve)::l - in - let subst_mbi = Umap.fold subst_inv subst2 [] in - let alias_subst key (mp,resolve) sub= - let newsetkey = - match key with - | MPI mp1 -> - let compute_set_newkey l (k,mp',resolve) = - let mp_from_key = match k with - | MBI msid -> MPbound msid - | MSI msid -> MPself msid - | MPI mp -> mp - in - let new_mp1 = replace_mp_in_mp mp_from_key mp' mp1 in - if new_mp1 == mp1 then l else (MPI new_mp1,resolve)::l - in - begin - match List.fold_left compute_set_newkey [] subst_mbi with - | [] -> None - | l -> Some (l) - end - | _ -> None + 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" + in + Deltamap.fold apply_subst resolver empty_delta_resolver + +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 - match newsetkey with - | None -> sub - | Some l -> - List.fold_left (fun s (k,r) -> Umap.add k (mp,r) s) - sub l + Deltamap.fold apply_res resolver1 empty_delta_resolver + +let add_delta_resolver resolver1 resolver2 = + if resolver1 == resolver2 then + resolver2 + else if resolver2 = empty_delta_resolver then + resolver1 + else + Deltamap.fold Deltamap.add (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 in - Umap.fold alias_subst subst1 empty_subst + Umap.fold prefixmp subst empty_subst -let join_alias (subst1 : substitution) (subst2 : substitution) = - let apply_subst (sub : substitution) key (mp,resolve) = +let join (subst1 : substitution) (subst2 : substitution) = + let apply_subst key (mp,resolve) res = let mp',resolve' = - match subst_mp0 sub mp with + match subst_mp0 subst2 mp with None -> mp, None - | Some (mp',resolve') -> mp',resolve' in - let resolve'' : resolver option = - try - let res = - match resolve with - Some res -> res - | None -> - match resolve' with - None -> raise BothSubstitutionsAreIdentitySubstitutions - | Some res -> raise (ChangeDomain res) - in - Some - (List.map - (fun (kn,topt) -> - kn, - match topt with - None -> - (match key with - MSI msid -> - let kn' = replace_mp_in_con (MPself msid) mp kn in - apply_opt_resolver resolve' kn' - | MBI mbid -> - let kn' = replace_mp_in_con (MPbound mbid) mp kn in - apply_opt_resolver resolve' kn' - | MPI mp1 -> - let kn' = replace_mp_in_con mp1 mp kn in - apply_opt_resolver resolve' kn') - | Some t -> Some (subst_mps sub t)) res) - with - BothSubstitutionsAreIdentitySubstitutions -> None - | ChangeDomain res -> - let rec changeDom = function - | [] -> [] - | (kn,topt)::r -> - let key' = - match key with - MSI msid -> MPself msid - | MBI mbid -> MPbound mbid - | MPI mp1 -> mp1 in - let kn' = replace_mp_in_con mp key' kn in - if kn==kn' then - (*the key does not appear in kn, we remove it - from the resolver that we are building*) - changeDom r - else - (kn',topt)::(changeDom r) - in - Some (changeDom res) + | Some (mp',resolve') -> mp' + ,Some resolve' in + let resolve'' : delta_resolver = + match resolve' with + Some res -> + add_delta_resolver + (subst_dom_codom_delta_resolver subst2 resolve) res + | None -> + subst_codom_delta_resolver subst2 resolve in - mp',resolve'' in - Umap.mapi (apply_subst subst2) subst1 + 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 remove_alias subst = - let rec remove key (mp,resolve) sub = - match key with - MPI _ -> sub - | _ -> Umap.add key (mp,resolve) sub - in - Umap.fold remove subst empty_subst - let rec occur_in_path uid path = match uid,path with - | MSI sid,MPself sid' -> sid = sid' | MBI bid,MPbound bid' -> bid = bid' | _,MPdot (mp1,_) -> occur_in_path uid mp1 | _ -> false - -let occur_uid uid sub = + +let occur_uid uid sub = let check_one uid' (mp,_) = if uid = uid' || occur_in_path uid mp then raise Exit in - try + try Umap.iter check_one sub; false with Exit -> true -let occur_msid uid = occur_uid (MSI uid) + let occur_mbid uid = occur_uid (MBI uid) - + type 'a lazy_subst = | LSval of 'a - | LSlazy of substitution * 'a - + | LSlazy of substitution list * 'a + type 'a substituted = 'a lazy_subst ref - + let from_val a = ref (LSval a) - -let force fsubst r = + +let force fsubst r = match !r with | LSval a -> a - | LSlazy(s,a) -> - let a' = fsubst s a in + | LSlazy(s,a) -> + let subst = List.fold_left join empty_subst (List.rev s) in + let a' = fsubst subst a in r := LSval a'; - a' + a' let subst_substituted s r = match !r with - | LSval a -> ref (LSlazy(s,a)) + | LSval a -> ref (LSlazy([s],a)) | LSlazy(s',a) -> - let s'' = join s' s in - ref (LSlazy(s'',a)) - + ref (LSlazy(s::s',a)) + diff --git a/kernel/mod_subst.mli b/kernel/mod_subst.mli index a2e45c52..a948d164 100644 --- a/kernel/mod_subst.mli +++ b/kernel/mod_subst.mli @@ -6,35 +6,83 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: mod_subst.mli 10849 2008-04-25 15:55:16Z soubiran $ i*) +(*i $Id$ i*) (*s [Mod_subst] *) open Names open Term -type resolver +(* A delta_resolver maps name (constant, inductive, module_path) + to canonical name *) +type delta_resolver + type substitution -val make_resolver : (constant * constr option) list -> resolver +val empty_delta_resolver : delta_resolver + +val add_inline_delta_resolver : constant -> delta_resolver -> delta_resolver + +val add_inline_constr_delta_resolver : constant -> constr -> 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_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 + +(* 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 constant_of_delta : delta_resolver -> constant -> constant + +val mind_of_delta : delta_resolver -> mutual_inductive -> mutual_inductive + +val delta_of_mp : delta_resolver -> module_path -> module_path + +(* Extract the set of inlined constant in the resolver *) +val inline_of_delta : delta_resolver -> 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 + + +(* 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*) val empty_subst : substitution -val add_msid : - mod_self_id -> module_path -> substitution -> substitution -val add_mbid : - mod_bound_id -> module_path -> resolver option -> substitution -> substitution +(* 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 -> substitution -> substitution + module_path -> module_path -> delta_resolver -> substitution -> substitution -val map_msid : - mod_self_id -> module_path -> substitution +(* map_* create a new substitution [arg2/arg1]{arg3} *) val map_mbid : - mod_bound_id -> module_path -> resolver option -> substitution + mod_bound_id -> module_path -> delta_resolver -> substitution val map_mp : - module_path -> module_path -> substitution + 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 @@ -47,16 +95,21 @@ val subst_substituted : substitution -> 'a substituted -> 'a substituted (*i 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 - substitution is structutally equal [mp], it is equal by pointers - as well [==] *) + substitution is structutally equal [mp], it is equal by pointers + as well [==] *) -val subst_mp : +val subst_mp : substitution -> module_path -> module_path -val subst_kn : +val subst_ind : + substitution -> mutual_inductive -> mutual_inductive + +val subst_kn : substitution -> kernel_name -> kernel_name val subst_con : @@ -71,24 +124,14 @@ val subst_evaluable_reference : substitution -> evaluable_global_reference -> evaluable_global_reference (* [replace_mp_in_con mp mp' con] replaces [mp] with [mp'] in [con] *) -val replace_mp_in_con : module_path -> module_path -> constant -> constant +val replace_mp_in_kn : module_path -> module_path -> kernel_name -> kernel_name (* [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_msid : mod_self_id -> substitution -> bool val occur_mbid : mod_bound_id -> substitution -> bool -val update_subst_alias : substitution -> substitution -> substitution - -val update_subst : substitution -> substitution -> substitution - -val subst_key : substitution -> substitution -> substitution - -val join_alias : substitution -> substitution -> substitution - -val remove_alias : substitution -> substitution diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml index 4a9fb606..f0ca555c 100644 --- a/kernel/mod_typing.ml +++ b/kernel/mod_typing.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: mod_typing.ml 11514 2008-10-28 13:39:02Z soubiran $ i*) +(*i $Id$ i*) open Util open Names @@ -30,61 +30,45 @@ let rec list_split_assoc k rev_before = function | (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 +let rec list_fold_map2 f e = function | [] -> (e,[],[]) - | h::t -> + | 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 _ -> + mtb.typ_delta + | _ -> (*case mp is a functor *) + empty_delta_resolver + let rec rebuild_mp mp l = match l with []-> mp | i::r -> rebuild_mp (MPdot(mp,i)) r - -let type_of_struct env b meb = - let rec aux env = function - | SEBfunctor (mp,mtb,body) -> - let env = add_module (MPbound mp) (module_body_of_type mtb) env in - SEBfunctor(mp,mtb, aux env body) - | SEBident mp -> - strengthen env (lookup_modtype mp env).typ_expr mp - | SEBapply _ as mtb -> eval_struct env mtb - | str -> str - in - if b then - Some (aux env meb) + +let rec check_with env sign with_decl alg_sign mp equiv = + let sign,wd,equiv,cst= match with_decl with + | With_Definition (id,_) -> + let sign,cb,cst = check_with_aux_def env sign with_decl mp equiv in + sign,With_definition_body(id,cb),equiv,cst + | With_Module (id,mp1) -> + let sign,equiv,cst = + check_with_aux_mod env sign with_decl mp equiv in + sign,With_module_body(id,mp1),equiv,cst in + if alg_sign = None then + sign,None,equiv,cst else - None - -let rec bounded_str_expr = function - | SEBfunctor (mp,mtb,body) -> bounded_str_expr body - | SEBident mp -> (check_bound_mp mp) - | SEBapply (f,a,_)->(bounded_str_expr f) - | _ -> false - -let return_opt_type mp env mtb = - if (check_bound_mp mp) then - Some (strengthen env mtb.typ_expr mp) - else - None - -let rec check_with env mtb with_decl = - match with_decl with - | With_Definition (id,_) -> - let cb = check_with_aux_def env mtb with_decl in - SEBwith(mtb,With_definition_body(id,cb)),empty_subst - | With_Module (id,mp) -> - let cst,sub,typ_opt = check_with_aux_mod env mtb with_decl true in - SEBwith(mtb,With_module_body(id,mp,typ_opt,cst)),sub - -and check_with_aux_def env mtb with_decl = - let msid,sig_b = match (eval_struct env mtb) with - | SEBstruct(msid,sig_b) -> - msid,sig_b - | _ -> error_signature_expected mtb + sign,Some (SEBwith(Option.get(alg_sign),wd)),equiv,cst + +and check_with_aux_def env sign with_decl mp equiv = + let sig_b = match sign with + | SEBstruct(sig_b) -> sig_b + | _ -> error_signature_expected sign in - let id,idl = match with_decl with + let id,idl = match with_decl with | With_Definition (id::idl,_) | With_Module (id::idl,_) -> id,idl | With_Definition ([],_) | With_Module ([],_) -> assert false in @@ -92,43 +76,43 @@ and check_with_aux_def env mtb with_decl = try let rev_before,spec,after = list_split_assoc l [] sig_b in let before = List.rev rev_before in - let env' = Modops.add_signature (MPself msid) before env in + let env' = Modops.add_signature mp before equiv env in match with_decl with | With_Definition ([],_) -> assert false - | With_Definition ([id],c) -> + | With_Definition ([id],c) -> let cb = match spec with SFBconst cb -> cb | _ -> error_not_a_constant l - in + in begin match cb.const_body with - | None -> + | 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 + 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 + let cb' = {cb with const_body = body; const_body_code = Cemitcodes.from_val (compile_constant_body env' body false false); const_constraints = cst} in - cb' - | Some b -> + 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 + let cb' = {cb with const_body = body; const_body_code = Cemitcodes.from_val (compile_constant_body env' body false false); const_constraints = cst} in - cb' + SEBstruct(before@((l,SFBconst(cb'))::after)),cb',cst end - | With_Definition (_::_,_) -> + | With_Definition (_::_,c) -> let old = match spec with SFBmodule msb -> msb | _ -> error_not_a_module (string_of_label l) @@ -136,10 +120,14 @@ and check_with_aux_def env mtb with_decl = begin match old.mod_expr with | None -> - let new_with_decl = match with_decl with - With_Definition (_,c) -> With_Definition (idl,c) - | With_Module (_,c) -> With_Module (idl,c) in - check_with_aux_def env' (type_of_mb env old) new_with_decl + let new_with_decl = With_Definition (idl,c) in + let sign,cb,cst = + check_with_aux_def env' old.mod_type new_with_decl + (MPdot(mp,l)) old.mod_delta in + let new_spec = SFBmodule({old with + mod_type = sign; + mod_type_alg = None}) in + SEBstruct(before@((l,new_spec)::after)),cb,cst | Some msb -> error_a_generative_module_expected l end @@ -148,13 +136,12 @@ and check_with_aux_def env mtb with_decl = Not_found -> error_no_such_label l | Reduction.NotConvertible -> error_with_incorrect l -and check_with_aux_mod env mtb with_decl now = - let initmsid,msid,sig_b = match (eval_struct env mtb) with - | SEBstruct(msid,sig_b) ->let msid'=(refresh_msid msid) in - msid,msid',(subst_signature_msid msid (MPself(msid')) sig_b) - | _ -> error_signature_expected mtb +and check_with_aux_mod env sign with_decl mp equiv = + let sig_b = match sign with + | SEBstruct(sig_b) ->sig_b + | _ -> error_signature_expected sign in - let id,idl = match with_decl with + let id,idl = match with_decl with | With_Definition (id::idl,_) | With_Module (id::idl,_) -> id,idl | With_Definition ([],_) | With_Module ([],_) -> assert false in @@ -163,265 +150,329 @@ and check_with_aux_mod env mtb with_decl now = let rev_before,spec,after = list_split_assoc l [] sig_b in let before = List.rev rev_before in let rec mp_rec = function - | [] -> MPself initmsid + | [] -> mp | i::r -> MPdot(mp_rec r,label_of_id i) - in - let env' = Modops.add_signature (MPself msid) before env in + in + let env' = Modops.add_signature mp before equiv env in match with_decl with | With_Module ([],_) -> assert false - | With_Module ([id], mp) -> - let old,alias = match spec with - SFBmodule msb -> Some msb,None - | SFBalias (mp',_,cst) -> None,Some (mp',cst) + | With_Module ([id], mp1) -> + let old = match spec with + SFBmodule msb -> msb | _ -> error_not_a_module (string_of_label l) in - let mtb' = lookup_modtype mp env' in + let mb_mp1 = (lookup_module mp1 env) in + let mtb_mp1 = + module_type_of_module env' None mb_mp1 in let cst = - match old,alias with - Some msb,None -> + match old.mod_expr with + None -> begin - try Constraint.union - (check_subtypes env' mtb' (module_type_of_module None msb)) - msb.mod_constraints + try Constraint.union + (check_subtypes env' mtb_mp1 + (module_type_of_module env' None old)) + old.mod_constraints with Failure _ -> error_with_incorrect (label_of_id id) end - | None,Some (mp',None) -> - check_modpath_equiv env' mp mp'; - Constraint.empty - | None,Some (mp',Some cst) -> - check_modpath_equiv env' mp mp'; - cst - | _,_ -> - anomaly "Mod_typing:no implementation and no alias" + | Some (SEBident(mp')) -> + check_modpath_equiv env' mp1 mp'; + old.mod_constraints + | _ -> error_a_generative_module_expected l + 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); + mod_constraints = cst} in + (* we propagate the new equality in the rest of the signature + with the identity substitution accompagned by the new resolver*) + let id_subst = map_mp (MPdot(mp,l)) (MPdot(mp,l)) new_mb.mod_delta in + SEBstruct(before@(l,new_spec)::subst_signature id_subst after), + add_delta_resolver equiv new_mb.mod_delta,cst + | With_Module (idc,mp1) -> + let old = match spec with + SFBmodule msb -> msb + | _ -> error_not_a_module (string_of_label l) in - if now then - let mp' = scrape_alias mp env' in - let _,sub = Modops.update_subst env' (module_body_of_type mtb') mp' in - let up_subst = update_subst sub (map_mp (mp_rec [id]) mp') in - cst, (join (map_mp (mp_rec [id]) mp') up_subst),(return_opt_type mp env' mtb') - else - cst,empty_subst,(return_opt_type mp env' mtb') - | With_Module (_::_,mp) -> - let old,alias = match spec with - SFBmodule msb -> Some msb, None - | SFBalias (mpold,typ_opt,cst)->None, Some mpold - | _ -> error_not_a_module (string_of_label l) - in begin - if alias = None then - let old = Option.get old in - match old.mod_expr with - None -> - let new_with_decl = match with_decl with - With_Definition (_,c) -> - With_Definition (idl,c) - | With_Module (_,c) -> With_Module (idl,c) in - let cst,_,typ_opt = - check_with_aux_mod env' - (type_of_mb env' old) new_with_decl false in - if now then - let mtb' = lookup_modtype mp env' in - let mp' = scrape_alias mp env' in - let _,sub = Modops.update_subst env' (module_body_of_type mtb') mp' in - let up_subst = update_subst - sub (map_mp (mp_rec (List.rev (id::idl))) mp') in - cst, - (join (map_mp (mp_rec (List.rev (id::idl))) mp') up_subst), - typ_opt - else - cst,empty_subst,typ_opt - | Some msb -> - error_a_generative_module_expected l - else - let mpold = Option.get alias in - let mpnew = rebuild_mp mpold (List.map label_of_id idl) in - check_modpath_equiv env' mpnew mp; - let mtb' = lookup_modtype mp env' in - Constraint.empty,empty_subst,(return_opt_type mp env' mtb') + match old.mod_expr with + None -> + let new_with_decl = With_Module (idl,mp1) in + let sign,equiv',cst = + check_with_aux_mod env' + old.mod_type new_with_decl (MPdot(mp,l)) old.mod_delta in + let new_equiv = add_delta_resolver equiv equiv' in + let new_spec = SFBmodule {old with + mod_type = sign; + mod_type_alg = None; + mod_delta = equiv'} + in + let id_subst = map_mp (MPdot(mp,l)) (MPdot(mp,l)) equiv' in + SEBstruct(before@(l,new_spec)::subst_signature id_subst after), + new_equiv,cst + | Some (SEBident(mp')) -> + 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 + | _ -> + error_a_generative_module_expected l end - | _ -> anomaly "Modtyping:incorrect use of with" + | _ -> anomaly "Modtyping:incorrect use of with" with Not_found -> error_no_such_label l | Reduction.NotConvertible -> error_with_incorrect l - -and translate_module env me = + +and translate_module env mp inl me = match me.mod_entry_expr, me.mod_entry_type with - | None, None -> + | None, None -> anomaly "Mod_typing.translate_module: empty type and expr in module entry" - | None, Some mte -> - let mtb,sub = translate_struct_entry env mte in - { mod_expr = None; - mod_type = Some mtb; - mod_alias = sub; - mod_constraints = Constraint.empty; - mod_retroknowledge = []} - | Some mexpr, _ -> - let meb,sub1 = translate_struct_entry env mexpr in - let mod_typ,sub,cst = + | None, Some mte -> + let mtb = translate_module_type env mp inl mte in + { mod_mp = mp; + mod_expr = None; + mod_type = mtb.typ_expr; + mod_type_alg = mtb.typ_expr_alg; + mod_delta = mtb.typ_delta; + mod_constraints = mtb.typ_constraints; + mod_retroknowledge = []} + | Some mexpr, _ -> + let sign,alg_implem,resolver,cst1 = + translate_struct_module_entry env mp inl mexpr in + let sign,alg1,resolver,cst2 = match me.mod_entry_type with - | None -> - (type_of_struct env (bounded_str_expr meb) meb) - ,sub1,Constraint.empty - | Some mte -> - let mtb2,sub2 = translate_struct_entry env mte in + | None -> + sign,None,resolver,Constraint.empty + | Some mte -> + let mtb = translate_module_type env mp inl mte in let cst = check_subtypes env - {typ_expr = meb; - typ_strength = None; - typ_alias = sub1;} - {typ_expr = mtb2; - typ_strength = None; - typ_alias = sub2;} + {typ_mp = mp; + typ_expr = sign; + typ_expr_alg = None; + typ_constraints = Constraint.empty; + typ_delta = resolver;} + mtb in - Some mtb2,sub2,cst + mtb.typ_expr,mtb.typ_expr_alg,mtb.typ_delta,cst in - { mod_type = mod_typ; - mod_expr = Some meb; - mod_constraints = cst; - mod_alias = sub; - mod_retroknowledge = []} (* spiwack: not so sure about that. It may - cause a bug when closing nested modules. - If it does, I don't really know how to - fix the bug.*) + { mod_mp = mp; + mod_type = sign; + mod_expr = Some alg_implem; + mod_type_alg = alg1; + mod_constraints = Univ.Constraint.union cst1 cst2; + mod_delta = resolver; + mod_retroknowledge = []} + (* spiwack: not so sure about that. It may + cause a bug when closing nested modules. + If it does, I don't really know how to + fix the bug.*) -and translate_struct_entry env mse = match mse with - | MSEident mp -> - let mtb = lookup_modtype mp env in - SEBident mp,mtb.typ_alias +and translate_struct_module_entry env mp inl mse = match mse with + | 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 | MSEfunctor (arg_id, arg_e, body_expr) -> - let arg_b,sub = translate_struct_entry env arg_e in - let mtb = - {typ_expr = arg_b; - typ_strength = None; - typ_alias = sub} in - let env' = add_module (MPbound arg_id) (module_body_of_type mtb) env in - let body_b,sub = translate_struct_entry env' body_expr in - SEBfunctor (arg_id, mtb, body_b),sub + 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 | MSEapply (fexpr,mexpr) -> - let feb,sub1 = translate_struct_entry env fexpr in - let feb'= eval_struct env feb + let sign,alg,resolver,cst1 = + translate_struct_module_entry env mp inl fexpr in - let farg_id, farg_b, fbody_b = destr_functor env feb' in - let mtb,mp = + let farg_id, farg_b, fbody_b = destr_functor env sign in + let mtb,mp1 = try - let mp = scrape_alias (path_of_mexpr mexpr) env in - lookup_modtype mp env,mp + 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 meb,sub2= translate_struct_entry env (MSEident mp) in - if sub1 = empty_subst then - let cst = check_subtypes env mtb farg_b in - SEBapply(feb,meb,cst),sub1 - else - let sub2 = match eval_struct env (SEBident mp) with - | SEBstruct (msid,sign) -> - join_alias - (subst_key (map_msid msid mp) sub2) - (map_msid msid mp) - | _ -> sub2 in - let sub3 = join_alias sub1 (map_mbid farg_id mp None) in - let sub4 = update_subst sub2 sub3 in - let cst = check_subtypes env mtb farg_b in - SEBapply(feb,meb,cst),(join sub3 sub4) + 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 | MSEwith(mte, with_decl) -> - let mtb,sub1 = translate_struct_entry env mte in - let mtb',sub2 = check_with env mtb with_decl in - mtb',join sub1 sub2 - + 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 + | MSEident mp1 -> + let mtb = lookup_modtype mp1 env in + mtb.typ_expr, + Some (SEBident mp1),mtb.typ_delta,mp1,Univ.Constraint.empty + | 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 + | 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 + | 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 + +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 rec translate_struct_include_module_entry env mp inl mse = match mse with + | 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 + | 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 + | _ -> error ("You cannot Include a high-order structure.") + let rec add_struct_expr_constraints env = function | SEBident _ -> env - | SEBfunctor (_,mtb,meb) -> - add_struct_expr_constraints + | SEBfunctor (_,mtb,meb) -> + add_struct_expr_constraints (add_modtype_constraints env mtb) meb - | SEBstruct (_,structure_body) -> - List.fold_left + | SEBstruct (structure_body) -> + List.fold_left (fun env (l,item) -> add_struct_elem_constraints env item) env structure_body | SEBapply (meb1,meb2,cst) -> - Environ.add_constraints cst - (add_struct_expr_constraints - (add_struct_expr_constraints env meb1) + Environ.add_constraints cst + (add_struct_expr_constraints + (add_struct_expr_constraints env meb1) meb2) | SEBwith(meb,With_definition_body(_,cb))-> Environ.add_constraints cb.const_constraints (add_struct_expr_constraints env meb) - | SEBwith(meb,With_module_body(_,_,_,cst))-> - Environ.add_constraints cst - (add_struct_expr_constraints env meb) + | SEBwith(meb,With_module_body(_,_))-> + add_struct_expr_constraints env meb and add_struct_elem_constraints env = function | SFBconst cb -> Environ.add_constraints cb.const_constraints env | SFBmind mib -> Environ.add_constraints mib.mind_constraints env | SFBmodule mb -> add_module_constraints env mb - | SFBalias (mp,_,Some cst) -> Environ.add_constraints cst env - | SFBalias (mp,_,None) -> env | SFBmodtype mtb -> add_modtype_constraints env mtb -and add_module_constraints env mb = +and add_module_constraints env mb = let env = match mb.mod_expr with | None -> env | Some meb -> add_struct_expr_constraints env meb in - let env = match mb.mod_type with - | None -> env - | Some mtb -> - add_struct_expr_constraints env mtb + let env = + add_struct_expr_constraints env mb.mod_type in Environ.add_constraints mb.mod_constraints env -and add_modtype_constraints env mtb = - add_struct_expr_constraints env mtb.typ_expr - +and add_modtype_constraints env mtb = + Environ.add_constraints mtb.typ_constraints + (add_struct_expr_constraints env mtb.typ_expr) + let rec struct_expr_constraints cst = function | SEBident _ -> cst - | SEBfunctor (_,mtb,meb) -> - struct_expr_constraints + | SEBfunctor (_,mtb,meb) -> + struct_expr_constraints (modtype_constraints cst mtb) meb - | SEBstruct (_,structure_body) -> - List.fold_left + | SEBstruct (structure_body) -> + List.fold_left (fun cst (l,item) -> struct_elem_constraints cst item) cst structure_body | SEBapply (meb1,meb2,cst1) -> - struct_expr_constraints + struct_expr_constraints (struct_expr_constraints (Univ.Constraint.union cst1 cst) meb1) meb2 | SEBwith(meb,With_definition_body(_,cb))-> struct_expr_constraints (Univ.Constraint.union cb.const_constraints cst) meb - | SEBwith(meb,With_module_body(_,_,_,cst1))-> - struct_expr_constraints (Univ.Constraint.union cst1 cst) meb + | SEBwith(meb,With_module_body(_,_))-> + struct_expr_constraints cst meb and struct_elem_constraints cst = function | SFBconst cb -> cst | SFBmind mib -> cst | SFBmodule mb -> module_constraints cst mb - | SFBalias (mp,_,Some cst1) -> Univ.Constraint.union cst1 cst - | SFBalias (mp,_,None) -> cst | SFBmodtype mtb -> modtype_constraints cst mtb -and module_constraints cst mb = +and module_constraints cst mb = let cst = match mb.mod_expr with | None -> cst | Some meb -> struct_expr_constraints cst meb in - let cst = match mb.mod_type with - | None -> cst - | Some mtb -> struct_expr_constraints cst mtb in + let cst = + struct_expr_constraints cst mb.mod_type in Univ.Constraint.union mb.mod_constraints cst -and modtype_constraints cst mtb = - struct_expr_constraints cst mtb.typ_expr - +and modtype_constraints cst mtb = + struct_expr_constraints (Univ.Constraint.union 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 diff --git a/kernel/mod_typing.mli b/kernel/mod_typing.mli index b9c68a23..63f7696c 100644 --- a/kernel/mod_typing.mli +++ b/kernel/mod_typing.mli @@ -6,20 +6,31 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: mod_typing.mli 11170 2008-06-25 08:31:04Z soubiran $ i*) +(*i $Id$ i*) (*i*) open Declarations open Environ open Entries open Mod_subst +open Names (*i*) -val translate_module : env -> module_entry -> module_body +val translate_module : env -> module_path -> bool -> module_entry + -> module_body -val translate_struct_entry : env -> module_struct_entry -> - struct_expr_body * substitution +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 add_modtype_constraints : env -> module_type_body -> env diff --git a/kernel/modops.ml b/kernel/modops.ml index 34d9e930..b49d34b3 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: modops.ml 12234 2009-07-09 09:14:09Z soubiran $ i*) +(*i $Id$ i*) (*i*) open Util @@ -21,6 +21,7 @@ open Mod_subst (*i*) + let error_existing_label l = error ("The label "^string_of_label l^" is already declared.") @@ -60,6 +61,9 @@ let error_not_a_modtype_loc loc s = let error_not_a_module_loc loc s = user_err_loc (loc,"",str ("\""^s^"\" is not a module.")) +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_module s = error_not_a_module_loc dummy_loc s let error_not_a_constant l = @@ -82,20 +86,12 @@ let error_local_context lo = (string_of_label l)^" is not empty.") -let error_no_such_label_sub l l1 l2 = - error (l1^" is not a subtype of "^l2^".\nThe field "^(string_of_label l)^" is missing in "^l1^".") - +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." -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 path_of_seb = function - | SEBident mp -> mp - | _ -> anomaly "Modops: evaluation failed." - +let error_application_to_module_type _ = error "Module application to a module type." let destr_functor env mtb = match mtb with @@ -103,123 +99,126 @@ let destr_functor env mtb = (arg_id,arg_t,body_t) | _ -> error_not_a_functor mtb -(* the constraints are not important here *) +let is_functor = function + | SEBfunctor (arg_id,arg_t,body_t) -> true + | _ -> false -let module_body_of_type mtb = - { mod_type = Some mtb.typ_expr; +let module_body_of_type mp mtb = + { mod_mp = mp; + mod_type = mtb.typ_expr; + mod_type_alg = mtb.typ_expr_alg; mod_expr = None; - mod_constraints = Constraint.empty; - mod_alias = mtb.typ_alias; + mod_constraints = mtb.typ_constraints; + mod_delta = mtb.typ_delta; mod_retroknowledge = []} -let module_type_of_module mp mb = - let mp1,expr = - (match mb.mod_type with - | Some expr -> mp,expr - | None -> (match mb.mod_expr with - | Some (SEBident mp') ->(Some mp'),(SEBident mp') - | Some expr -> mp,expr - | None -> - anomaly "Modops: empty expr and type")) in - {typ_expr = expr; - typ_alias = mb.mod_alias; - typ_strength = mp1 - } - -let rec check_modpath_equiv env mp1 mp2 = +let check_modpath_equiv env mp1 mp2 = if mp1=mp2 then () else - let mp1 = scrape_alias mp1 env in - let mp2 = scrape_alias mp2 env in - if mp1=mp2 then () - else - error_not_equal mp1 mp2 + 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) + then () + else error_not_equal mp1 mp2 let rec subst_with_body sub = function - | With_module_body(id,mp,typ_opt,cst) -> - With_module_body(id,subst_mp sub mp,Option.smartmap - (subst_struct_expr sub) typ_opt,cst) + | With_module_body(id,mp) -> + With_module_body(id,subst_mp sub mp) | With_definition_body(id,cb) -> With_definition_body( id,subst_const_body sub cb) -and subst_modtype sub mtb = - let typ_expr' = subst_struct_expr sub mtb.typ_expr in - let sub_mtb = join_alias mtb.typ_alias sub in - if typ_expr'==mtb.typ_expr && sub_mtb==mtb.typ_alias then - mtb +and subst_modtype sub do_delta mtb= + let mp = subst_mp sub mtb.typ_mp in + let sub = add_mp mtb.typ_mp mp empty_delta_resolver sub in + let typ_expr' = subst_struct_expr sub do_delta mtb.typ_expr in + let typ_alg' = + Option.smartmap + (subst_struct_expr sub (fun x y-> x)) mtb.typ_expr_alg in + let mtb_delta = do_delta mtb.typ_delta sub in + if typ_expr'==mtb.typ_expr && + typ_alg'==mtb.typ_expr_alg && mp==mtb.typ_mp then + mtb else - { mtb with - typ_expr = typ_expr'; - typ_alias = sub_mtb} + {mtb with + typ_mp = mp; + typ_expr = typ_expr'; + typ_expr_alg = typ_alg'; + typ_delta = mtb_delta} -and subst_structure sub sign = - let subst_body = function +and subst_structure sub do_delta sign = + let subst_body = function SFBconst cb -> SFBconst (subst_const_body sub cb) | SFBmind mib -> SFBmind (subst_mind sub mib) | SFBmodule mb -> - SFBmodule (subst_module sub mb) + SFBmodule (subst_module sub do_delta mb) | SFBmodtype mtb -> - SFBmodtype (subst_modtype sub mtb) - | SFBalias (mp,typ_opt,cst) -> - SFBalias (subst_mp sub mp,Option.smartmap - (subst_struct_expr sub) typ_opt,cst) + SFBmodtype (subst_modtype sub do_delta mtb) in List.map (fun (l,b) -> (l,subst_body b)) sign -and subst_module sub mb = - let mtb' = Option.smartmap (subst_struct_expr sub) mb.mod_type in - (* This is similar to the previous case. In this case we have - a module M in a signature that is knows to be equivalent to a module M' - (because the signature is "K with Module M := M'") and we are substituting - M' with some M''. *) - let me' = Option.smartmap (subst_struct_expr sub) mb.mod_expr in - let mb_alias = update_subst sub mb.mod_alias in - let mb_alias = if mb_alias = empty_subst then - join_alias mb.mod_alias sub - else - join mb_alias (join_alias mb.mod_alias sub) - in - if mtb'==mb.mod_type && mb.mod_expr == me' - && mb_alias == mb.mod_alias +and subst_module sub do_delta mb = + let mp = subst_mp sub mb.mod_mp in + let sub = if is_functor mb.mod_type && not(mp=mb.mod_mp) then + add_mp mb.mod_mp mp + empty_delta_resolver sub else sub in + let id_delta = (fun x y-> x) in + let mtb',me' = + let mtb = subst_struct_expr sub do_delta mb.mod_type in + match mb.mod_expr with + None -> mtb,None + | Some me -> if me==mb.mod_type then + mtb,Some mtb + else mtb,Option.smartmap + (subst_struct_expr sub id_delta) mb.mod_expr + in + let typ_alg' = Option.smartmap + (subst_struct_expr sub id_delta) mb.mod_type_alg in + let mb_delta = do_delta mb.mod_delta sub in + if mtb'==mb.mod_type && mb.mod_expr == me' + && mb_delta == mb.mod_delta && mp == mb.mod_mp then mb else - { mod_expr = me'; - mod_type=mtb'; - mod_constraints=mb.mod_constraints; - mod_alias = mb_alias; - mod_retroknowledge=mb.mod_retroknowledge} - - -and subst_struct_expr sub = function - | SEBident mp -> SEBident (subst_mp sub mp) - | SEBfunctor (msid, mtb, meb') -> - SEBfunctor(msid,subst_modtype sub mtb,subst_struct_expr sub meb') - | SEBstruct (msid,str)-> - SEBstruct(msid, subst_structure sub str) + { mb with + mod_mp = mp; + mod_expr = me'; + mod_type_alg = typ_alg'; + mod_type=mtb'; + mod_delta = mb_delta} + +and subst_struct_expr sub do_delta = function + | SEBident mp -> SEBident (subst_mp sub mp) + | SEBfunctor (mbid, mtb, meb') -> + SEBfunctor(mbid,subst_modtype sub do_delta mtb + ,subst_struct_expr sub do_delta meb') + | SEBstruct (str)-> + SEBstruct( subst_structure sub do_delta str) | SEBapply (meb1,meb2,cst)-> - SEBapply(subst_struct_expr sub meb1, - subst_struct_expr sub meb2, + SEBapply(subst_struct_expr sub do_delta meb1, + subst_struct_expr sub do_delta meb2, cst) | SEBwith (meb,wdb)-> - SEBwith(subst_struct_expr sub meb, + SEBwith(subst_struct_expr sub do_delta meb, subst_with_body sub wdb) - -let subst_signature_msid msid mp = - subst_structure (map_msid msid mp) +let subst_signature subst = + subst_structure subst + (fun resolver subst-> subst_codom_delta_resolver subst resolver) + +let subst_struct_expr subst = + subst_struct_expr subst + (fun resolver subst-> subst_codom_delta_resolver subst resolver) (* spiwack: here comes the function which takes care of importing the retroknowledge declared in the library *) (* lclrk : retroknowledge_action list, rkaction : retroknowledge action *) -let add_retroknowledge msid mp = - let subst = add_msid msid mp empty_subst in - let subst_and_perform rkaction env = +let add_retroknowledge mp = + let perform rkaction env = match rkaction with | Retroknowledge.RKRegister (f, e) -> Environ.register env f (match e with - | Const kn -> kind_of_term (subst_mps subst (mkConst kn)) - | Ind ind -> kind_of_term (subst_mps subst (mkInd ind)) + | Const kn -> kind_of_term (mkConst kn) + | Ind ind -> kind_of_term (mkInd ind) | _ -> anomaly "Modops.add_retroknowledge: had to import an unsupported kind of term") in fun lclrk env -> @@ -231,302 +230,341 @@ let add_retroknowledge msid mp = for things to go right (the pun is not intented). So we lose tail recursivity, but the world will have exploded before any module imports 10 000 retroknowledge registration.*) - List.fold_right subst_and_perform lclrk env - - + List.fold_right perform lclrk env -let strengthen_const env mp l cb = - match cb.const_opaque, cb.const_body with - | false, Some _ -> cb - | true, Some _ - | _, None -> - let const = mkConst (make_con mp empty_dirpath l) 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 strengthen_mind env mp l mib = match mib.mind_equiv with - | Some _ -> mib - | None -> {mib with mind_equiv = Some (make_kn mp empty_dirpath l)} - - -let rec eval_struct env = function - | SEBident mp -> - begin - let mtb =lookup_modtype mp env in - match mtb.typ_expr,mtb.typ_strength with - mtb,None -> eval_struct env mtb - | mtb,Some mp -> strengthen_mtb env mp (eval_struct env mtb) - end - | SEBapply (seb1,seb2,_) -> - let svb1 = eval_struct env seb1 in - let farg_id, farg_b, fbody_b = destr_functor env svb1 in - let mp = path_of_seb seb2 in - let mp = scrape_alias mp env in - let sub_alias = (lookup_modtype mp env).typ_alias in - let sub_alias = match eval_struct env (SEBident mp) with - | SEBstruct (msid,sign) -> - join_alias - (subst_key (map_msid msid mp) sub_alias) - (map_msid msid mp) - | _ -> sub_alias in - let resolve = resolver_of_environment farg_id farg_b mp sub_alias env in - let sub_alias1 = update_subst sub_alias - (map_mbid farg_id mp (Some resolve)) in - eval_struct env (subst_struct_expr - (join sub_alias1 - (map_mbid farg_id mp (Some resolve))) fbody_b) - | SEBwith (mtb,(With_definition_body _ as wdb)) -> - let mtb',_ = merge_with env mtb wdb empty_subst in - mtb' - | SEBwith (mtb, (With_module_body (_,mp,_,_) as wdb)) -> - let alias_in_mp = - (lookup_modtype mp env).typ_alias in - let alias_in_mp = match eval_struct env (SEBident mp) with - | SEBstruct (msid,sign) -> subst_key (map_msid msid mp) alias_in_mp - | _ -> alias_in_mp in - let mtb',_ = merge_with env mtb wdb alias_in_mp in - mtb' -(* | SEBfunctor(mbid,mtb,body) -> - let env = add_module (MPbound mbid) (module_body_of_type mtb) env in - SEBfunctor(mbid,mtb,eval_struct env body) *) - | mtb -> mtb - -and type_of_mb env mb = - match mb.mod_type,mb.mod_expr with - None,Some b -> eval_struct env b - | Some t, _ -> eval_struct env t - | _,_ -> anomaly - "Modops: empty type and empty expr" - -and merge_with env mtb with_decl alias= - let msid,sig_b = match (eval_struct env mtb) with - | SEBstruct(msid,sig_b) -> msid,sig_b - | _ -> error_signature_expected mtb - in - let id,idl = match with_decl with - | With_definition_body (id::idl,_) | With_module_body (id::idl,_,_,_) -> id,idl - | With_definition_body ([],_) | With_module_body ([],_,_,_) -> assert false - in - let l = label_of_id id in - try - let rev_before,spec,after = list_split_assoc l [] sig_b in - let before = List.rev rev_before in - let rec mp_rec = function - | [] -> MPself msid - | i::r -> MPdot(mp_rec r,label_of_id i) - in - let env' = add_signature (MPself msid) before env in - let new_spec,subst = match with_decl with - | With_definition_body ([],_) - | With_module_body ([],_,_,_) -> assert false - | With_definition_body ([id],c) -> - SFBconst c,None - | With_module_body ([id], mp,typ_opt,cst) -> - let mp' = scrape_alias mp env' in - let new_alias = update_subst alias (map_mp (mp_rec [id]) mp') in - SFBalias (mp,typ_opt,Some cst), - Some(join (map_mp (mp_rec [id]) mp') new_alias) - | With_definition_body (_::_,_) - | With_module_body (_::_,_,_,_) -> - let old,aliasold = match spec with - SFBmodule msb -> Some msb, None - | SFBalias (mpold,typ_opt,cst) ->None, Some (mpold,typ_opt,cst) - | _ -> error_not_a_module (string_of_label l) - in - if aliasold = None then - let old = Option.get old in - let new_with_decl,subst1 = - match with_decl with - With_definition_body (_,c) -> With_definition_body (idl,c),None - | With_module_body (idc,mp,typ_opt,cst) -> - let mp' = scrape_alias mp env' in - With_module_body (idl,mp,typ_opt,cst), - Some(map_mp (mp_rec (List.rev idc)) mp') - in - let subst = match subst1 with - | None -> None - | Some s -> Some (join s (update_subst alias s)) in - let modtype,subst_msb = - merge_with env' (type_of_mb env' old) new_with_decl alias in - let msb = - { mod_expr = None; - mod_type = Some modtype; - mod_constraints = old.mod_constraints; - mod_alias = begin - match subst_msb with - |None -> empty_subst - |Some s -> s - end; - mod_retroknowledge = old.mod_retroknowledge} - in - (SFBmodule msb),subst - else - let mpold,typ_opt,cst = Option.get aliasold in - SFBalias (mpold,typ_opt,cst),None - in - SEBstruct(msid, before@(l,new_spec):: - (Option.fold_right subst_structure subst after)),subst - with - Not_found -> error_no_such_label l - -and add_signature mp sign env = +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 = make_con mp empty_dirpath l in + let con = constant_of_kn kn in + let mind = mind_of_kn kn in match elem with - | SFBconst cb -> Environ.add_constant con cb env - | SFBmind mib -> Environ.add_mind kn mib env - | SFBmodule mb -> - add_module (MPdot (mp,l)) mb env + | 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 *) - | SFBalias (mp1,_,cst) -> - Environ.register_alias (MPdot(mp,l)) mp1 env - | SFBmodtype mtb -> Environ.add_modtype (MPdot(mp,l)) - mtb env + | SFBmodtype mtb -> Environ.add_modtype mtb.typ_mp mtb env in List.fold_left add_one env sign -and add_module mp mb env = +and add_module mb env = + let mp = mb.mod_mp in let env = Environ.shallow_add_module mp mb env in - let env = - Environ.add_modtype mp (module_type_of_module (Some mp) mb) env - in - let mod_typ = type_of_mb env mb in - match mod_typ with - | SEBstruct (msid,sign) -> - add_retroknowledge msid mp (mb.mod_retroknowledge) - (add_signature mp (subst_signature_msid msid mp sign) env) + match mb.mod_type with + | SEBstruct (sign) -> + add_retroknowledge mp mb.mod_retroknowledge + (add_signature mp sign mb.mod_delta env) | SEBfunctor _ -> env | _ -> anomaly "Modops:the evaluation of the structure failed " - - -and constants_of_specification env mp sign = - let aux (env,res) (l,elem) = - match elem with - | SFBconst cb -> env,((make_con mp empty_dirpath l),cb)::res - | SFBmind _ -> env,res - | SFBmodule mb -> - let new_env = add_module (MPdot (mp,l)) mb env in - new_env,(constants_of_modtype env (MPdot (mp,l)) - (type_of_mb env mb)) @ res - | SFBalias (mp1,typ_opt,cst) -> - let new_env = register_alias (MPdot (mp,l)) mp1 env in - new_env,(constants_of_modtype env (MPdot (mp,l)) - (eval_struct env (SEBident mp1))) @ res - | SFBmodtype mtb -> - (* module type dans un module type. - Il faut au moins mettre mtb dans l'environnement (avec le bon - kn pour pouvoir continuer aller deplier les modules utilisant ce - mtb - ex: - Module Type T1. - Module Type T2. - .... - End T2. - ..... - Declare Module M : T2. - End T2 - si on ne rajoute pas T2 dans l'environement de typage - on va exploser au moment du Declare Module - *) - let new_env = Environ.add_modtype (MPdot(mp,l)) mtb env in - new_env, (constants_of_modtype env (MPdot(mp,l)) mtb.typ_expr) @ res - in - snd (List.fold_left aux (env,[]) sign) - -and constants_of_modtype env mp modtype = - match (eval_struct env modtype) with - SEBstruct (msid,sign) -> - constants_of_specification env mp - (subst_signature_msid msid mp sign) - | SEBfunctor _ -> [] - | _ -> anomaly "Modops:the evaluation of the structure failed " - -(* returns a resolver for kn that maps mbid to mp. We only keep - constants that have the inline flag *) -and resolver_of_environment mbid modtype mp alias env = - let constants = constants_of_modtype env (MPbound mbid) modtype.typ_expr in - let constants = List.map (fun (l,cb) -> (l,subst_const_body alias cb)) constants in - let rec make_resolve = function - | [] -> [] - | (con,expecteddef)::r -> - let con' = replace_mp_in_con (MPbound mbid) mp con in - let con',_ = subst_con alias con' in - (* let con' = replace_mp_in_con (MPbound mbid) mp con' in *) - try - if expecteddef.Declarations.const_inline then - 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 - (con,constr)::(make_resolve r) - else make_resolve r - else make_resolve r - with Not_found -> error_no_such_label (con_label con') - in - let resolve = make_resolve constants in - Mod_subst.make_resolver resolve +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 = + if mp_in_delta mb.mod_mp mb.mod_delta then + 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 + { 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 + (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 = + 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' + | (_,SFBmind _ as item):: rest -> + let resolve_out,rest' = + strengthen_sig env 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 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' -and strengthen_mtb env mp mtb = - let mtb1 = eval_struct env mtb in - match mtb1 with - | SEBfunctor _ -> mtb1 - | SEBstruct (msid,sign) -> - SEBstruct (msid,strengthen_sig env msid sign mp) - | _ -> anomaly "Modops:the evaluation of the structure failed " - -and strengthen_mod env mp mb = - let mod_typ = type_of_mb env mb in - { mod_expr = mb.mod_expr; - mod_type = Some (strengthen_mtb env mp mod_typ); - mod_constraints = mb.mod_constraints; - mod_alias = mb.mod_alias; - mod_retroknowledge = mb.mod_retroknowledge} - -and strengthen_sig env msid sign mp = match sign with - | [] -> [] - | (l,SFBconst cb) :: rest -> - let item' = l,SFBconst (strengthen_const env mp l cb) in - let rest' = strengthen_sig env msid rest mp in +let strengthen env mtb mp = + if mp_in_delta mtb.typ_mp mtb.typ_delta then + (* in this case mtb has already been strengthened*) + mtb + else + match mtb.typ_expr with + | SEBstruct (sign) -> + let resolve_out,sign_out = + strengthen_sig env 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 = + match mp with + Some mp -> + strengthen env { + 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; + typ_expr_alg = None; + 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 rec make_inline delta = function + | [] -> delta + | 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)) + in + make_inline delta constants + +let rec strengthen_and_subst_mod + mb subst env mp_from mp_to env resolver = + 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 + subst_module subst + (fun resolver subst-> subst_dom_delta_resolver subst resolver) mb + else + let resolver,new_sig = + strengthen_and_subst_struct str subst env + mp_from mp_from mp_to false false mb.mod_delta + in + {mb with + mod_mp = mp_to; + mod_expr = Some (SEBident mp_from); + mod_type = SEBstruct(new_sig); + mod_delta = add_mp_delta_resolver mp_to mp_from resolver} + | SEBfunctor(arg_id,arg_b,body) -> + let subst = add_mp mb.mod_mp mp_to empty_delta_resolver subst in + subst_module subst + (fun resolver subst-> subst_dom_codom_delta_resolver subst resolver) mb + + | _ -> 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 = + match str with + | [] -> empty_delta_resolver,[] + | (l,SFBconst cb) :: rest -> + let item' = if alias then + l,SFBconst (subst_const_body subst cb) + else + l,SFBconst (strengthen_const env 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 + 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' - | (l,SFBmind mib) :: rest -> - let item' = l,SFBmind (strengthen_mind env mp l mib) in - let rest' = strengthen_sig env msid rest mp in + else + resolve_out,item'::rest' + | (l,SFBmind mib) :: rest -> + 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 + 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' - | (l,SFBmodule mb) :: rest -> - let mp' = MPdot (mp,l) in - let item' = l,SFBmodule (strengthen_mod env mp' mb) in - let env' = add_module - (MPdot (MPself msid,l)) mb env in - let rest' = strengthen_sig env' msid rest mp in + 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 + let mb_out = if alias then + subst_module subst + (fun resolver subst -> subst_dom_delta_resolver subst resolver) mb + else + strengthen_and_subst_mod + mb subst env mp_from' mp_to' env 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' + 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 + add_delta_resolver resolve_out mb_out.mod_delta, item':: rest' - | ((l,SFBalias (mp1,_,cst)) as item) :: rest -> - let env' = register_alias (MPdot(MPself msid,l)) mp1 env in - let rest' = strengthen_sig env' msid rest mp in - item::rest' - | (l,SFBmodtype mty as item) :: rest -> - let env' = add_modtype - (MPdot((MPself msid),l)) - mty - env - in - let rest' = strengthen_sig env' msid rest mp in - item::rest' - + | (l,SFBmodtype mty) :: rest -> + let mp_from' = MPdot (mp_from,l) in + let mp_to' = MPdot(mp_to,l) in + 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' + 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 env mtb mp = strengthen_mtb env mp mtb +let strengthen_and_subst_mb mb mp env 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 + (i.e. it is already done)*) + let mp_alias = delta_of_mp 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 + 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 + in + {mb with + mod_mp = mp; + mod_type = SEBstruct(new_sig); + mod_expr = Some (SEBident mb.mod_mp); + mod_delta = if include_b then resolver_out + else add_delta_resolver new_resolver resolver_out} + | SEBfunctor(arg_id,argb,body) -> + let subst = map_mp mb.mod_mp mp empty_delta_resolver in + subst_module subst + (fun resolver subst -> subst_dom_codom_delta_resolver subst resolver) mb + | _ -> anomaly "Modops:the evaluation of the structure failed " -let update_subst env mb mp = - match type_of_mb env mb with - | SEBstruct(msid,str) -> false, join_alias - (subst_key (map_msid msid mp) mb.mod_alias) - (map_msid msid mp) - | _ -> true, mb.mod_alias +let subst_modtype_and_resolver mtb mp env = + 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 + subst_modtype full_subst + (fun resolver subst -> subst_dom_codom_delta_resolver subst resolver) mtb + +let rec is_bounded_expr l = function + | SEBident mp -> List.mem mp l + | SEBapply (fexpr,mexpr,_) -> + is_bounded_expr l mexpr || is_bounded_expr l fexpr + | _ -> false + +let rec clean_struct l = function + | (lab,SFBmodule mb) as field -> + let clean_typ = clean_expr l mb.mod_type in + let clean_impl = + begin try + if (is_bounded_expr l (Option.get mb.mod_expr)) then + Some clean_typ + else Some (clean_expr l (Option.get mb.mod_expr)) + with + Option.IsNone -> None + end in + if clean_typ==mb.mod_type && clean_impl==mb.mod_expr then + field + else + (lab,SFBmodule {mb with + mod_type=clean_typ; + mod_expr=clean_impl}) + | field -> field + +and clean_expr l = function + | SEBfunctor (mbid,sigt,str) as s-> + let str_clean = clean_expr l str in + let sig_clean = clean_expr l sigt.typ_expr in + if str_clean == str && sig_clean = sigt.typ_expr then + s else SEBfunctor (mbid,{sigt with typ_expr=sig_clean},str_clean) + | SEBstruct str as s-> + let str_clean = Util.list_smartmap (clean_struct l) str in + if str_clean == str then s else SEBstruct(str_clean) + | str -> str + +let rec collect_mbid l = function + | SEBfunctor (mbid,sigt,str) as s-> + let str_clean = collect_mbid ((MPbound mbid)::l) str in + if str_clean == str then s else + SEBfunctor (mbid,sigt,str_clean) + | SEBstruct str as s-> + let str_clean = Util.list_smartmap (clean_struct l) str in + if str_clean == str then s else SEBstruct(str_clean) + | _ -> anomaly "Modops:the evaluation of the structure failed " + + +let clean_bounded_mod_expr = function + | SEBfunctor _ as str -> + let str_clean = collect_mbid [] str in + if str_clean == str then str else str_clean + | str -> str diff --git a/kernel/modops.mli b/kernel/modops.mli index 2d8b21ad..3488a312 100644 --- a/kernel/modops.mli +++ b/kernel/modops.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: modops.mli 10664 2008-03-14 11:27:37Z soubiran $ i*) +(*i $Id$ i*) (*i*) open Util @@ -20,46 +20,40 @@ open Mod_subst (* Various operations on modules and module types *) -(* make the environment entry out of type *) -val module_body_of_type : module_type_body -> module_body -val module_type_of_module : module_path option -> module_body -> - module_type_body +val module_body_of_type : module_path -> module_type_body -> module_body -val destr_functor : - env -> struct_expr_body -> mod_bound_id * module_type_body * struct_expr_body +val module_type_of_module : env -> module_path option -> module_body -> + module_type_body -val subst_modtype : substitution -> module_type_body -> module_type_body -val subst_structure : substitution -> structure_body -> structure_body +val destr_functor : + env -> struct_expr_body -> mod_bound_id * module_type_body * struct_expr_body val subst_struct_expr : substitution -> struct_expr_body -> struct_expr_body -val subst_signature_msid : - mod_self_id -> module_path -> - structure_body -> structure_body +val subst_signature : substitution -> structure_body -> structure_body -val subst_structure : substitution -> structure_body -> structure_body +val add_signature : + module_path -> structure_body -> delta_resolver -> env -> env -(* Evaluation functions *) -val eval_struct : env -> struct_expr_body -> struct_expr_body +(* adds a module and its components, but not the constraints *) +val add_module : module_body -> env -> env -val type_of_mb : env -> module_body -> struct_expr_body +val check_modpath_equiv : env -> module_path -> module_path -> unit -(* [add_signature mp sign env] assumes that the substitution [msid] - $\mapsto$ [mp] has already been performed (or is not necessary, like - when [mp = MPself msid]) *) -val add_signature : - module_path -> structure_body -> env -> env +val strengthen : env -> module_type_body -> module_path -> module_type_body -(* adds a module and its components, but not the constraints *) -val add_module : - module_path -> module_body -> env -> env +val complete_inline_delta_resolver : + env -> module_path -> mod_bound_id -> module_type_body -> + delta_resolver -> delta_resolver -val check_modpath_equiv : env -> module_path -> module_path -> unit +val strengthen_and_subst_mb : module_body -> module_path -> env -> bool + -> module_body -val strengthen : env -> struct_expr_body -> module_path -> struct_expr_body +val subst_modtype_and_resolver : module_type_body -> module_path -> env -> + module_type_body -val update_subst : env -> module_body -> module_path -> bool * substitution +val clean_bounded_mod_expr : struct_expr_body -> struct_expr_body val error_existing_label : label -> 'a @@ -69,13 +63,13 @@ val error_application_to_not_path : module_struct_entry -> 'a val error_not_a_functor : module_struct_entry -> 'a -val error_incompatible_modtypes : +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_incompatible_labels : label -> label -> 'a val error_no_such_label : label -> 'a @@ -84,15 +78,17 @@ 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_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_modtype_loc : loc -> string -> 'a -val error_not_a_module_loc : loc -> string -> 'a +val error_not_a_module_loc : loc -> string -> 'a -val error_not_a_module : 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 @@ -102,9 +98,9 @@ val error_a_generative_module_expected : label -> 'a val error_local_context : label option -> 'a -val error_no_such_label_sub : label->string->string->'a +val error_no_such_label_sub : label->string->'a + +val error_with_in_module : unit -> 'a -val resolver_of_environment : - mod_bound_id -> module_type_body -> module_path -> substitution - -> env -> resolver +val error_application_to_module_type : unit -> 'a diff --git a/kernel/names.ml b/kernel/names.ml index b4dcd7c8..4e444985 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: names.ml 11750 2009-01-05 20:47:34Z herbelin $ *) +(* $Id$ *) open Pp open Util @@ -23,7 +23,7 @@ let string_of_id id = String.copy id (* Hash-consing of identifier *) module Hident = Hashcons.Make( - struct + struct type t = string type u = string -> string let hash_sub hstr id = hstr id @@ -31,7 +31,7 @@ module Hident = Hashcons.Make( let hash = Hashtbl.hash end) -module IdOrdered = +module IdOrdered = struct type t = identifier let compare = id_ord @@ -47,17 +47,11 @@ type name = Name of identifier | Anonymous (* 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 -module ModIdOrdered = - struct - type t = identifier - let compare = Pervasives.compare - end - -module ModIdmap = Map.Make(ModIdOrdered) +module ModIdmap = Idmap let make_dirpath x = x let repr_dirpath x = x @@ -69,30 +63,21 @@ let string_of_dirpath = function | sl -> String.concat "." (List.map string_of_id (List.rev sl)) -let u_number = ref 0 +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) let debug_string_of_uid (i,s,p) = "<"(*^string_of_dirpath p ^"#"^*) ^ s ^"#"^ string_of_int i^">" -let string_of_uid (i,s,p) = +let string_of_uid (i,s,p) = string_of_dirpath p ^"."^s -module Umap = Map.Make(struct - type t = uniq_ident +module Umap = Map.Make(struct + type t = uniq_ident let compare = Pervasives.compare end) type label = string -type mod_self_id = uniq_ident -let make_msid = make_uid -let repr_msid (n, id, dp) = (n, id, dp) -let debug_string_of_msid = debug_string_of_uid -let refresh_msid (_,s,dir) = make_uid dir s -let string_of_msid = string_of_uid -let id_of_msid (_,s,_) = s -let label_of_msid (_,s,_) = s - type mod_bound_id = uniq_ident let make_mbid = make_uid let repr_mbid (n, id, dp) = (n, id, dp) @@ -114,10 +99,9 @@ module Labmap = Idmap type module_path = | MPfile of dir_path | MPbound of mod_bound_id - | MPself of mod_self_id + (* | MPapp of module_path * module_path *) | MPdot of module_path * label - let rec check_bound_mp = function | MPbound _ -> true | MPdot(mp,_) ->check_bound_mp mp @@ -126,12 +110,14 @@ let rec check_bound_mp = function let rec string_of_mp = function | MPfile sl -> "MPfile (" ^ string_of_dirpath sl ^ ")" | MPbound uid -> string_of_uid uid - | MPself 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 *) let rec mp_ord mp1 mp2 = match (mp1,mp2) with - MPdot(mp1,l1), MPdot(mp2,l2) -> + MPdot(mp1,l1), MPdot(mp2,l2) -> let c = Pervasives.compare l1 l2 in if c<>0 then c @@ -154,31 +140,53 @@ type kernel_name = module_path * dir_path * label let make_kn mp dir l = (mp,dir,l) let repr_kn kn = kn -let modpath kn = +let modpath kn = let mp,_,_ = repr_kn kn in mp -let label kn = +let label kn = let _,_,l = repr_kn kn in l -let string_of_kn (mp,dir,l) = +let string_of_kn (mp,dir,l) = string_of_mp mp ^ "#" ^ string_of_dirpath dir ^ "#" ^ string_of_label l let pr_kn kn = str (string_of_kn kn) -let kn_ord kn1 kn2 = +let kn_ord kn1 kn2 = let mp1,dir1,l1 = kn1 in let mp2,dir2,l2 = kn2 in let c = Pervasives.compare l1 l2 in if c <> 0 then c - else + else let c = Pervasives.compare dir1 dir2 in if c<>0 then - c + c else MPord.compare mp1 mp2 +(* 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 + kn1 \rhd_{\delta}^* kn2 \rhd_{\delta} t *) +type constant = kernel_name*kernel_name + +(* 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 *) +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 @@ -188,64 +196,115 @@ end module KNmap = Map.Make(KNord) module KNpred = Predicate.Make(KNord) module KNset = Set.Make(KNord) -module Cmap = KNmap -module Cpred = KNpred -module Cset = KNset + +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_msid = (make_msid initial_dir "If you see this, it's a bug") -let initial_path = MPself initial_msid +let initial_path = MPfile initial_dir type variable = identifier -type constant = kernel_name -type mutual_inductive = kernel_name + +(* 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 -let make_con mp dir l = (mp,dir,l) -let repr_con con = con -let string_of_con = string_of_kn -let con_label = label -let pr_con = pr_kn -let con_modpath = modpath - -let mind_modpath = modpath +let constant_of_kn kn = (kn,kn) +let constant_of_kn_equiv kn1 kn2 = (kn1,kn2) +let make_con mp dir l = ((mp,dir,l),(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_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)) +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 ith_mutual_inductive (kn,_) i = (kn,i) let ith_constructor_of_inductive ind i = (ind,i) let inductive_of_constructor (ind,i) = ind 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 InductiveOrdered = struct type t = inductive - let compare (spx,ix) (spy,iy) = - let c = ix - iy in if c = 0 then KNord.compare spx spy else c + let compare (spx,ix) (spy,iy) = + let c = ix - iy in if c = 0 then Canonical_ord.compare spx spy else c +end + +module InductiveOrdered_env = struct + type t = inductive + let compare (spx,ix) (spy,iy) = + let c = ix - iy in if c = 0 then User_ord.compare spx spy else c end module Indmap = Map.Make(InductiveOrdered) +module Indmap_env = Map.Make(InductiveOrdered_env) module ConstructorOrdered = struct type t = constructor - let compare (indx,ix) (indy,iy) = + let compare (indx,ix) (indy,iy) = let c = ix - iy in if c = 0 then InductiveOrdered.compare indx indy else c end +module ConstructorOrdered_env = struct + type t = constructor + let compare (indx,ix) (indy,iy) = + let c = ix - iy in if c = 0 then InductiveOrdered_env.compare indx indy else c +end + module Constrmap = Map.Make(ConstructorOrdered) +module Constrmap_env = Map.Make(ConstructorOrdered_env) (* Better to have it here that in closure, since used in grammar.cma *) type evaluable_global_reference = | EvalVarRef of identifier | EvalConstRef of constant +let eq_egr e1 e2 = match e1,e2 with + EvalConstRef con1, EvalConstRef con2 -> eq_constant con1 con2 + | _,_ -> e1 = e2 + (* Hash-consing of name objects *) module Hname = Hashcons.Make( - struct + struct type t = name type u = identifier -> identifier let hash_sub hident = function @@ -260,7 +319,7 @@ module Hname = Hashcons.Make( end) module Hdir = Hashcons.Make( - struct + struct type t = dir_path type u = identifier -> identifier let hash_sub hident d = List.map hident d @@ -272,7 +331,7 @@ module Hdir = Hashcons.Make( end) module Huniqid = Hashcons.Make( - struct + 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) @@ -281,31 +340,31 @@ module Huniqid = Hashcons.Make( end) module Hmod = Hashcons.Make( - struct + struct type t = module_path type u = (dir_path -> dir_path) * (uniq_ident -> uniq_ident) * (string -> string) let rec hash_sub (hdir,huniqid,hstr as hfuns) = function | MPfile dir -> MPfile (hdir dir) | MPbound m -> MPbound (huniqid m) - | MPself m -> MPself (huniqid m) | MPdot (md,l) -> MPdot (hash_sub hfuns md, hstr l) let rec equal d1 d2 = match (d1,d2) with | MPfile dir1, MPfile dir2 -> dir1 == dir2 | MPbound m1, MPbound m2 -> m1 == m2 - | MPself m1, MPself m2 -> m1 == m2 | MPdot (mod1,l1), MPdot (mod2,l2) -> equal mod1 mod2 & l1 = l2 | _ -> false let hash = Hashtbl.hash end) -module Hkn = Hashcons.Make( + +module Hcn = Hashcons.Make( struct - type t = kernel_name + type t = kernel_name*kernel_name type u = (module_path -> module_path) * (dir_path -> dir_path) * (string -> string) - let hash_sub (hmod,hdir,hstr) (md,dir,l) = (hmod md, hdir dir, hstr l) - let equal (mod1,dir1,l1) (mod2,dir2,l2) = + 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),_) = mod1 == mod2 && dir1 == dir2 && l1 == l2 let hash = Hashtbl.hash end) @@ -317,8 +376,9 @@ let hcons_names () = 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 hkn = Hashcons.simple_hcons Hkn.f (hmod,hdir,hstring) in - (hkn,hkn,hdir,hname,hident,hstring) + 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) (*******) @@ -333,12 +393,21 @@ let cst_full_transparent_state = (Idpred.empty, Cpred.full) type 'a tableKey = | ConstKey of constant | VarKey of identifier - | RelKey of 'a + | RelKey of 'a type inv_rel_key = int (* index in the [rel_context] part of environment - starting by the end, {\em inverse} + starting by the end, {\em inverse} of de Bruijn indice *) type id_key = inv_rel_key tableKey +let eq_id_key ik1 ik2 = + match ik1,ik2 with + ConstKey (_,kn1), + ConstKey (_,kn2) -> kn1=kn2 + | a,b -> a=b + +let eq_con_chk (kn1,_) (kn2,_) = kn1=kn2 +let eq_mind_chk (kn1,_) (kn2,_) = kn1=kn2 +let eq_ind_chk (kn1,i1) (kn2,i2) = i1=i2&&eq_mind_chk kn1 kn2 diff --git a/kernel/names.mli b/kernel/names.mli index 49b10bfe..632f3733 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: names.mli 11582 2008-11-12 19:49:57Z notin $ i*) +(*i $Id$ i*) (*s Identifiers *) @@ -39,25 +39,13 @@ val empty_dirpath : dir_path (* Printing of directory paths as ["coq_root.module.submodule"] *) val string_of_dirpath : dir_path -> string - -(*s Unique identifier to be used as "self" in structures and - signatures - invisible for users *) -type label -type mod_self_id - -(* The first argument is a file name - to prevent conflict between - different files *) -val make_msid : dir_path -> string -> mod_self_id -val repr_msid : mod_self_id -> int * string * dir_path -val id_of_msid : mod_self_id -> identifier -val label_of_msid : mod_self_id -> label -val refresh_msid : mod_self_id -> mod_self_id -val debug_string_of_msid : mod_self_id -> string -val string_of_msid : mod_self_id -> 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 @@ -80,9 +68,9 @@ module Labmap : Map.S with type key = label type module_path = | MPfile of dir_path | MPbound of mod_bound_id - | MPself of mod_self_id + (* | MPapp of module_path * module_path very soon *) | MPdot of module_path * label -(*i | MPapply of module_path * module_path in the future (maybe) i*) + val check_bound_mp : module_path -> bool @@ -91,13 +79,12 @@ 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 -(* Name of the toplevel structure *) -val initial_msid : mod_self_id -val initial_path : module_path (* [= MPself initial_msid] *) - (* 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] *) + (*s The absolute names of objects seen by kernel *) type kernel_name @@ -122,25 +109,64 @@ module KNmap : Map.S with type key = kernel_name type variable = identifier type constant -type mutual_inductive = kernel_name +type mutual_inductive (* Beware: first inductive has index 0 *) type inductive = mutual_inductive * int (* Beware: first constructor has index 1 *) type constructor = inductive * int +(* *_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 module Cpred : Predicate.S with type elt = constant module Cset : Set.S with type elt = constant +module Cset_env : Set.S with type elt = constant +module Mindmap : Map.S with type key = mutual_inductive +module Mindmap_env : Map.S with type key = mutual_inductive +module Mindset : Set.S with type elt = mutual_inductive module Indmap : Map.S with type key = inductive module Constrmap : Map.S with type key = constructor +module Indmap_env : Map.S with type key = inductive +module Constrmap_env : Map.S with type key = constructor val constant_of_kn : kernel_name -> constant +val constant_of_kn_equiv : kernel_name -> kernel_name -> constant val make_con : module_path -> dir_path -> label -> constant +val make_con_equiv : module_path -> module_path -> dir_path + -> label -> constant +val user_con : constant -> kernel_name +val canonical_con : constant -> kernel_name val repr_con : constant -> module_path * dir_path * label +val eq_constant : constant -> constant -> bool + val string_of_con : constant -> string val con_label : constant -> label val con_modpath : constant -> module_path val pr_con : constant -> Pp.std_ppcmds +val debug_pr_con : constant -> Pp.std_ppcmds +val debug_string_of_con : constant -> string + + + +val mind_of_kn : kernel_name -> mutual_inductive +val mind_of_kn_equiv : kernel_name -> kernel_name -> mutual_inductive +val make_mind : module_path -> dir_path -> label -> mutual_inductive +val make_mind_equiv : module_path -> module_path -> dir_path + -> label -> mutual_inductive +val user_mind : mutual_inductive -> kernel_name +val canonical_mind : mutual_inductive -> kernel_name +val repr_mind : mutual_inductive -> module_path * dir_path * label +val eq_mind : mutual_inductive -> mutual_inductive -> bool + +val string_of_mind : mutual_inductive -> string +val mind_label : mutual_inductive -> label +val mind_modpath : mutual_inductive -> module_path +val pr_mind : mutual_inductive -> Pp.std_ppcmds +val debug_pr_mind : mutual_inductive -> Pp.std_ppcmds +val debug_string_of_mind : mutual_inductive -> string + + val mind_modpath : mutual_inductive -> module_path val ind_modpath : inductive -> module_path @@ -150,16 +176,21 @@ val ith_mutual_inductive : inductive -> int -> inductive val ith_constructor_of_inductive : inductive -> int -> constructor val inductive_of_constructor : constructor -> inductive 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 *) type evaluable_global_reference = | EvalVarRef of identifier | EvalConstRef of constant +val eq_egr : evaluable_global_reference -> evaluable_global_reference + -> bool + (* Hash-consing *) val hcons_names : unit -> (constant -> constant) * - (kernel_name -> kernel_name) * (dir_path -> dir_path) * + (mutual_inductive -> mutual_inductive) * (dir_path -> dir_path) * (name -> name) * (identifier -> identifier) * (string -> string) @@ -168,7 +199,7 @@ val hcons_names : unit -> type 'a tableKey = | ConstKey of constant | VarKey of identifier - | RelKey of 'a + | RelKey of 'a type transparent_state = Idpred.t * Cpred.t @@ -178,7 +209,16 @@ 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} + starting by the end, {\em inverse} of de Bruijn indice *) type id_key = inv_rel_key tableKey + +val eq_id_key : id_key -> id_key -> bool + +(*equalities on constant and inductive + names for the checker*) + +val eq_con_chk : constant -> constant -> bool +val eq_ind_chk : inductive -> inductive -> bool + diff --git a/kernel/pre_env.ml b/kernel/pre_env.ml index dd4d430a..b58951e9 100644 --- a/kernel/pre_env.ml +++ b/kernel/pre_env.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: pre_env.ml 10664 2008-03-14 11:27:37Z soubiran $ *) +(* $Id$ *) open Util open Names @@ -18,23 +18,22 @@ open Declarations (* The type of environments. *) -type key = int option ref +type key = int option ref type constant_key = constant_body * key - + type globals = { - env_constants : constant_key Cmap.t; - env_inductives : mutual_inductive_body KNmap.t; + env_constants : constant_key Cmap_env.t; + env_inductives : mutual_inductive_body Mindmap_env.t; env_modules : module_body MPmap.t; - env_modtypes : module_type_body MPmap.t; - env_alias : module_path MPmap.t } + env_modtypes : module_type_body MPmap.t} type stratification = { env_universes : universes; env_engagement : engagement option } -type val_kind = +type val_kind = | VKvalue of values * Idset.t | VKnone @@ -56,13 +55,12 @@ type named_context_val = named_context * named_vals let empty_named_context_val = [],[] -let empty_env = { +let empty_env = { env_globals = { - env_constants = Cmap.empty; - env_inductives = KNmap.empty; + env_constants = Cmap_env.empty; + env_inductives = Mindmap_env.empty; env_modules = MPmap.empty; - env_modtypes = MPmap.empty; - env_alias = MPmap.empty }; + env_modtypes = MPmap.empty}; env_named_context = empty_named_context; env_named_vals = []; env_rel_context = empty_rel_context; @@ -77,25 +75,25 @@ let empty_env = { (* Rel context *) let nb_rel env = env.env_nb_rel - + let push_rel d env = let rval = ref VKnone in { env with env_rel_context = add_rel_decl d env.env_rel_context; env_rel_val = rval :: env.env_rel_val; env_nb_rel = env.env_nb_rel + 1 } - + let lookup_rel_val n env = try List.nth env.env_rel_val (n - 1) with _ -> raise Not_found - + let env_of_rel n env = { env with env_rel_context = Util.list_skipn n env.env_rel_context; env_rel_val = Util.list_skipn n env.env_rel_val; env_nb_rel = env.env_nb_rel - n } - + (* Named context *) let push_named_context_val d (ctxt,vals) = @@ -103,36 +101,32 @@ let push_named_context_val d (ctxt,vals) = let rval = ref VKnone in Sign.add_named_decl d ctxt, (id,rval)::vals -exception ASSERT of Sign.rel_context +exception ASSERT of rel_context -let push_named d env = +let push_named d env = (* if not (env.env_rel_context = []) then raise (ASSERT env.env_rel_context); assert (env.env_rel_context = []); *) let id,body,_ = d in let rval = ref VKnone in - { env with + { env with env_named_context = Sign.add_named_decl d env.env_named_context; env_named_vals = (id,rval):: env.env_named_vals } let lookup_named_val id env = snd(List.find (fun (id',_) -> id = id') env.env_named_vals) - + (* Warning all the names should be different *) let env_of_named id env = env - + (* Global constants *) let lookup_constant_key kn env = - Cmap.find kn env.env_globals.env_constants + Cmap_env.find kn env.env_globals.env_constants let lookup_constant kn env = - fst (Cmap.find kn env.env_globals.env_constants) + fst (Cmap_env.find kn env.env_globals.env_constants) (* Mutual Inductives *) let lookup_mind kn env = - KNmap.find kn env.env_globals.env_inductives + Mindmap_env.find kn env.env_globals.env_inductives -let rec scrape_mind env kn = - match (lookup_mind kn env).mind_equiv with - | None -> kn - | Some kn' -> scrape_mind env kn' diff --git a/kernel/pre_env.mli b/kernel/pre_env.mli index 445f4e5f..718132b3 100644 --- a/kernel/pre_env.mli +++ b/kernel/pre_env.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: pre_env.mli 10664 2008-03-14 11:27:37Z soubiran $ *) +(* $Id$ *) open Util open Names @@ -18,23 +18,22 @@ open Declarations (* The type of environments. *) -type key = int option ref +type key = int option ref type constant_key = constant_body * key - + type globals = { - env_constants : constant_key Cmap.t; - env_inductives : mutual_inductive_body KNmap.t; + env_constants : constant_key Cmap_env.t; + env_inductives : mutual_inductive_body Mindmap_env.t; env_modules : module_body MPmap.t; - env_modtypes : module_type_body MPmap.t; - env_alias : module_path MPmap.t } + env_modtypes : module_type_body MPmap.t} type stratification = { env_universes : universes; env_engagement : engagement option } -type val_kind = +type val_kind = | VKvalue of values * Idset.t | VKnone @@ -49,7 +48,7 @@ type env = { env_rel_context : rel_context; env_rel_val : lazy_val list; env_nb_rel : int; - env_stratification : stratification; + env_stratification : stratification; retroknowledge : Retroknowledge.retroknowledge } type named_context_val = named_context * named_vals @@ -63,14 +62,14 @@ val empty_env : env 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 +val env_of_rel : int -> env -> env (* Named context *) -val push_named_context_val : +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 +val env_of_named : identifier -> env -> env (* Global constants *) @@ -80,5 +79,3 @@ val lookup_constant : constant -> env -> constant_body (* Mutual Inductives *) val lookup_mind : mutual_inductive -> env -> mutual_inductive_body -(* Find the ultimate inductive in the [mind_equiv] chain *) -val scrape_mind : env -> mutual_inductive -> mutual_inductive diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 76b32463..18e2c156 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: reduction.ml 11897 2009-02-09 19:28:02Z barras $ *) +(* $Id$ *) open Util open Names @@ -22,7 +22,7 @@ let unfold_reference ((ids, csts), infos) k = | VarKey id when not (Idpred.mem id ids) -> None | ConstKey cst when not (Cpred.mem cst csts) -> None | _ -> unfold_reference infos k - + let rec is_empty_stack = function [] -> true | Zupdate _::s -> is_empty_stack s @@ -87,6 +87,9 @@ let pure_stack lfts stk = (* Reduction Functions *) (****************************************************************************) +let whd_betaiota t = + whd_val (create_clos_infos betaiota empty_env) (inject t) + let nf_betaiota t = norm_val (create_clos_infos betaiota empty_env) (inject t) @@ -96,13 +99,13 @@ let whd_betaiotazeta x = Prod _|Lambda _|Fix _|CoFix _) -> x | _ -> whd_val (create_clos_infos betaiotazeta empty_env) (inject x) -let whd_betadeltaiota env t = +let whd_betadeltaiota env t = match kind_of_term t with | (Sort _|Meta _|Evar _|Ind _|Construct _| Prod _|Lambda _|Fix _|CoFix _) -> t | _ -> whd_val (create_clos_infos betadeltaiota env) (inject t) -let whd_betadeltaiota_nolet env t = +let whd_betadeltaiota_nolet env t = match kind_of_term t with | (Sort _|Meta _|Evar _|Ind _|Construct _| Prod _|Lambda _|Fix _|CoFix _|LetIn _) -> t @@ -117,6 +120,15 @@ let beta_appvect c v = | _ -> applist (substl env t, stack) in stacklam [] c (Array.to_list v) +let betazeta_appvect n c v = + let rec stacklam n env t stack = + if n = 0 then applist (substl env t, stack) else + match kind_of_term t, stack with + Lambda(_,_,c), arg::stacktl -> stacklam (n-1) (arg::env) c stacktl + | LetIn(_,b,_,c), _ -> stacklam (n-1) (b::env) c stack + | _ -> anomaly "Not enough lambda/let's" in + stacklam n [] c (Array.to_list v) + (********************************************************************) (* Conversion *) (********************************************************************) @@ -158,8 +170,8 @@ let compare_stacks f fmind lft1 stk1 lft2 stk2 cuniv = and this holds whatever Set is predicative or impredicative *) -type conv_pb = - | CONV +type conv_pb = + | CONV | CUMUL let sort_cmp pb s0 s1 cuniv = @@ -218,7 +230,7 @@ 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 = +let rec ccnv cv_pb infos lft1 lft2 term1 term2 cuniv = eqappr cv_pb infos (lft1, (term1,[])) (lft2, (term2,[])) cuniv (* Conversion between [lft1](hd1 v1) and [lft2](hd2 v2) *) @@ -240,7 +252,7 @@ and eqappr cv_pb infos (lft1,st1) (lft2,st2) cuniv = (* case of leaves *) | (FAtom a1, FAtom a2) -> (match kind_of_term a1, kind_of_term a2 with - | (Sort s1, Sort s2) -> + | (Sort s1, Sort s2) -> assert (is_empty_stack v1 && is_empty_stack v2); sort_cmp cv_pb s1 s2 cuniv | (Meta n, Meta m) -> @@ -265,7 +277,7 @@ and eqappr cv_pb infos (lft1,st1) (lft2,st2) cuniv = (* 2 constants, 2 local defined vars or 2 defined rels *) | (FFlex fl1, FFlex fl2) -> (try (* try first intensional equality *) - if fl1 = fl2 + if eq_table_key fl1 fl2 then convert_stacks infos lft1 lft2 v1 v2 cuniv else raise NotConvertible with NotConvertible -> @@ -290,7 +302,7 @@ and eqappr cv_pb infos (lft1,st1) (lft2,st2) cuniv = (* only one constant, defined var or defined rel *) | (FFlex fl1, _) -> (match unfold_reference infos fl1 with - | Some def1 -> + | Some def1 -> eqappr cv_pb infos (lft1, whd_stack (snd infos) def1 v1) appr2 cuniv | None -> raise NotConvertible) | (_, FFlex fl2) -> @@ -298,7 +310,7 @@ and eqappr cv_pb infos (lft1,st1) (lft2,st2) cuniv = | Some def2 -> eqappr cv_pb infos appr1 (lft2, whd_stack (snd infos) def2 v2) cuniv | None -> raise NotConvertible) - + (* other constructors *) | (FLambda _, FLambda _) -> assert (is_empty_stack v1 && is_empty_stack v2); @@ -316,13 +328,13 @@ and eqappr cv_pb infos (lft1,st1) (lft2,st2) cuniv = (* Inductive types: MutInd MutConstruct Fix Cofix *) | (FInd ind1, FInd ind2) -> - if mind_equiv_infos (snd infos) ind1 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 && mind_equiv_infos (snd infos) ind1 ind2 + if j1 = j2 && eq_ind ind1 ind2 then convert_stacks infos lft1 lft2 v1 v2 cuniv else raise NotConvertible @@ -337,7 +349,7 @@ and eqappr cv_pb infos (lft1,st1) (lft2,st2) cuniv = 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 + 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 @@ -361,22 +373,22 @@ and eqappr cv_pb infos (lft1,st1) (lft2,st2) cuniv = | ( (FLetIn _, _) | (FCases _,_) | (FApp _,_) | (FCLOS _,_) | (FLIFT _,_) | (_, FLetIn _) | (_,FCases _) | (_,FApp _) | (_,FCLOS _) | (_,FLIFT _) | (FLOCKED,_) | (_,FLOCKED) ) -> assert false - + (* In all other cases, terms are not convertible *) | _ -> raise NotConvertible and convert_stacks infos lft1 lft2 stk1 stk2 cuniv = compare_stacks (fun (l1,t1) (l2,t2) c -> ccnv CONV infos l1 l2 t1 t2 c) - (mind_equiv_infos (snd infos)) + (eq_ind) lft1 stk1 lft2 stk2 cuniv and convert_vect infos lft1 lft2 v1 v2 cuniv = let lv1 = Array.length v1 in let lv2 = Array.length v2 in if lv1 = lv2 - then - let rec fold n univ = + then + let rec fold n univ = if n >= lv1 then univ else let u1 = ccnv CONV infos lft1 lft2 v1.(n) v2.(n) univ in @@ -403,10 +415,10 @@ let conv ?(evars=fun _->None) = fconv CONV evars let conv_leq ?(evars=fun _->None) = fconv CUMUL evars let conv_leq_vecti ?(evars=fun _->None) env v1 v2 = - array_fold_left2_i + array_fold_left2_i (fun i c t1 t2 -> let c' = - try conv_leq ~evars env t1 t2 + try conv_leq ~evars env t1 t2 with NotConvertible -> raise (NotConvertibleVect i) in Constraint.union c c') Constraint.empty @@ -417,25 +429,25 @@ let conv_leq_vecti ?(evars=fun _->None) env v1 v2 = let vm_conv = ref (fun cv_pb -> fconv cv_pb (fun _->None)) let set_vm_conv f = vm_conv := f -let vm_conv cv_pb env t1 t2 = - try +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 - + let default_conv = ref (fun cv_pb -> fconv cv_pb (fun _->None)) let set_default_conv f = default_conv := f -let default_conv cv_pb env t1 t2 = - try +let default_conv cv_pb env t1 t2 = + try !default_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 - + let default_conv_leq = default_conv CUMUL (* let convleqkey = Profile.declare_profile "Kernel_reduction.conv_leq";; @@ -462,37 +474,37 @@ let hnf_prod_app env t n = | Prod (_,_,b) -> subst1 n b | _ -> anomaly "hnf_prod_app: Need a product" -let hnf_prod_applist env t nl = +let hnf_prod_applist env t nl = List.fold_left (hnf_prod_app env) t nl (* Dealing with arities *) -let dest_prod env = +let dest_prod env = let rec decrec env m c = let t = whd_betadeltaiota env c in match kind_of_term t with | Prod (n,a,c0) -> let d = (n,None,a) in - decrec (push_rel d env) (Sign.add_rel_decl d m) c0 + decrec (push_rel d env) (add_rel_decl d m) c0 | _ -> m,t - in - decrec env Sign.empty_rel_context + in + decrec env empty_rel_context (* The same but preserving lets *) -let dest_prod_assum env = +let dest_prod_assum env = let rec prodec_rec env l ty = let rty = whd_betadeltaiota_nolet env ty in match kind_of_term rty with | Prod (x,t,c) -> let d = (x,None,t) in - prodec_rec (push_rel d env) (Sign.add_rel_decl d l) c + prodec_rec (push_rel d env) (add_rel_decl d l) c | LetIn (x,b,t,c) -> let d = (x,Some b,t) in - prodec_rec (push_rel d env) (Sign.add_rel_decl d l) c + prodec_rec (push_rel d env) (add_rel_decl d l) c | Cast (c,_,_) -> prodec_rec env l c | _ -> l,rty in - prodec_rec env Sign.empty_rel_context + prodec_rec env empty_rel_context let dest_arity env c = let l, c = dest_prod_assum env c in diff --git a/kernel/reduction.mli b/kernel/reduction.mli index d8658d43..c7c040c8 100644 --- a/kernel/reduction.mli +++ b/kernel/reduction.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: reduction.mli 11897 2009-02-09 19:28:02Z barras $ i*) +(*i $Id$ i*) (*i*) open Term @@ -21,6 +21,7 @@ val whd_betaiotazeta : constr -> constr val whd_betadeltaiota : env -> constr -> constr val whd_betadeltaiota_nolet : env -> constr -> constr +val whd_betaiota : constr -> constr val nf_betaiota : constr -> constr (************************************************************************) @@ -33,7 +34,7 @@ type 'a trans_conversion_function = Names.transparent_state -> env -> 'a -> 'a - type conv_pb = CONV | CUMUL -val sort_cmp : +val sort_cmp : conv_pb -> sorts -> sorts -> Univ.constraints -> Univ.constraints val conv_sort : sorts conversion_function @@ -63,9 +64,12 @@ val default_conv_leq : 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. *) +val betazeta_appvect : int -> constr -> constr array -> constr + (* Pseudo-reduction rule Prod(x,A,B) a --> B[x\a] *) val hnf_prod_applist : env -> types -> constr list -> types @@ -73,8 +77,8 @@ val hnf_prod_applist : env -> types -> constr list -> types (************************************************************************) (*s Recognizing products and arities modulo reduction *) -val dest_prod : env -> types -> Sign.rel_context * types -val dest_prod_assum : env -> types -> Sign.rel_context * types +val dest_prod : env -> types -> rel_context * types +val dest_prod_assum : env -> types -> rel_context * types -val dest_arity : env -> types -> Sign.arity +val dest_arity : env -> types -> arity val is_arity : env -> types -> bool diff --git a/kernel/retroknowledge.ml b/kernel/retroknowledge.ml index 7a1880be..a3e493db 100644 --- a/kernel/retroknowledge.ml +++ b/kernel/retroknowledge.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: retroknowledge.ml 10739 2008-04-01 14:45:20Z herbelin $ *) +(* $Id$ *) open Term open Names @@ -28,8 +28,8 @@ type nat_field = | NatType | NatPlus | NatTimes - -type n_field = + +type n_field = | NPositive | NType | NTwice @@ -39,7 +39,7 @@ type n_field = | NPlus | NTimes -type int31_field = +type int31_field = | Int31Bits | Int31Type | Int31Twice @@ -77,20 +77,15 @@ type flags = {fastcomputation : bool} (*A definition of maps from strings to pro_int31, to be able to have any amount of coq representation for the 31bits integers *) -module OrderedField = -struct - type t = field - let compare = compare -end - -module Proactive = Map.Make (OrderedField) +module Proactive = + Map.Make (struct type t = field let compare = compare end) type proactive = entry Proactive.t -(* the reactive knowledge is represented as a functionaly map +(* the reactive knowledge is represented as a functionaly map from the type of terms (actually it is the terms whose outermost - layer is unfolded (typically by Term.kind_of_term)) to the + layer is unfolded (typically by Term.kind_of_term)) to the type reactive_end which is a record containing all the kind of reactive information needed *) (* todo: because of the bug with output state, reactive_end should eventually @@ -98,13 +93,8 @@ type proactive = entry Proactive.t a finite type describing the fields to the field of proactive retroknowledge (and then to make as many functions as needed in environ.ml) *) -module OrderedEntry = -struct - type t = entry - let compare = compare -end - -module Reactive = Map.Make (OrderedEntry) +module Reactive = + Map.Make (struct type t = entry let compare = compare end) type reactive_end = {(*information required by the compiler of the VM *) vm_compiling : @@ -141,18 +131,18 @@ type action = (*initialisation*) -let initial_flags = +let initial_flags = {fastcomputation = true;} -let initial_proactive = +let initial_proactive = (Proactive.empty:proactive) -let initial_reactive = +let initial_reactive = (Reactive.empty:reactive) let initial_retroknowledge = - {flags = initial_flags; - proactive = initial_proactive; + {flags = initial_flags; + proactive = initial_proactive; reactive = initial_reactive } let empty_reactive_end = @@ -185,7 +175,7 @@ let find knowledge field = (*access functions for reactive retroknowledge*) (* used for compiling of functions (add, mult, etc..) *) -let get_vm_compiling_info knowledge key = +let get_vm_compiling_info knowledge key = match (Reactive.find key knowledge.reactive).vm_compiling with | None -> raise Not_found @@ -205,18 +195,18 @@ let get_vm_constant_dynamic_info knowledge key = | None -> raise Not_found | Some f -> f knowledge.flags.fastcomputation -let get_vm_before_match_info knowledge key = +let get_vm_before_match_info knowledge key = match (Reactive.find key knowledge.reactive).vm_before_match with | None -> raise Not_found | Some f -> f knowledge.flags.fastcomputation -let get_vm_decompile_constant_info knowledge key = +let get_vm_decompile_constant_info knowledge key = match (Reactive.find key knowledge.reactive).vm_decompile_const with | None -> raise Not_found | Some f -> f - + (* functions manipulating reactive knowledge *) diff --git a/kernel/retroknowledge.mli b/kernel/retroknowledge.mli index ee3fccd5..0f1cdc8e 100644 --- a/kernel/retroknowledge.mli +++ b/kernel/retroknowledge.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: retroknowledge.mli 10739 2008-04-01 14:45:20Z herbelin $ i*) +(*i $Id$ i*) (*i*) open Names @@ -24,8 +24,8 @@ type nat_field = | NatType | NatPlus | NatTimes - -type n_field = + +type n_field = | NPositive | NType | NTwice @@ -35,7 +35,7 @@ type n_field = | NPlus | NTimes -type int31_field = +type int31_field = | Int31Bits | Int31Type | Int31Twice @@ -81,14 +81,14 @@ val initial_retroknowledge : retroknowledge returns the compilation of id in cont if it has a specific treatment or raises Not_found if id should be compiled as usual *) val get_vm_compiling_info : retroknowledge -> entry -> Cbytecodes.comp_env -> - constr array -> + constr array -> int -> Cbytecodes.bytecodes-> Cbytecodes.bytecodes (*Given an identifier id (usually Construct _) and its argument array, returns a function that tries an ad-hoc optimisated compilation (in the case of the 31-bit integers it means compiling them directly into an integer) raises Not_found if id should be compiled as usual, and expectingly - CBytecodes.NotClosed if the term is not a closed constructor pattern + CBytecodes.NotClosed if the term is not a closed constructor pattern (a constant for the compiler) *) val get_vm_constant_static_info : retroknowledge -> entry -> constr array -> @@ -99,19 +99,19 @@ val get_vm_constant_static_info : retroknowledge -> entry -> of id+args+cont when id has a specific treatment (in the case of 31-bit integers, that would be the dynamic compilation into integers) or raises Not_found if id should be compiled as usual *) -val get_vm_constant_dynamic_info : retroknowledge -> entry -> - Cbytecodes.comp_env -> - Cbytecodes.block array -> +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 - over this type. In the case of 31-bit integers for instance, it is used +(* 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 - recover the elements of that type from their compiled form if it's non +(* 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 @@ -127,26 +127,26 @@ val find : retroknowledge -> field -> entry (* 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 -> +val add_vm_compiling_info : retroknowledge-> entry -> (bool -> Cbytecodes.comp_env -> constr array -> int -> Cbytecodes.bytecodes -> Cbytecodes.bytecodes) -> retroknowledge -val add_vm_constant_static_info : retroknowledge-> entry -> +val add_vm_constant_static_info : retroknowledge-> entry -> (bool->constr array-> Cbytecodes.structured_constant) -> retroknowledge -val add_vm_constant_dynamic_info : retroknowledge-> entry -> - (bool -> Cbytecodes.comp_env -> - Cbytecodes.block array -> int -> +val add_vm_constant_dynamic_info : retroknowledge-> entry -> + (bool -> Cbytecodes.comp_env -> + Cbytecodes.block array -> int -> Cbytecodes.bytecodes -> Cbytecodes.bytecodes) -> retroknowledge val add_vm_before_match_info : retroknowledge -> entry -> (bool->Cbytecodes.bytecodes->Cbytecodes.bytecodes) -> retroknowledge -val add_vm_decompile_constant_info : retroknowledge -> entry -> +val add_vm_decompile_constant_info : retroknowledge -> entry -> (int -> constr) -> retroknowledge - + val clear_info : retroknowledge-> entry -> retroknowledge diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 7a2db86b..cf3546c7 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: safe_typing.ml 12187 2009-06-13 19:36:59Z msozeau $ *) +(* $Id$ *) open Util open Names @@ -27,21 +27,21 @@ open Subtyping open Mod_typing open Mod_subst -type modvariant = - | NONE - | SIG of (* funsig params *) (mod_bound_id * module_type_body) list + +type modvariant = + | NONE + | SIG of (* funsig params *) (mod_bound_id * module_type_body) list | STRUCT of (* functor params *) (mod_bound_id * module_type_body) list | LIBRARY of dir_path -type module_info = - { msid : mod_self_id; - modpath : module_path; - seed : dir_path; (* the "seed" of unique identifier generator *) - label : label; - variant : modvariant; - alias_subst : substitution} - -let check_label l labset = +type module_info = + {modpath : module_path; + label : label; + variant : modvariant; + resolver : delta_resolver; + resolver_of_param : delta_resolver;} + +let check_label l labset = if Labset.mem l labset then error_existing_label l let set_engagement_opt oeng env = @@ -51,7 +51,7 @@ let set_engagement_opt oeng env = type library_info = dir_path * Digest.t -type safe_environment = +type safe_environment = { old : safe_environment; env : env; modinfo : module_info; @@ -75,16 +75,15 @@ type safe_environment = (* a small hack to avoid variants and an unused case in all functions *) -let rec empty_environment = - { old = empty_environment; +let rec empty_environment = + { old = empty_environment; env = empty_env; modinfo = { - msid = initial_msid; modpath = initial_path; - seed = initial_dir; label = mk_label "_"; variant = NONE; - alias_subst = empty_subst}; + resolver = empty_delta_resolver; + resolver_of_param = empty_delta_resolver}; labset = Labset.empty; revstruct = []; univ = Univ.Constraint.empty; @@ -102,7 +101,7 @@ let env_of_senv = env_of_safe_env -let add_constraints cst senv = +let add_constraints cst senv = {senv with env = Environ.add_constraints cst senv.env; univ = Univ.Constraint.union cst senv.univ } @@ -112,7 +111,7 @@ let add_constraints cst senv = (* terms which are closed under the environnement env, i.e terms which only depends on constant who are themselves closed *) -let closed env term = +let closed env term = ContextObjectMap.is_empty (assumptions full_transparent_state env term) (* the set of safe terms in an environement any recursive set of @@ -125,15 +124,15 @@ let safe = (* universal lifting, used for the "get" operations mostly *) -let retroknowledge f senv = +let retroknowledge f senv = Environ.retroknowledge f (env_of_senv senv) -let register senv field value by_clause = +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 = + local_retroknowledge = Retroknowledge.RKRegister (field,value)::senv.local_retroknowledge } @@ -162,7 +161,7 @@ let unregister senv field = let safe_push_named (id,_,_ as d) env = let _ = try - let _ = lookup_named id env in + let _ = lookup_named id env in error ("Identifier "^string_of_id id^" already defined.") with Not_found -> () in Environ.push_named d env @@ -182,7 +181,7 @@ let push_named_assum (id,t) senv = (* Insertion of constants and parameters in environment. *) -type global_declaration = +type global_declaration = | ConstantEntry of constant_entry | GlobalRecipe of Cooking.recipe @@ -205,8 +204,8 @@ let hcons_constant_body cb = 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 + let cb = + match decl with | ConstantEntry ce -> translate_constant senv.env kn ce | GlobalRecipe r -> let cb = translate_recipe senv.env kn r in @@ -214,9 +213,16 @@ let add_constant dir l decl senv = 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 + in kn, { old = senv'.old; env = env''; - modinfo = senv'.modinfo; + modinfo = {senv'.modinfo with + resolver = resolver}; labset = Labset.add l senv'.labset; revstruct = (l,SFBconst cb)::senv'.revstruct; univ = senv'.univ; @@ -224,24 +230,24 @@ let add_constant dir l decl senv = imports = senv'.imports; loads = senv'.loads ; local_retroknowledge = senv'.local_retroknowledge } - + (* Insertion of inductive types. *) let add_mind dir l mie senv = - if mie.mind_entry_inds = [] then - anomaly "empty inductive types declaration"; + if mie.mind_entry_inds = [] then + anomaly "empty inductive types declaration"; (* this test is repeated by translate_mind *) let id = (List.nth mie.mind_entry_inds 0).mind_entry_typename in if l <> label_of_id id then anomaly ("the label of inductive packet and its first inductive"^ " type do not match"); - check_label l senv.labset; - (* TODO: when we will allow reorderings we will have to verify + check_label l senv.labset; + (* TODO: when we will allow reorderings we will have to verify all labels *) let mib = translate_mind senv.env mie in let senv' = add_constraints mib.mind_constraints senv in - let kn = make_kn senv.modinfo.modpath dir l 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''; @@ -256,212 +262,221 @@ let add_mind dir l mie senv = (* Insertion of module types *) -let add_modtype l mte senv = - check_label l senv.labset; - let mtb_expr,sub = translate_struct_entry senv.env mte in - let mtb = { typ_expr = mtb_expr; - typ_strength = None; - typ_alias = sub} in - let senv' = add_constraints - (struct_expr_constraints mtb_expr) senv in +let add_modtype l mte inl senv = + check_label l senv.labset; let mp = MPdot(senv.modinfo.modpath, l) 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 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 } (* full_add_module adds module with universes and constraints *) -let full_add_module mp mb senv = - let senv = add_constraints (module_constraints mb) senv in - let env = Modops.add_module mp mb senv.env in +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} - + (* Insertion of modules *) - -let add_module l me senv = - check_label l senv.labset; - let mb = translate_module senv.env me in + +let add_module l me inl senv = + check_label l senv.labset; let mp = MPdot(senv.modinfo.modpath, l) in - let senv' = full_add_module mp mb senv in - let is_functor,sub = Modops.update_subst senv'.env mb mp in - mp, { old = senv'.old; - env = senv'.env; - modinfo = - if is_functor then - senv'.modinfo - else - {senv'.modinfo with - alias_subst = join senv'.modinfo.alias_subst sub}; - 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 } - -let add_alias l mp senv = - check_label l senv.labset; - let mp' = MPdot(senv.modinfo.modpath, l) in - let mp1 = scrape_alias mp senv.env in - let typ_opt = - if check_bound_mp mp then - Some (strengthen senv.env - (lookup_modtype mp senv.env).typ_expr mp) - else - None + 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 in - (* we get all updated alias substitution {mp1.K\M} that comes from mp1 *) - let _,sub = Modops.update_subst senv.env (lookup_module mp1 senv.env) mp1 in - (* transformation of {mp1.K\M} to {mp.K\M}*) - let sub = update_subst sub (map_mp mp' mp1) in - (* transformation of {mp.K\M} to {mp.K\M'} where M'=M{mp1\mp'}*) - let sub = join_alias sub (map_mp mp' mp1) in - (* we add the alias substitution *) - let sub = add_mp mp' mp1 sub in - let env' = register_alias mp' mp senv.env in - mp', { old = senv.old; - env = env'; - modinfo = { senv.modinfo with - alias_subst = join - senv.modinfo.alias_subst sub}; - labset = Labset.add l senv.labset; - revstruct = (l,SFBalias (mp,typ_opt,None))::senv.revstruct; - univ = senv.univ; - engagement = senv.engagement; - imports = senv.imports; - loads = senv.loads; - local_retroknowledge = senv.local_retroknowledge } - + 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 } + (* Interactive modules *) -let start_module l senv = - check_label l senv.labset; - let msid = make_msid senv.modinfo.seed (string_of_label l) in - let mp = MPself msid in - let modinfo = { msid = msid; - modpath = mp; - seed = senv.modinfo.seed; - label = l; - variant = STRUCT []; - alias_subst = empty_subst} - in - mp, { old = senv; - env = senv.env; - modinfo = modinfo; - labset = Labset.empty; - revstruct = []; - univ = Univ.Constraint.empty; - engagement = None; - imports = senv.imports; - loads = []; - (* spiwack : not sure, but I hope it's correct *) - local_retroknowledge = [] } - -let end_module l restype senv = +let start_module l senv = + check_label l senv.labset; + let mp = MPdot(senv.modinfo.modpath, l) in + let modinfo = { modpath = mp; + label = l; + variant = STRUCT []; + resolver = empty_delta_resolver; + resolver_of_param = empty_delta_resolver} + in + mp, { old = senv; + env = senv.env; + modinfo = modinfo; + labset = Labset.empty; + revstruct = []; + univ = Univ.Constraint.empty; + engagement = None; + imports = senv.imports; + loads = []; + (* spiwack : not sure, but I hope it's correct *) + local_retroknowledge = [] } + +let end_module l restype senv = let oldsenv = senv.old in let modinfo = senv.modinfo in - let restype = Option.map (translate_struct_entry senv.env) restype in - let params,is_functor = + let mp = senv.modinfo.modpath in + let restype = + Option.map + (fun (res,inl) -> translate_module_type senv.env mp inl res) restype in + let params,is_functor = match modinfo.variant with | NONE | LIBRARY _ | SIG _ -> error_no_module_to_end () | 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; - let functorize_struct tb = + let functorize_struct tb = List.fold_left - (fun mtb (arg_id,arg_b) -> + (fun mtb (arg_id,arg_b) -> SEBfunctor(arg_id,arg_b,mtb)) tb params in - let auto_tb = - SEBstruct (modinfo.msid, List.rev senv.revstruct) + let auto_tb = + SEBstruct (List.rev senv.revstruct) in - let mod_typ,subst,cst = + let mexpr,mod_typ,mod_typ_alg,resolver,cst = match restype with - | None -> None,modinfo.alias_subst,Constraint.empty - | Some (res_tb,subst) -> - let cst = check_subtypes senv.env - {typ_expr = auto_tb; - typ_strength = None; - typ_alias = modinfo.alias_subst} - {typ_expr = res_tb; - typ_strength = None; - typ_alias = subst} in - let mtb = functorize_struct res_tb in - Some mtb,subst,cst + | None -> let mexpr = functorize_struct auto_tb in + mexpr,mexpr,None,modinfo.resolver,Constraint.empty + | Some mtb -> + let auto_mtb = { + typ_mp = senv.modinfo.modpath; + typ_expr = auto_tb; + typ_expr_alg = None; + typ_constraints = Constraint.empty; + typ_delta = empty_delta_resolver} in + let cst = check_subtypes senv.env auto_mtb + mtb in + let mod_typ = functorize_struct mtb.typ_expr in + let mexpr = functorize_struct auto_tb in + let typ_alg = + Option.map functorize_struct mtb.typ_expr_alg in + mexpr,mod_typ,typ_alg,mtb.typ_delta,cst in - let mexpr = functorize_struct auto_tb in let cst = Constraint.union cst senv.univ in - let mb = - { mod_expr = Some mexpr; + let mb = + { mod_mp = mp; + mod_expr = Some mexpr; mod_type = mod_typ; + mod_type_alg = mod_typ_alg; mod_constraints = cst; - mod_alias = subst; + mod_delta = resolver; mod_retroknowledge = senv.local_retroknowledge } in - let mp = MPdot (oldsenv.modinfo.modpath, l) in let newenv = oldsenv.env in let newenv = set_engagement_opt senv.engagement newenv in let senv'= {senv with env=newenv} in - let senv' = + let senv' = List.fold_left - (fun env (mp,mb) -> full_add_module mp mb env) + (fun env (_,mb) -> full_add_module mb env) senv' (List.rev senv'.loads) in let newenv = Environ.add_constraints cst senv'.env in - let newenv = - Modops.add_module mp mb newenv - in - let is_functor,subst = Modops.update_subst newenv mb mp in - let newmodinfo = - if is_functor then - oldsenv.modinfo - else - { oldsenv.modinfo with - alias_subst = join - oldsenv.modinfo.alias_subst - subst }; + let newenv = + Modops.add_module mb newenv in + let modinfo = match mb.mod_type with + SEBstruct _ -> + { oldsenv.modinfo with + resolver = + add_delta_resolver resolver oldsenv.modinfo.resolver} + | _ -> oldsenv.modinfo in - mp, { old = oldsenv.old; - env = newenv; - modinfo = newmodinfo; - labset = Labset.add l oldsenv.labset; - revstruct = (l,SFBmodule mb)::oldsenv.revstruct; - univ = Univ.Constraint.union senv'.univ oldsenv.univ; - (* engagement is propagated to the upper level *) - engagement = senv'.engagement; - imports = senv'.imports; - loads = senv'.loads@oldsenv.loads; - local_retroknowledge = senv'.local_retroknowledge@oldsenv.local_retroknowledge } + mp,resolver,{ old = oldsenv.old; + env = newenv; + modinfo = modinfo; + labset = Labset.add l oldsenv.labset; + revstruct = (l,SFBmodule mb)::oldsenv.revstruct; + univ = Univ.Constraint.union senv'.univ oldsenv.univ; + (* engagement is propagated to the upper level *) + engagement = senv'.engagement; + imports = senv'.imports; + loads = senv'.loads@oldsenv.loads; + local_retroknowledge = + senv'.local_retroknowledge@oldsenv.local_retroknowledge } (* Include for module and module type*) - let add_include me senv = - let struct_expr,_ = translate_struct_entry senv.env me in - let senv = add_constraints (struct_expr_constraints struct_expr) senv in - let msid,str = match (eval_struct senv.env struct_expr) with - | SEBstruct(msid,str_l) -> msid,str_l - | _ -> error ("You cannot Include a higher-order Module or Module Type.") + 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 + senv.modinfo.modpath inl me in + sign,cst,resolver + else + let mtb = + translate_module_type senv.env + senv.modinfo.modpath inl me in + mtb.typ_expr,mtb.typ_constraints,mtb.typ_delta in + let senv = add_constraints cst senv in let mp_sup = senv.modinfo.modpath in - let str1 = subst_signature_msid msid mp_sup str in - let add senv (l,elem) = + (* Include Self support *) + 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 + 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) + | str -> resolver,str,senv + 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 + 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}} + in + let add senv (l,elem) = check_label l senv.labset; match elem with | SFBconst cb -> - let con = make_con mp_sup empty_dirpath l in + 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; @@ -474,34 +489,30 @@ let end_module l restype senv = imports = senv'.imports; loads = senv'.loads ; local_retroknowledge = senv'.local_retroknowledge } - | SFBmind mib -> 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 senv' = add_constraints mib.mind_constraints senv in - let env'' = Environ.add_mind kn mib senv'.env in + let env'' = Environ.add_mind mind mib senv'.env in { old = senv'.old; env = env''; modinfo = senv'.modinfo; - labset = Labset.add l senv'.labset; + labset = Labset.add l 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 mp = MPdot(senv.modinfo.modpath, l) in - let is_functor,sub = Modops.update_subst senv.env mb mp in - let senv' = full_add_module mp mb senv in + let senv' = full_add_module mb senv in { old = senv'.old; env = senv'.env; - modinfo = - if is_functor then - senv'.modinfo - else - {senv'.modinfo with - alias_subst = join senv'.modinfo.alias_subst sub}; + modinfo = senv'.modinfo; labset = Labset.add l senv'.labset; revstruct = (l,SFBmodule mb)::senv'.revstruct; univ = senv'.univ; @@ -509,87 +520,69 @@ let end_module l restype senv = imports = senv'.imports; loads = senv'.loads; local_retroknowledge = senv'.local_retroknowledge } - | SFBalias (mp',typ_opt,cst) -> - let env' = Option.fold_right - Environ.add_constraints cst senv.env in - let mp = MPdot(senv.modinfo.modpath, l) in - let mp1 = scrape_alias mp' senv.env in - let _,sub = Modops.update_subst senv.env (lookup_module mp1 senv.env) mp1 in - let sub = update_subst sub (map_mp mp mp1) in - let sub = join_alias sub (map_mp mp mp1) in - let sub = add_mp mp mp1 sub in - let env' = register_alias mp mp' env' in - { old = senv.old; - env = env'; - modinfo = { senv.modinfo with - alias_subst = join - senv.modinfo.alias_subst sub}; - labset = Labset.add l senv.labset; - revstruct = (l,SFBalias (mp',typ_opt,cst))::senv.revstruct; - univ = senv.univ; - engagement = senv.engagement; - imports = senv.imports; - loads = senv.loads; - local_retroknowledge = senv.local_retroknowledge } | SFBmodtype mtb -> - let env' = add_modtype_constraints senv.env mtb in + let senv' = add_constraints mtb.typ_constraints senv in let mp = MPdot(senv.modinfo.modpath, l) in - let env'' = Environ.add_modtype mp mtb env' in + let env' = Environ.add_modtype mp mtb senv'.env in { old = senv.old; - env = env''; - modinfo = senv.modinfo; + 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 } + revstruct = (l,SFBmodtype mtb)::senv'.revstruct; + univ = senv'.univ; + engagement = senv'.engagement; + imports = senv'.imports; + loads = senv'.loads; + local_retroknowledge = senv'.local_retroknowledge } in - List.fold_left add senv str1 - + resolver,(List.fold_left add senv str) + (* Adding parameters to modules or module types *) -let add_module_parameter mbid mte senv = +let add_module_parameter mbid mte inl senv = if senv.revstruct <> [] or senv.loads <> [] then anomaly "Cannot add a module parameter to a non empty module"; - let mtb_expr,sub = translate_struct_entry senv.env mte in - let mtb = {typ_expr = mtb_expr; - typ_strength = None; - typ_alias = sub} in - let senv = full_add_module (MPbound mbid) (module_body_of_type mtb) senv + let mtb = translate_module_type senv.env (MPbound mbid) inl mte in + let senv = + full_add_module (module_body_of_type (MPbound mbid) mtb) senv in let new_variant = match senv.modinfo.variant with | STRUCT params -> STRUCT ((mbid,mtb) :: params) | SIG params -> SIG ((mbid,mtb) :: params) - | _ -> - anomaly "Module parameters can only be added to modules or signatures" + | _ -> + anomaly "Module parameters can only be added to modules or signatures" in - { old = senv.old; - env = senv.env; - modinfo = { senv.modinfo with variant = new_variant }; - labset = senv.labset; - revstruct = []; - univ = senv.univ; - engagement = senv.engagement; - imports = senv.imports; - loads = []; - local_retroknowledge = senv.local_retroknowledge } - + + let resolver_of_param = match mtb.typ_expr with + SEBstruct _ -> mtb.typ_delta + | _ -> empty_delta_resolver + in + mtb.typ_delta, { old = senv.old; + env = senv.env; + modinfo = { senv.modinfo with + variant = new_variant; + resolver_of_param = add_delta_resolver + resolver_of_param senv.modinfo.resolver_of_param}; + labset = senv.labset; + revstruct = []; + univ = senv.univ; + engagement = senv.engagement; + imports = senv.imports; + loads = []; + local_retroknowledge = senv.local_retroknowledge } + (* Interactive module types *) -let start_modtype l senv = - check_label l senv.labset; - let msid = make_msid senv.modinfo.seed (string_of_label l) in - let mp = MPself msid in - let modinfo = { msid = msid; - modpath = mp; - seed = senv.modinfo.seed; - label = l; - variant = SIG []; - alias_subst = empty_subst } - in +let start_modtype l senv = + check_label l senv.labset; + let mp = MPdot(senv.modinfo.modpath, l) in + let modinfo = { modpath = mp; + label = l; + variant = SIG []; + resolver = empty_delta_resolver; + resolver_of_param = empty_delta_resolver} + in mp, { old = senv; env = senv.env; modinfo = modinfo; @@ -602,64 +595,61 @@ let start_modtype l senv = (* spiwack: not 100% sure, but I think it should be like that *) local_retroknowledge = []} -let end_modtype l senv = +let end_modtype l senv = let oldsenv = senv.old in let modinfo = senv.modinfo in - let params = + let params = match modinfo.variant with | LIBRARY _ | NONE | STRUCT _ -> error_no_modtype_to_end () | 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; - let auto_tb = - SEBstruct (modinfo.msid, List.rev senv.revstruct) + let auto_tb = + SEBstruct (List.rev senv.revstruct) in - let mtb_expr = + let mtb_expr = List.fold_left - (fun mtb (arg_id,arg_b) -> + (fun mtb (arg_id,arg_b) -> SEBfunctor(arg_id,arg_b,mtb)) auto_tb params in let mp = MPdot (oldsenv.modinfo.modpath, l) in let newenv = oldsenv.env in - (* since universes constraints cannot be stored in the modtype, - they are propagated to the upper level *) let newenv = Environ.add_constraints senv.univ newenv in let newenv = set_engagement_opt senv.engagement newenv in let senv = {senv with env=newenv} in - let senv = + let senv = List.fold_left - (fun env (mp,mb) -> full_add_module mp mb env) + (fun env (mp,mb) -> full_add_module mb env) senv (List.rev senv.loads) in - let subst = senv.modinfo.alias_subst in - let mtb = {typ_expr = mtb_expr; - typ_strength = None; - typ_alias = subst} in - let newenv = + let mtb = {typ_mp = mp; + typ_expr = mtb_expr; + typ_expr_alg = None; + typ_constraints = senv.univ; + typ_delta = senv.modinfo.resolver} in + let newenv = Environ.add_modtype mp mtb senv.env - in + in mp, { old = oldsenv.old; env = newenv; - modinfo = oldsenv.modinfo; - labset = Labset.add l oldsenv.labset; - revstruct = (l,SFBmodtype mtb)::oldsenv.revstruct; - univ = Univ.Constraint.union senv.univ oldsenv.univ; - engagement = senv.engagement; - imports = senv.imports; - loads = senv.loads@oldsenv.loads; - (* spiwack : if there is a bug with retroknowledge in nested modules - it's likely to come from here *) - local_retroknowledge = - senv.local_retroknowledge@oldsenv.local_retroknowledge} - + modinfo = oldsenv.modinfo; + labset = Labset.add l oldsenv.labset; + revstruct = (l,SFBmodtype mtb)::oldsenv.revstruct; + univ = Univ.Constraint.union senv.univ oldsenv.univ; + engagement = senv.engagement; + imports = senv.imports; + loads = senv.loads@oldsenv.loads; + (* spiwack : if there is a bug with retroknowledge in nested modules + it's likely to come from here *) + local_retroknowledge = + senv.local_retroknowledge@oldsenv.local_retroknowledge} let current_modpath senv = senv.modinfo.modpath -let current_msid senv = senv.modinfo.msid - +let delta_of_senv senv = senv.modinfo.resolver,senv.modinfo.resolver_of_param (* Check that the engagement expected by a library matches the initial one *) let check_engagement env c = @@ -676,34 +666,32 @@ let set_engagement c senv = (* Libraries = Compiled modules *) -type compiled_library = +type compiled_library = dir_path * module_body * library_info list * engagement option -(* We check that only initial state Require's were performed before +(* We check that only initial state Require's were performed before [start_library] was called *) let is_empty senv = senv.revstruct = [] && - senv.modinfo.msid = initial_msid && + senv.modinfo.modpath = initial_path && senv.modinfo.variant = NONE let start_library dir senv = if not (is_empty senv) then anomaly "Safe_typing.start_library: environment should be empty"; - let dir_path,l = + let dir_path,l = match (repr_dirpath dir) with [] -> anomaly "Empty dirpath in Safe_typing.start_library" | hd::tl -> make_dirpath tl, label_of_id hd in - let msid = make_msid dir_path (string_of_label l) in - let mp = MPself msid in - let modinfo = { msid = msid; - modpath = mp; - seed = dir; - label = l; - variant = LIBRARY dir; - alias_subst = empty_subst } + let mp = MPfile dir in + let modinfo = {modpath = mp; + label = l; + variant = LIBRARY dir; + resolver = empty_delta_resolver; + resolver_of_param = empty_delta_resolver} in mp, { old = senv; env = senv.env; @@ -716,13 +704,21 @@ let start_library dir senv = loads = []; local_retroknowledge = [] } +let pack_module senv = + {mod_mp=senv.modinfo.modpath; + mod_expr=None; + mod_type= SEBstruct (List.rev senv.revstruct); + mod_type_alg=None; + mod_constraints=Constraint.empty; + mod_delta=senv.modinfo.resolver; + mod_retroknowledge=[]; + } - -let export senv dir = +let export senv dir = let modinfo = senv.modinfo in begin match modinfo.variant with - | LIBRARY dp -> + | LIBRARY dp -> if dir <> dp then anomaly "We are not exporting the right library!" | _ -> @@ -730,14 +726,18 @@ let export senv dir = end; (*if senv.modinfo.params <> [] || senv.modinfo.restype <> None then (* error_export_simple *) (); *) - let mb = - { mod_expr = Some (SEBstruct (modinfo.msid, List.rev senv.revstruct)); - mod_type = None; + let str = SEBstruct (List.rev senv.revstruct) in + let mp = senv.modinfo.modpath in + let mb = + { mod_mp = mp; + mod_expr = Some str; + mod_type = str; + mod_type_alg = None; mod_constraints = senv.univ; - mod_alias = senv.modinfo.alias_subst; + mod_delta = senv.modinfo.resolver; mod_retroknowledge = senv.local_retroknowledge} in - modinfo.msid, (dir,mb,senv.imports,engagement senv.env) + mp, (dir,mb,senv.imports,engagement senv.env) let check_imports senv needed = @@ -748,7 +748,7 @@ let check_imports senv needed = if stamp <> actual_stamp then error ("Inconsistent assumptions over module "^(string_of_dirpath id)^".") - with Not_found -> + with Not_found -> error ("Reference to unknown module "^(string_of_dirpath id)^".") in List.iter check needed @@ -767,16 +767,20 @@ environment, and store for the future (instead of just its type) loaded by side-effect once and for all (like it is done in OCaml). Would this be correct with respect to undo's and stuff ? *) - -let import (dp,mb,depends,engmt) digest senv = + +let import (dp,mb,depends,engmt) digest senv = check_imports senv depends; check_engagement senv.env engmt; let mp = MPfile dp in let env = senv.env in let env = Environ.add_constraints mb.mod_constraints env in - let env = Modops.add_module mp mb env in - mp, { senv with - env = env; + let env = Modops.add_module mb env in + mp, { senv with + env = env; + modinfo = + {senv.modinfo with + resolver = + add_delta_resolver mb.mod_delta senv.modinfo.resolver}; imports = (dp,digest)::senv.imports; loads = (mp,mb)::senv.loads } @@ -784,35 +788,35 @@ let import (dp,mb,depends,engmt) digest senv = (* Remove the body of opaque constants in modules *) let rec lighten_module mb = { mb with - mod_expr = Option.map lighten_modexpr mb.mod_expr; - mod_type = Option.map lighten_modexpr mb.mod_type; + mod_expr = None; + mod_type = lighten_modexpr mb.mod_type; } - -and lighten_struct struc = + +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 _ | SFBalias _) as x -> x + | (SFBconst _ | SFBmind _ ) as x -> x | SFBmodule m -> SFBmodule (lighten_module m) - | SFBmodtype m -> SFBmodtype - ({m with + | 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, - ({mty with + SEBfunctor (mbid, + ({mty with typ_expr = lighten_modexpr mty.typ_expr}), lighten_modexpr mexpr) | SEBident mp as x -> x - | SEBstruct (msid, struc) -> - SEBstruct (msid, lighten_struct struc) + | 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) - + SEBwith (lighten_modexpr seb,wdcl) + let lighten_library (dp,mb,depends,s) = (dp,lighten_module mb,depends,s) @@ -822,8 +826,5 @@ let j_val j = j.uj_val let j_type j = j.uj_type let safe_infer senv = infer (env_of_senv senv) - -let typing senv = Typeops.typing (env_of_senv senv) - - +let typing senv = Typeops.typing (env_of_senv senv) diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index 6d656f8b..c378d8cc 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -6,13 +6,14 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: safe_typing.mli 10664 2008-03-14 11:27:37Z soubiran $ i*) +(*i $Id$ 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 @@ -20,7 +21,7 @@ open Entries typed before being added. We also add [open_structure] and [close_section], [close_module] to - provide functionnality for sections and interactive modules + provide functionnality for sections and interactive modules *) type safe_environment @@ -39,35 +40,31 @@ val push_named_def : Univ.constraints * safe_environment (* Adding global axioms or definitions *) -type global_declaration = +type global_declaration = | ConstantEntry of constant_entry | GlobalRecipe of Cooking.recipe -val add_constant : - dir_path -> label -> global_declaration -> safe_environment -> +val add_constant : + dir_path -> label -> global_declaration -> safe_environment -> constant * safe_environment (* Adding an inductive type *) -val add_mind : +val add_mind : dir_path -> label -> mutual_inductive_entry -> safe_environment -> mutual_inductive * safe_environment (* Adding a module *) val add_module : - label -> module_entry -> safe_environment - -> module_path * safe_environment + label -> module_entry -> bool -> safe_environment + -> module_path * delta_resolver * safe_environment -(* Adding a module alias*) -val add_alias : - label -> module_path -> safe_environment - -> module_path * safe_environment (* Adding a module type *) val add_modtype : - label -> module_struct_entry -> safe_environment + label -> module_struct_entry -> bool -> safe_environment -> module_path * safe_environment (* Adding universe constraints *) -val add_constraints : +val add_constraints : Univ.constraints -> safe_environment -> safe_environment (* Settin the strongly constructive or classical logical engagement *) @@ -75,14 +72,15 @@ val set_engagement : engagement -> safe_environment -> safe_environment (*s Interactive module functions *) -val start_module : +val start_module : label -> safe_environment -> module_path * safe_environment + val end_module : - label -> module_struct_entry option - -> safe_environment -> module_path * safe_environment + label -> (module_struct_entry * bool) option + -> safe_environment -> module_path * delta_resolver * safe_environment val add_module_parameter : - mod_bound_id -> module_struct_entry -> safe_environment -> safe_environment + mod_bound_id -> module_struct_entry -> bool -> safe_environment -> delta_resolver * safe_environment val start_modtype : label -> safe_environment -> module_path * safe_environment @@ -91,24 +89,25 @@ val end_modtype : label -> safe_environment -> module_path * safe_environment val add_include : - module_struct_entry -> safe_environment -> safe_environment + module_struct_entry -> bool -> bool -> safe_environment -> + delta_resolver * safe_environment +val pack_module : safe_environment -> module_body val current_modpath : safe_environment -> module_path -val current_msid : safe_environment -> mod_self_id - - +val delta_of_senv : safe_environment -> delta_resolver*delta_resolver + (* Loading and saving compilation units *) (* exporting and importing modules *) type compiled_library -val start_library : dir_path -> safe_environment +val start_library : dir_path -> safe_environment -> module_path * safe_environment -val export : safe_environment -> dir_path - -> mod_self_id * compiled_library +val export : safe_environment -> dir_path + -> module_path * compiled_library -val import : compiled_library -> Digest.t -> safe_environment +val import : compiled_library -> Digest.t -> safe_environment -> module_path * safe_environment (* Remove the body of opaque constants *) diff --git a/kernel/sign.ml b/kernel/sign.ml index 8fa59809..d30d7086 100644 --- a/kernel/sign.ml +++ b/kernel/sign.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: sign.ml 10451 2008-01-18 17:20:28Z barras $ *) +(* $Id$ *) open Names open Util @@ -43,31 +43,6 @@ let fold_named_context_reverse f ~init l = List.fold_left f init l (*s Signatures of ordered section variables *) type section_context = named_context -(*s Signatures of ordered optionally named variables, intended to be - accessed by de Bruijn indices (to represent bound variables) *) - -type rel_declaration = name * constr option * types -type rel_context = rel_declaration list - -let empty_rel_context = [] - -let add_rel_decl d ctxt = d::ctxt - -let rec lookup_rel n sign = - match n, sign with - | 1, decl :: _ -> decl - | n, _ :: sign -> lookup_rel (n-1) sign - | _, [] -> raise Not_found - -let rel_context_length = List.length - -let rel_context_nhyps hyps = - let rec nhyps acc = function - | [] -> acc - | (_,None,_)::hyps -> nhyps (1+acc) hyps - | (_,Some _,_)::hyps -> nhyps acc hyps in - nhyps 0 hyps - let fold_rel_context f l ~init:x = List.fold_right f l x let fold_rel_context_reverse f ~init:x l = List.fold_left f x l @@ -102,98 +77,3 @@ let push_named_to_rel_context hyps ctxt = (n+1), (map_rel_declaration (substn_vars n s) d)::ctxt | [] -> 1, hyps in snd (subst ctxt) - - -(*********************************) -(* Term constructors *) -(*********************************) - -let it_mkProd_or_LetIn = List.fold_left (fun c d -> mkProd_or_LetIn d c) -let it_mkLambda_or_LetIn = List.fold_left (fun c d -> mkLambda_or_LetIn d c) - -(*********************************) -(* Term destructors *) -(*********************************) - -type arity = rel_context * sorts - -(* Decompose an arity (i.e. a product of the form (x1:T1)..(xn:Tn)s - with s a sort) into the pair ([(xn,Tn);...;(x1,T1)],s) *) - -let destArity = - let rec prodec_rec l c = - match kind_of_term c with - | Prod (x,t,c) -> prodec_rec ((x,None,t)::l) c - | LetIn (x,b,t,c) -> prodec_rec ((x,Some b,t)::l) c - | Cast (c,_,_) -> prodec_rec l c - | Sort s -> l,s - | _ -> anomaly "destArity: not an arity" - in - prodec_rec [] - -let mkArity (sign,s) = it_mkProd_or_LetIn (mkSort s) sign - -let rec isArity c = - match kind_of_term c with - | Prod (_,_,c) -> isArity c - | LetIn (_,b,_,c) -> isArity (subst1 b c) - | Cast (c,_,_) -> isArity c - | Sort _ -> true - | _ -> false - -(* Transforms a product term (x1:T1)..(xn:Tn)T into the pair - ([(xn,Tn);...;(x1,T1)],T), where T is not a product *) -let decompose_prod_assum = - let rec prodec_rec l c = - match kind_of_term c with - | Prod (x,t,c) -> prodec_rec (add_rel_decl (x,None,t) l) c - | LetIn (x,b,t,c) -> prodec_rec (add_rel_decl (x,Some b,t) l) c - | Cast (c,_,_) -> prodec_rec l c - | _ -> l,c - in - prodec_rec empty_rel_context - -(* Transforms a lambda term [x1:T1]..[xn:Tn]T into the pair - ([(xn,Tn);...;(x1,T1)],T), where T is not a lambda *) -let decompose_lam_assum = - let rec lamdec_rec l c = - match kind_of_term c with - | Lambda (x,t,c) -> lamdec_rec (add_rel_decl (x,None,t) l) c - | LetIn (x,b,t,c) -> lamdec_rec (add_rel_decl (x,Some b,t) l) c - | Cast (c,_,_) -> lamdec_rec l c - | _ -> l,c - in - lamdec_rec empty_rel_context - -(* Given a positive integer n, transforms a product term (x1:T1)..(xn:Tn)T - into the pair ([(xn,Tn);...;(x1,T1)],T) *) -let decompose_prod_n_assum n = - if n < 0 then - error "decompose_prod_n_assum: integer parameter must be positive"; - let rec prodec_rec l n c = - if n=0 then l,c - else match kind_of_term c with - | Prod (x,t,c) -> prodec_rec (add_rel_decl (x,None,t) l) (n-1) c - | LetIn (x,b,t,c) -> prodec_rec (add_rel_decl (x,Some b,t) l) (n-1) c - | Cast (c,_,_) -> prodec_rec l n c - | c -> error "decompose_prod_n_assum: not enough assumptions" - in - prodec_rec empty_rel_context n - -(* Given a positive integer n, transforms a lambda term [x1:T1]..[xn:Tn]T - into the pair ([(xn,Tn);...;(x1,T1)],T) - Lets in between are not expanded but turn into local definitions, - but n is the actual number of destructurated lambdas. *) -let decompose_lam_n_assum n = - if n < 0 then - error "decompose_lam_n_assum: integer parameter must be positive"; - let rec lamdec_rec l n c = - if n=0 then l,c - else match kind_of_term c with - | Lambda (x,t,c) -> lamdec_rec (add_rel_decl (x,None,t) l) (n-1) c - | LetIn (x,b,t,c) -> lamdec_rec (add_rel_decl (x,Some b,t) l) n c - | Cast (c,_,_) -> lamdec_rec l n c - | c -> error "decompose_lam_n_assum: not enough abstractions" - in - lamdec_rec empty_rel_context n - diff --git a/kernel/sign.mli b/kernel/sign.mli index 88e9dbf0..b3e7ace5 100644 --- a/kernel/sign.mli +++ b/kernel/sign.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: sign.mli 9103 2006-09-01 11:02:52Z herbelin $ i*) +(*i $Id$ i*) (*i*) open Names @@ -40,16 +40,6 @@ val instance_from_named_context : named_context -> constr array (*s Signatures of ordered optionally named variables, intended to be accessed 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 -val add_rel_decl : rel_declaration -> rel_context -> rel_context - -val lookup_rel : int -> rel_context -> rel_declaration -val rel_context_length : rel_context -> int -val rel_context_nhyps : rel_context -> int - val push_named_to_rel_context : named_context -> rel_context -> rel_context (*s Recurrence on [rel_context]: older declarations processed first *) @@ -70,35 +60,3 @@ val iter_rel_context : (constr -> unit) -> rel_context -> unit (*s Map function of [named_context] *) val iter_named_context : (constr -> unit) -> named_context -> unit - -(*s Term constructors *) - -val it_mkLambda_or_LetIn : constr -> rel_context -> constr -val it_mkProd_or_LetIn : types -> rel_context -> types - -(*s Term destructors *) - -(* Destructs a term of the form $(x_1:T_1)..(x_n:T_n)s$ into the pair *) -type arity = rel_context * sorts -val destArity : types -> arity -val mkArity : arity -> types -val isArity : types -> bool - -(* Transforms a product term $(x_1:T_1)..(x_n:T_n)T$ including letins - into the pair $([(x_n,T_n);...;(x_1,T_1)],T)$, where $T$ is not a - product nor a let. *) -val decompose_prod_assum : types -> rel_context * types - -(* Transforms a lambda term $[x_1:T_1]..[x_n:T_n]T$ including letins - into the pair $([(x_n,T_n);...;(x_1,T_1)],T)$, where $T$ is not a - lambda nor a let. *) -val decompose_lam_assum : constr -> rel_context * 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)$. *) -val decompose_prod_n_assum : int -> types -> rel_context * types - -(* 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_assum : int -> constr -> rel_context * constr diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml index 98ee1dbb..e07af3ba 100644 --- a/kernel/subtyping.ml +++ b/kernel/subtyping.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: subtyping.ml 11453 2008-10-15 14:42:34Z soubiran $ i*) +(*i $Id$ i*) (*i*) open Util @@ -27,22 +27,21 @@ open Entries (* 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 *) -type namedobject = +type namedobject = | Constant of constant_body | IndType of inductive * mutual_inductive_body | IndConstr of constructor * mutual_inductive_body | Module of module_body | Modtype of module_type_body - | Alias of module_path * struct_expr_body option (* adds above information about one mutual inductive: all types and constructors *) -let add_nameobjects_of_mib ln mib map = +let add_nameobjects_of_mib ln mib map = let add_nameobjects_of_one j oib map = let ip = (ln,j) in - let map = - array_fold_right_i + let map = + array_fold_right_i (fun i id map -> Labmap.add (label_of_id id) (IndConstr((ip,i+1), mib)) map) oib.mind_consnames @@ -55,16 +54,15 @@ let add_nameobjects_of_mib ln mib map = (* creates namedobject map for the whole signature *) -let make_label_map mp list = - let add_one (l,e) map = +let make_label_map mp list = + let add_one (l,e) map = let add_map obj = Labmap.add l obj map in match e with | SFBconst cb -> add_map (Constant cb) | SFBmind mib -> - add_nameobjects_of_mib (make_kn mp empty_dirpath l) mib map + add_nameobjects_of_mib (make_mind mp empty_dirpath l) mib map | SFBmodule mb -> add_map (Module mb) | SFBmodtype mtb -> add_map (Modtype mtb) - | SFBalias (mp,typ_opt,cst) -> add_map (Alias (mp,typ_opt)) in List.fold_right add_one list Labmap.empty @@ -75,20 +73,23 @@ let check_conv_error error cst f env a1 a2 = NotConvertible -> error () (* for now we do not allow reorderings *) -let check_inductive cst env msid1 l info1 mib2 spec2 = - let kn = make_kn (MPself msid1) empty_dirpath l in + +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 mib1 = + let mib1 = match info1 with - | IndType ((_,0), mib) -> mib + | IndType ((_,0), mib) -> subst_mind subst1 mib | _ -> error () in + let mib2 = subst_mind subst2 mib2 in let check_inductive_type cst 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 - of the types of the constructors. + of the types of the constructors. By monotonicity of the infered l.u.b. wrt subtyping (i.e. if X:U |- T(X):s and |- M:U' and U'<=U then infer_type(T(M))<=s), each @@ -115,8 +116,7 @@ let check_inductive cst env msid1 l info1 mib2 spec2 = | Type _, Type _ -> (* shortcut here *) prop_sort, prop_sort | (Prop _, Type _) | (Type _,Prop _) -> error () | _ -> (s1, s2) in - check_conv cst conv_leq env - (Sign.mkArity (ctx1,s1)) (Sign.mkArity (ctx2,s2)) + check_conv cst conv_leq env (mkArity (ctx1,s1)) (mkArity (ctx2,s2)) in let check_packet cst p1 p2 = @@ -139,17 +139,17 @@ let check_inductive cst env msid1 l info1 mib2 spec2 = cst in let check_cons_types i cst p1 p2 = - array_fold_left2 + array_fold_left2 (fun cst t1 t2 -> check_conv cst conv env t1 t2) cst - (arities_of_specif kn (mib1,p1)) - (arities_of_specif kn (mib2,p2)) + (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); assert (mib1.mind_hyps=[] && mib2.mind_hyps=[]); - assert (Array.length mib1.mind_packets >= 1 + assert (Array.length mib1.mind_packets >= 1 && Array.length mib2.mind_packets >= 1); (* Check that the expected numbers of uniform parameters are the same *) @@ -159,46 +159,43 @@ let check_inductive cst env msid1 l info1 mib2 spec2 = (* the inductive types and constructors types have to be convertible *) check (fun mib -> mib.mind_nparams); - begin - match mib2.mind_equiv with - | None -> () - | Some kn2' -> - let kn2 = scrape_mind env kn2' in - let kn1 = match mib1.mind_equiv with - None -> kn - | Some kn1' -> scrape_mind env kn1' - in - if kn1 <> kn2 then error () + begin + match mind_of_delta reso2 kn2 with + | kn2' when kn2=kn2' -> () + | kn2' -> + if not (eq_mind (mind_of_delta reso1 kn1) kn2') then + error () end; (* we check that records and their field names are preserved. *) check (fun mib -> mib.mind_record); - if mib1.mind_record then begin - let rec names_prod_letin t = match kind_of_term t with + 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) | LetIn(n,_,_,t) -> n::(names_prod_letin t) | Cast(t,_,_) -> names_prod_letin t | _ -> [] - in + in assert (Array.length mib1.mind_packets = 1); 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); + 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)); end; (* we first check simple things *) - let cst = + let cst = array_fold_left2 check_packet cst mib1.mind_packets mib2.mind_packets in (* and constructor types in the end *) - let cst = + let cst = array_fold_left2_i check_cons_types cst mib1.mind_packets mib2.mind_packets in cst + -let check_constant cst env msid1 l info1 cb2 spec2 = +let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 = let error () = error_not_match l spec2 in let check_conv cst f = check_conv_error error cst f in - let check_type cst env t1 t2 = + let check_type cst env t1 t2 = (* If the type of a constant is generated, it may mention non-variable algebraic universes that the general conversion @@ -209,9 +206,9 @@ let check_constant cst env msid1 l info1 cb2 spec2 = Gamma |- A |> T, Gamma |- A' |> T' and Gamma |- A=A' then T <= T'). Hence they don't have to be checked again *) - let t1,t2 = - if Sign.isArity t2 then - let (ctx2,s2) = Sign.destArity t2 in + let t1,t2 = + if isArity t2 then + let (ctx2,s2) = destArity t2 in match s2 with | Type v when not (is_univ_variable v) -> (* The type in the interface is inferred and is made of algebraic @@ -222,13 +219,13 @@ let check_constant cst env msid1 l info1 cb2 spec2 = | Type u when not (is_univ_variable u) -> (* Both types are inferred, no need to recheck them. We cheat and collapse the types to Prop *) - Sign.mkArity (ctx1,prop_sort), Sign.mkArity (ctx2,prop_sort) + mkArity (ctx1,prop_sort), mkArity (ctx2,prop_sort) | Prop _ -> (* The type in the interface is inferred, it may be the case that the type in the implementation is smaller because the body is more reduced. We safely collapse the upper type to Prop *) - Sign.mkArity (ctx1,prop_sort), Sign.mkArity (ctx2,prop_sort) + mkArity (ctx1,prop_sort), mkArity (ctx2,prop_sort) | Type _ -> (* The type in the interface is inferred and the type in the implementation is not inferred or is inferred but from a @@ -246,32 +243,40 @@ let check_constant cst env msid1 l info1 cb2 spec2 = in match info1 with - | Constant cb1 -> - assert (cb1.const_hyps=[] && cb2.const_hyps=[]) ; - (*Start by checking types*) + | 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 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 (MPself msid1) empty_dirpath l 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 -> + | Some lc1 -> let c = Declarations.force lc1 in begin - match (kind_of_term c) with - Const n -> - let cb = lookup_constant n env in + 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 -> + | true, Some lc1 -> Declarations.force lc1 | _,_ -> c) - | _ -> c + | _ ,_-> c end | None -> mkConst con in @@ -311,120 +316,103 @@ let check_constant cst env msid1 l info1 cb2 spec2 = let ty2 = Typeops.type_of_constant_type env cb2.const_type in check_conv cst conv env ty1 ty2 | _ -> error () - -let rec check_modules cst env msid1 l msb1 msb2 alias = - let mp = (MPdot(MPself msid1,l)) in - let mty1 = module_type_of_module (Some mp) msb1 in - let alias1,struct_expr = match eval_struct env mty1.typ_expr with - | SEBstruct (msid,sign) as str -> - update_subst alias (map_msid msid mp),str - | _ as str -> empty_subst,str in - let mty1 = {mty1 with - typ_expr = struct_expr; - typ_alias = join alias1 mty1.typ_alias } in - let mty2 = module_type_of_module None msb2 in - let cst = check_modtypes cst env mty1 mty2 false in + +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 cst = check_modtypes cst env mty1 mty2 subst1 subst2 false in cst - -and check_signatures cst env (msid1,sig1) alias (msid2,sig2') = - let mp1 = MPself msid1 in - let env = add_signature mp1 sig1 env in - let sig1 = subst_structure alias sig1 in - let alias1 = update_subst alias (map_msid msid2 mp1) in - let sig2 = subst_structure alias1 sig2' in - let sig2 = subst_signature_msid msid2 mp1 sig2 in +and check_signatures cst env mp1 sig1 mp2 sig2 subst1 subst2 reso1 reso2= let map1 = make_label_map mp1 sig1 in - let check_one_body cst (l,spec2) = - let info1 = - try - Labmap.find l map1 - with - Not_found -> error_no_such_label_sub l - (string_of_msid msid1) (string_of_msid msid2) + let check_one_body cst (l,spec2) = + let info1 = + try + Labmap.find l map1 + with + Not_found -> error_no_such_label_sub l + (string_of_mp mp1) in match spec2 with | SFBconst cb2 -> - check_constant cst env msid1 l info1 cb2 spec2 - | SFBmind mib2 -> - check_inductive cst env msid1 l info1 mib2 spec2 - | SFBmodule msb2 -> + check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 + | SFBmind mib2 -> + check_inductive cst env + mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2 + | SFBmodule msb2 -> begin match info1 with - | Module msb -> check_modules cst env msid1 l msb msb2 alias - | Alias (mp,typ_opt) ->let msb = - {mod_expr = Some (SEBident mp); - mod_type = typ_opt; - mod_constraints = Constraint.empty; - mod_alias = (lookup_modtype mp env).typ_alias; - mod_retroknowledge = []} in - check_modules cst env msid1 l msb msb2 alias - | _ -> error_not_match l spec2 - end - | SFBalias (mp,typ_opt,_) -> - begin - match info1 with - | Alias (mp1,_) -> check_modpath_equiv env mp mp1; cst - | Module msb -> - let msb1 = - {mod_expr = Some (SEBident mp); - mod_type = typ_opt; - mod_constraints = Constraint.empty; - mod_alias = (lookup_modtype mp env).typ_alias; - mod_retroknowledge = []} in - check_modules cst env msid1 l msb msb1 alias + | Module msb -> check_modules cst env msb msb2 + subst1 subst2 | _ -> error_not_match l spec2 end | SFBmodtype mtb2 -> - let mtb1 = + let mtb1 = match info1 with | Modtype mtb -> mtb | _ -> error_not_match l spec2 in - check_modtypes cst env mtb1 mtb2 true + let env = add_module (module_body_of_type mtb2.typ_mp mtb2) + (add_module (module_body_of_type mtb1.typ_mp mtb1) env) in + check_modtypes cst env mtb1 mtb2 subst1 subst2 true in List.fold_left check_one_body cst sig2 - -and check_modtypes cst env mtb1 mtb2 equiv = - if mtb1==mtb2 then cst else (* just in case :) *) - let mtb1',mtb2'= - (match mtb1.typ_strength with - None -> eval_struct env mtb1.typ_expr, - eval_struct env mtb2.typ_expr - | Some mp -> strengthen env mtb1.typ_expr mp, - eval_struct env mtb2.typ_expr) in - let rec check_structure cst env str1 str2 equiv = - match str1, str2 with - | SEBstruct (msid1,list1), - SEBstruct (msid2,list2) -> - let cst = check_signatures cst env - (msid1,list1) mtb1.typ_alias (msid2,list2) in - if equiv then - check_signatures cst env - (msid2,list2) mtb2.typ_alias (msid1,list1) - else - cst - | SEBfunctor (arg_id1,arg_t1,body_t1), +and check_modtypes cst env mtb1 mtb2 subst1 subst2 equiv = + if mtb1==mtb2 then cst else + let mtb1',mtb2'=mtb1.typ_expr,mtb2.typ_expr in + let rec check_structure cst env str1 str2 equiv subst1 subst2 = + match str1,str2 with + | SEBstruct (list1), + SEBstruct (list2) -> + if equiv then + let subst2 = + add_mp mtb2.typ_mp mtb1.typ_mp mtb1.typ_delta subst2 in + Univ.Constraint.union + (check_signatures cst env + mtb1.typ_mp list1 mtb2.typ_mp list2 subst1 subst2 + mtb1.typ_delta mtb2.typ_delta) + (check_signatures cst env + mtb2.typ_mp list2 mtb1.typ_mp list1 subst2 subst1 + mtb2.typ_delta mtb1.typ_delta) + else + check_signatures cst env + mtb1.typ_mp list1 mtb2.typ_mp list2 subst1 subst2 + mtb1.typ_delta mtb2.typ_delta + | SEBfunctor (arg_id1,arg_t1,body_t1), SEBfunctor (arg_id2,arg_t2,body_t2) -> - let cst = check_modtypes cst env arg_t2 arg_t1 equiv in + let subst1 = + (join (map_mbid arg_id1 (MPbound arg_id2) arg_t2.typ_delta) subst1) in + let cst = check_modtypes cst env + arg_t2 arg_t1 subst2 subst1 + equiv in (* contravariant *) - let env = - add_module (MPbound arg_id2) (module_body_of_type arg_t2) env + let env = add_module + (module_body_of_type (MPbound arg_id2) arg_t2) env in - let body_t1' = - (* since we are just checking well-typedness we do not need - to expand any constant. Hence the identity resolver. *) - subst_struct_expr - (map_mbid arg_id1 (MPbound arg_id2) None) - body_t1 + let env = match body_t1 with + SEBstruct str -> + add_module {mod_mp = mtb1.typ_mp; + mod_expr = None; + mod_type = subst_struct_expr subst1 body_t1; + mod_type_alg= None; + mod_constraints=mtb1.typ_constraints; + mod_retroknowledge = []; + mod_delta = mtb1.typ_delta} env + | _ -> env in - check_structure cst env (eval_struct env body_t1') - (eval_struct env body_t2) equiv + check_structure cst env body_t1 body_t2 equiv + subst1 + subst2 | _ , _ -> error_incompatible_modtypes mtb1 mtb2 - in - if mtb1'== mtb2' then cst - else check_structure cst env mtb1' mtb2' equiv - -let check_subtypes env sup super = - check_modtypes Constraint.empty env sup super false + in + if mtb1'== mtb2' then cst + else check_structure cst env mtb1' mtb2' equiv subst1 subst2 + +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 + (map_mp super.typ_mp sup.typ_mp sup.typ_delta) false + diff --git a/kernel/subtyping.mli b/kernel/subtyping.mli index 0445666d..c0b1ee5d 100644 --- a/kernel/subtyping.mli +++ b/kernel/subtyping.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: subtyping.mli 10664 2008-03-14 11:27:37Z soubiran $ i*) +(*i $Id$ i*) (*i*) open Univ diff --git a/kernel/term.ml b/kernel/term.ml index 1f3d2635..68565659 100644 --- a/kernel/term.ml +++ b/kernel/term.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: term.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id$ *) (* This module instantiates the structure of generic deBruijn terms to Coq *) @@ -26,7 +26,7 @@ type metavariable = int (* This defines Cases annotations *) type case_style = LetStyle | IfStyle | LetPatternStyle | MatchStyle | RegularStyle type case_printing = - { ind_nargs : int; (* number of real args of the inductive type *) + { ind_nargs : int; (* length of the arity of the inductive type *) style : case_style } type case_info = { ci_ind : inductive; @@ -42,7 +42,7 @@ type contents = Pos | Null type sorts = | Prop of contents (* proposition types *) | Type of universe - + let prop_sort = Prop Null let set_sort = Prop Pos let type1_sort = Type type1_univ @@ -58,7 +58,7 @@ let family_of_sort = function (* Constructions as implemented *) (********************************************************************) -type cast_kind = VMcast | DEFAULTcast +type cast_kind = VMcast | DEFAULTcast (* [constr array] is an instance matching definitional [named_context] in the same order (i.e. last argument first) *) @@ -93,7 +93,7 @@ type ('constr, 'types) kind_of_term = (* Experimental *) type ('constr, 'types) kind_of_type = | SortType of sorts - | CastType of 'types * 'types + | CastType of 'types * 'types | ProdType of name * 'types * 'types | LetInType of name * 'constr * 'types * 'types | AtomicType of 'constr * 'constr array @@ -118,7 +118,7 @@ type fixpoint = (int array * int) * rec_declaration type cofixpoint = int * rec_declaration (***************************) -(* hash-consing functions *) +(* hash-consing functions *) (***************************) let comp_term t1 t2 = @@ -184,7 +184,7 @@ module Hconstr = type t = constr type u = (constr -> constr) * ((sorts -> sorts) * (constant -> constant) * - (kernel_name -> kernel_name) * (name -> name) * + (mutual_inductive -> mutual_inductive) * (name -> name) * (identifier -> identifier)) let hash_sub = hash_term let equal = comp_term @@ -211,7 +211,7 @@ let mkVar id = Var id let mkSort 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) +(* (that means t2 is declared as the type of t1) [s] is the strategy to use when *) let mkCast (t1,k2,t2) = match t1 with @@ -230,14 +230,14 @@ let mkLetIn (x,c1,t,c2) = LetIn (x,c1,t,c2) (* If lt = [t1; ...; tn], constructs the application (t1 ... tn) *) (* We ensure applicative terms have at least one argument and the function is not itself an applicative term *) -let mkApp (f, a) = +let mkApp (f, a) = if Array.length a = 0 then f else match f with | App (g, cl) -> App (g, Array.append cl a) | _ -> App (f, a) -(* Constructs a constant *) +(* Constructs a constant *) (* The array of terms correspond to the variables introduced in the section *) let mkConst c = Const c @@ -248,7 +248,7 @@ let mkEvar e = Evar e (* 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 +(* 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 c = Construct c @@ -261,6 +261,7 @@ let mkFix fix = Fix fix let mkCoFix cofix = CoFix cofix let kind_of_term c = c +let kind_of_term2 c = c (************************************************************************) (* kind_of_term = constructions as seen by the user *) @@ -284,7 +285,7 @@ type hnftype = (* Non primitive term destructors *) (**********************************************************************) -(* Destructor operations : partial functions +(* Destructor operations : partial functions Raise invalid_arg "dest*" if the const has not the expected form *) (* Destructs a DeBrujin index *) @@ -348,8 +349,12 @@ 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 +let isEvar_or_Meta c = match kind_of_term c with + | Evar _ | Meta _ -> true + | _ -> false + (* Destructs a casted term *) -let destCast c = match kind_of_term c with +let destCast c = match kind_of_term c with | Cast (t1,k,t2) -> (t1,k,t2) | _ -> invalid_arg "destCast" @@ -366,22 +371,22 @@ let isVar c = match kind_of_term c with Var _ -> true | _ -> false let isInd c = match kind_of_term c with Ind _ -> true | _ -> false (* Destructs the product (x:t1)t2 *) -let destProd c = match kind_of_term c with - | Prod (x,t1,t2) -> (x,t1,t2) +let destProd c = match kind_of_term c with + | Prod (x,t1,t2) -> (x,t1,t2) | _ -> invalid_arg "destProd" let isProd c = match kind_of_term c with | Prod _ -> true | _ -> false (* Destructs the abstraction [x:t1]t2 *) -let destLambda c = match kind_of_term c with - | Lambda (x,t1,t2) -> (x,t1,t2) +let destLambda c = match kind_of_term c with + | Lambda (x,t1,t2) -> (x,t1,t2) | _ -> invalid_arg "destLambda" 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) +let destLetIn c = match kind_of_term c with + | LetIn (x,b,t1,t2) -> (x,b,t1,t2) | _ -> invalid_arg "destProd" let isLetIn c = match kind_of_term c with LetIn _ -> true | _ -> false @@ -430,13 +435,13 @@ let destCase c = match kind_of_term c with let isCase c = match kind_of_term c with Case _ -> true | _ -> false -let destFix c = match kind_of_term c with +let destFix c = match kind_of_term c with | Fix fix -> fix | _ -> invalid_arg "destFix" let isFix c = match kind_of_term c with Fix _ -> true | _ -> false -let destCoFix c = match kind_of_term c with +let destCoFix c = match kind_of_term c with | CoFix cofix -> cofix | _ -> invalid_arg "destCoFix" @@ -466,7 +471,7 @@ let rec under_casts f c = match kind_of_term c with (* flattens application lists throwing casts in-between *) let rec collapse_appl c = match kind_of_term c with - | App (f,cl) -> + | App (f,cl) -> let rec collapse_rec f cl2 = match kind_of_term (strip_outer_cast f) with | App (g,cl1) -> collapse_rec g (Array.append cl1 cl2) @@ -482,12 +487,12 @@ let decompose_app c = (* strips head casts and flattens head applications *) let rec strip_head_cast c = match kind_of_term c with - | App (f,cl) -> + | 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 + in collapse_rec f cl | Cast (c,_,_) -> strip_head_cast c | _ -> c @@ -550,7 +555,7 @@ let iter_constr_with_binders g f n c = match kind_of_term c with | App (c,l) -> f n c; Array.iter (f n) l | Evar (_,l) -> Array.iter (f n) l | Case (_,p,c,bl) -> f n p; f n c; Array.iter (f n) bl - | Fix (_,(_,tl,bl)) -> + | Fix (_,(_,tl,bl)) -> Array.iter (f n) tl; Array.iter (f (iterate g (Array.length tl) n)) bl | CoFix (_,(_,tl,bl)) -> @@ -604,6 +609,7 @@ let map_constr_with_binders g f l c = match kind_of_term c with application associativity, binders name and Cases annotations are not taken into account *) + let compare_constr f t1 t2 = match kind_of_term t1, kind_of_term t2 with | Rel n1, Rel n2 -> n1 = n2 @@ -619,15 +625,15 @@ let compare_constr f t1 t2 = 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 (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 | Evar (e1,l1), Evar (e2,l2) -> e1 = e2 & array_for_all2 f l1 l2 - | Const c1, Const c2 -> c1 = c2 - | Ind c1, Ind c2 -> c1 = c2 - | Construct c1, Construct c2 -> c1 = c2 + | Const c1, Const c2 -> eq_constant c1 c2 + | Ind c1, Ind c2 -> eq_ind c1 c2 + | Construct c1, Construct c2 -> eq_constructor c1 c2 | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) -> f p1 p2 & f c1 c2 & array_for_all2 f bl1 bl2 | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) -> @@ -642,7 +648,7 @@ let compare_constr f t1 t2 = type types = constr -type strategy = types option +type strategy = types option type named_declaration = identifier * constr option * types type rel_declaration = name * constr option * types @@ -653,6 +659,34 @@ 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 +(***************************************************************************) +(* Type of local contexts (telescopes) *) +(***************************************************************************) + +(*s Signatures of ordered optionally named variables, intended to be + accessed by de Bruijn indices (to represent bound variables) *) + +type rel_context = rel_declaration list + +let empty_rel_context = [] + +let add_rel_decl d ctxt = d::ctxt + +let rec lookup_rel n sign = + match n, sign with + | 1, decl :: _ -> decl + | n, _ :: sign -> lookup_rel (n-1) sign + | _, [] -> raise Not_found + +let rel_context_length = List.length + +let rel_context_nhyps hyps = + let rec nhyps acc = function + | [] -> acc + | (_,None,_)::hyps -> nhyps (1+acc) hyps + | (_,Some _,_)::hyps -> nhyps acc hyps in + nhyps 0 hyps + (****************************************************************************) (* Functions for dealing with constr terms *) (****************************************************************************) @@ -666,11 +700,11 @@ exception LocalOccur (* (closedn n M) raises FreeVar if a variable of height greater than n occurs in M, returns () otherwise *) -let closedn n c = +let closedn n c = let rec closed_rec n c = match kind_of_term c with | Rel m -> if m>n then raise LocalOccur | _ -> iter_constr_with_binders succ closed_rec n c - in + in try closed_rec n c; true with LocalOccur -> false (* [closed0 M] is true iff [M] is a (deBruijn) closed term *) @@ -679,21 +713,21 @@ let closed0 = closedn 0 (* (noccurn n M) returns true iff (Rel n) does NOT occur in term M *) -let noccurn n term = +let noccurn n term = let rec occur_rec n c = match kind_of_term c with | Rel m -> if m = n then raise LocalOccur | _ -> iter_constr_with_binders succ occur_rec n c - in + in try occur_rec n term; true with LocalOccur -> false -(* (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 *) -let noccur_between n m term = +let noccur_between n m term = let rec occur_rec n c = match kind_of_term c with | Rel(p) -> if n<=p && p<n+m then raise LocalOccur | _ -> iter_constr_with_binders succ occur_rec n c - in + in try occur_rec n term; true with LocalOccur -> false (* Checking function for terms containing existential variables. @@ -703,7 +737,7 @@ let noccur_between n m term = which may contain the CoFix variables. These occurrences of CoFix variables are not considered *) -let noccur_with_meta n m term = +let noccur_with_meta n m term = let rec occur_rec n c = match kind_of_term c with | Rel p -> if n<=p & p<n+m then raise LocalOccur | App(f,cl) -> @@ -728,18 +762,18 @@ let rec exliftn el c = match kind_of_term c with (* Lifting the binding depth across k bindings *) -let liftn k n = +let liftn k n = match el_liftn (pred n) (el_shft k ELID) with | ELID -> (fun c -> c) | el -> exliftn el - + let lift k = liftn k 1 (*********************) (* Substituting *) (*********************) -(* (subst1 M c) substitutes M for Rel(1) in c +(* (subst1 M c) substitutes M for Rel(1) in c we generalise it to (substl [M1,...,Mn] c) which substitutes in parallel M1,...,Mn for respectively Rel(1),...,Rel(n) in c *) @@ -759,15 +793,15 @@ let rec lift_substituend depth s = let make_substituend c = { sinfo=Unknown; sit=c } let substn_many lamv n c = - let lv = Array.length lamv in + let lv = Array.length lamv in if lv = 0 then c - else + else let rec substrec depth c = match kind_of_term c with | Rel k -> if k<=depth then c else if k-depth <= lv then lift_substituend depth lamv.(k-depth-1) else mkRel (k-lv) - | _ -> map_constr_with_binders succ substrec depth c in + | _ -> map_constr_with_binders succ substrec depth c in substrec n c (* @@ -791,21 +825,21 @@ let substl_named_decl = substl_decl let rec thin_val = function | [] -> [] - | (((id,{ sit = v }) as s)::tl) when isVar v -> + | (((id,{ sit = v }) as s)::tl) when isVar v -> if id = destVar v then thin_val tl else s::(thin_val tl) | h::tl -> h::(thin_val tl) (* (replace_vars sigma M) applies substitution sigma to term M *) -let replace_vars var_alist = +let replace_vars var_alist = let var_alist = List.map (fun (str,c) -> (str,make_substituend c)) var_alist in - let var_alist = thin_val var_alist in + let var_alist = thin_val var_alist in let rec substrec n c = match kind_of_term c with | Var x -> (try lift_substituend n (List.assoc x var_alist) with Not_found -> c) | _ -> map_constr_with_binders succ substrec n c - in + in if var_alist = [] then (function x -> x) else substrec 0 (* @@ -910,7 +944,7 @@ let mkAppA v = 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 *) +(* Constructs a constant *) (* The array of terms correspond to the variables introduced in the section *) let mkConst = mkConst @@ -921,7 +955,7 @@ let mkEvar = mkEvar (* 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 +(* 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 @@ -930,15 +964,15 @@ let mkConstruct = mkConstruct let mkCase = mkCase let mkCaseL (ci, p, c, ac) = mkCase (ci, p, c, Array.of_list ac) -(* If recindxs = [|i1,...in|] +(* If recindxs = [|i1,...in|] funnames = [|f1,...fn|] typarray = [|t1,...tn|] bodies = [|b1,...bn|] - then + then mkFix ((recindxs,i),(funnames,typarray,bodies)) - - constructs the ith function of the block + + constructs the ith function of the block Fixpoint f1 [ctx1] : t1 := b1 with f2 [ctx2] : t2 := b2 @@ -953,12 +987,12 @@ let mkFix = mkFix (* If funnames = [|f1,...fn|] typarray = [|t1,...tn|] bodies = [|b1,...bn|] - then + then mkCoFix (i,(funnames,typsarray,bodies)) - constructs the ith function of the block - + constructs the ith function of the block + CoFixpoint f1 : t1 := b1 with f2 : t2 := b2 ... @@ -984,7 +1018,7 @@ let prodn n env b = | (0, env, b) -> b | (n, ((v,t)::l), b) -> prodrec (n-1, l, mkProd (v,t,b)) | _ -> assert false - in + in prodrec (n,env,b) (* compose_prod [xn:Tn;..;x1:T1] b = (x1:T1)..(xn:Tn)b *) @@ -996,7 +1030,7 @@ let lamn n env b = | (0, env, b) -> b | (n, ((v,t)::l), b) -> lamrec (n-1, l, mkLambda (v,t,b)) | _ -> assert false - in + in lamrec (n,env,b) (* compose_lam [xn:Tn;..;x1:T1] b = [x1:T1]..[xn:Tn]b *) @@ -1007,29 +1041,29 @@ let applist (f,l) = mkApp (f, Array.of_list l) let applistc f l = mkApp (f, Array.of_list l) let appvect = mkApp - + let appvectc f l = mkApp (f,l) - + (* to_lambda n (x1:T1)...(xn:Tn)T = * [x1:T1]...[xn:Tn]T *) let rec to_lambda n prod = - if n = 0 then - prod - else - match kind_of_term prod with + if n = 0 then + prod + else + match kind_of_term prod with | Prod (na,ty,bd) -> mkLambda (na,ty,to_lambda (n-1) bd) | Cast (c,_,_) -> to_lambda n c - | _ -> errorlabstrm "to_lambda" (mt ()) + | _ -> errorlabstrm "to_lambda" (mt ()) let rec to_prod n lam = - if n=0 then + if n=0 then lam - else - match kind_of_term lam with + else + match kind_of_term lam with | Lambda (na,ty,bd) -> mkProd (na,ty,to_prod (n-1) bd) | Cast (c,_,_) -> to_prod n c - | _ -> errorlabstrm "to_prod" (mt ()) - + | _ -> errorlabstrm "to_prod" (mt ()) + (* pseudo-reduction rule: * [prod_app s (Prod(_,B)) N --> B[N] * with an strip_outer_cast on the first argument to produce a product *) @@ -1048,91 +1082,190 @@ let prod_appvect t nL = Array.fold_left prod_app t nL (* prod_applist T [ a1 ; ... ; an ] -> (T a1 ... an) *) let prod_applist t nL = List.fold_left prod_app t nL +let it_mkProd_or_LetIn = List.fold_left (fun c d -> mkProd_or_LetIn d c) +let it_mkLambda_or_LetIn = List.fold_left (fun c d -> mkLambda_or_LetIn d c) + (*********************************) (* Other term destructors *) (*********************************) (* Transforms a product term (x1:T1)..(xn:Tn)T into the pair ([(xn,Tn);...;(x1,T1)],T), where T is not a product *) -let decompose_prod = +let decompose_prod = let rec prodec_rec l c = match kind_of_term c with | Prod (x,t,c) -> prodec_rec ((x,t)::l) c | Cast (c,_,_) -> prodec_rec l c | _ -> l,c - in + in prodec_rec [] (* Transforms a lambda term [x1:T1]..[xn:Tn]T into the pair ([(xn,Tn);...;(x1,T1)],T), where T is not a lambda *) -let decompose_lam = +let decompose_lam = let rec lamdec_rec l c = match kind_of_term c with | Lambda (x,t,c) -> lamdec_rec ((x,t)::l) c | Cast (c,_,_) -> lamdec_rec l c | _ -> l,c - in + in lamdec_rec [] -(* Given a positive integer n, transforms a product term (x1:T1)..(xn:Tn)T +(* Given a positive integer n, transforms a product term (x1:T1)..(xn:Tn)T into the pair ([(xn,Tn);...;(x1,T1)],T) *) let decompose_prod_n n = if n < 0 then error "decompose_prod_n: integer parameter must be positive"; - let rec prodec_rec l n c = - if n=0 then l,c - else match kind_of_term c with + let rec prodec_rec l n c = + if n=0 then l,c + else match kind_of_term c with | Prod (x,t,c) -> prodec_rec ((x,t)::l) (n-1) c | Cast (c,_,_) -> prodec_rec l n c | _ -> error "decompose_prod_n: not enough products" - in - prodec_rec [] n + in + prodec_rec [] n -(* Given a positive integer n, transforms a lambda term [x1:T1]..[xn:Tn]T +(* Given a positive integer n, transforms a lambda term [x1:T1]..[xn:Tn]T into the pair ([(xn,Tn);...;(x1,T1)],T) *) let decompose_lam_n n = if n < 0 then error "decompose_lam_n: integer parameter must be positive"; - let rec lamdec_rec l n c = - if n=0 then l,c - else match kind_of_term c with + let rec lamdec_rec l n c = + if n=0 then l,c + else match kind_of_term c with | Lambda (x,t,c) -> lamdec_rec ((x,t)::l) (n-1) c | Cast (c,_,_) -> lamdec_rec l n c | _ -> error "decompose_lam_n: not enough abstractions" - in - lamdec_rec [] n + in + lamdec_rec [] n + +(* Transforms a product term (x1:T1)..(xn:Tn)T into the pair + ([(xn,Tn);...;(x1,T1)],T), where T is not a product *) +let decompose_prod_assum = + let rec prodec_rec l c = + match kind_of_term c with + | Prod (x,t,c) -> prodec_rec (add_rel_decl (x,None,t) l) c + | LetIn (x,b,t,c) -> prodec_rec (add_rel_decl (x,Some b,t) l) c + | Cast (c,_,_) -> prodec_rec l c + | _ -> l,c + in + prodec_rec empty_rel_context + +(* Transforms a lambda term [x1:T1]..[xn:Tn]T into the pair + ([(xn,Tn);...;(x1,T1)],T), where T is not a lambda *) +let decompose_lam_assum = + let rec lamdec_rec l c = + match kind_of_term c with + | Lambda (x,t,c) -> lamdec_rec (add_rel_decl (x,None,t) l) c + | LetIn (x,b,t,c) -> lamdec_rec (add_rel_decl (x,Some b,t) l) c + | Cast (c,_,_) -> lamdec_rec l c + | _ -> l,c + in + lamdec_rec empty_rel_context + +(* Given a positive integer n, transforms a product term (x1:T1)..(xn:Tn)T + into the pair ([(xn,Tn);...;(x1,T1)],T) *) +let decompose_prod_n_assum n = + if n < 0 then + error "decompose_prod_n_assum: integer parameter must be positive"; + let rec prodec_rec l n c = + if n=0 then l,c + else match kind_of_term c with + | Prod (x,t,c) -> prodec_rec (add_rel_decl (x,None,t) l) (n-1) c + | LetIn (x,b,t,c) -> prodec_rec (add_rel_decl (x,Some b,t) l) (n-1) c + | Cast (c,_,_) -> prodec_rec l n c + | c -> error "decompose_prod_n_assum: not enough assumptions" + in + prodec_rec empty_rel_context n + +(* Given a positive integer n, transforms a lambda term [x1:T1]..[xn:Tn]T + into the pair ([(xn,Tn);...;(x1,T1)],T) + Lets in between are not expanded but turn into local definitions, + but n is the actual number of destructurated lambdas. *) +let decompose_lam_n_assum n = + if n < 0 then + error "decompose_lam_n_assum: integer parameter must be positive"; + let rec lamdec_rec l n c = + if n=0 then l,c + else match kind_of_term c with + | Lambda (x,t,c) -> lamdec_rec (add_rel_decl (x,None,t) l) (n-1) c + | LetIn (x,b,t,c) -> lamdec_rec (add_rel_decl (x,Some b,t) l) n c + | Cast (c,_,_) -> lamdec_rec l n c + | c -> error "decompose_lam_n_assum: not enough abstractions" + in + lamdec_rec empty_rel_context n (* (nb_lam [na1:T1]...[nan:Tan]c) where c is not an abstraction * gives n (casts are ignored) *) -let nb_lam = +let nb_lam = let rec nbrec n c = match kind_of_term c with | Lambda (_,_,c) -> nbrec (n+1) c | Cast (c,_,_) -> nbrec n c | _ -> n - in + in nbrec 0 - + (* similar to nb_lam, but gives the number of products instead *) -let nb_prod = +let nb_prod = let rec nbrec n c = match kind_of_term c with | Prod (_,_,c) -> nbrec (n+1) c | Cast (c,_,_) -> nbrec n c | _ -> n - in + in nbrec 0 -(* Rem: end of import from old module Generic *) +let prod_assum t = fst (decompose_prod_assum t) +let prod_n_assum n t = fst (decompose_prod_n_assum n t) +let strip_prod_assum t = snd (decompose_prod_assum t) +let strip_prod t = snd (decompose_prod t) +let strip_prod_n n t = snd (decompose_prod_n n t) +let lam_assum t = fst (decompose_lam_assum t) +let lam_n_assum n t = fst (decompose_lam_n_assum n t) +let strip_lam_assum t = snd (decompose_lam_assum t) +let strip_lam t = snd (decompose_lam t) +let strip_lam_n n t = snd (decompose_lam_n n t) + +(***************************) +(* Arities *) +(***************************) + +(* 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 + +let destArity = + let rec prodec_rec l c = + match kind_of_term c with + | Prod (x,t,c) -> prodec_rec ((x,None,t)::l) c + | LetIn (x,b,t,c) -> prodec_rec ((x,Some b,t)::l) c + | Cast (c,_,_) -> prodec_rec l c + | Sort s -> l,s + | _ -> anomaly "destArity: not an arity" + in + prodec_rec [] + +let mkArity (sign,s) = it_mkProd_or_LetIn (mkSort s) sign + +let rec isArity c = + match kind_of_term c with + | Prod (_,_,c) -> isArity c + | LetIn (_,b,_,c) -> isArity (subst1 b c) + | Cast (c,_,_) -> isArity c + | Sort _ -> true + | _ -> false (*******************************) -(* alpha conversion functions *) +(* alpha conversion functions *) (*******************************) (* alpha conversion : ignore print names and casts *) -let rec eq_constr m n = +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 *) +(* hash-consing *) (*******************) module Htype = diff --git a/kernel/term.mli b/kernel/term.mli index 3b5a2bc1..0de83166 100644 --- a/kernel/term.mli +++ b/kernel/term.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: term.mli 11309 2008-08-06 10:30:35Z herbelin $ i*) +(*i $Id$ i*) (*i*) open Names @@ -42,7 +42,7 @@ type metavariable = int (*s Case annotation *) type case_style = LetStyle | IfStyle | LetPatternStyle | MatchStyle | RegularStyle type case_printing = - { ind_nargs : int; (* number of real args 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 *) type case_info = @@ -63,13 +63,13 @@ val eq_constr : constr -> constr -> bool (* [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 {\em 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. - The following functions are intended to simplify and to uniform the + The following functions are intended to simplify and to uniform the manipulation of terms. Some of these functions may be overlapped with previous ones. *) @@ -96,9 +96,9 @@ val mkType : Univ.universe -> types (* This defines the strategy to use for verifiying a Cast *) -type cast_kind = VMcast | DEFAULTcast +type cast_kind = VMcast | DEFAULTcast -(* Constructs the term [t1::t2], i.e. the term $t_1$ casted with the +(* 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 @@ -122,7 +122,7 @@ val mkNamedLetIn : identifier -> constr -> types -> constr -> constr $(f~t_1~\dots~t_n)$. *) val mkApp : constr * constr array -> constr -(* Constructs a constant *) +(* Constructs a constant *) (* The array of terms correspond to the variables introduced in the section *) val mkConst : constant -> constr @@ -132,7 +132,7 @@ val mkConst : constant -> constr (* 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 @@ -162,8 +162,8 @@ val mkFix : fixpoint -> constr [typarray = [|t1,...tn|]] [bodies = [b1,.....bn]] \par\noindent then [mkCoFix (i, (typsarray, funnames, bodies))] - constructs the ith function of the block - + constructs the ith function of the block + [CoFixpoint f1 = b1 with f2 = b2 ... @@ -208,11 +208,12 @@ type ('constr, 'types) kind_of_term = 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 *) type ('constr, 'types) kind_of_type = | SortType of sorts - | CastType of 'types * 'types + | CastType of 'types * 'types | ProdType of name * 'types * 'types | LetInType of name * 'constr * 'types * 'types | AtomicType of 'constr * 'constr array @@ -226,6 +227,7 @@ val isVar : constr -> bool val isInd : constr -> bool val isEvar : constr -> bool val isMeta : constr -> bool +val isEvar_or_Meta : constr -> bool val isSort : constr -> bool val isCast : constr -> bool val isApp : constr -> bool @@ -245,7 +247,7 @@ val is_Type : constr -> bool val iskind : constr -> bool val is_small : sorts -> bool -(*s Term destructors. +(*s Term destructors. Destructor operations are partial functions and raise [invalid_arg "dest*"] if the term has not the expected form. *) @@ -258,7 +260,7 @@ val destMeta : constr -> metavariable (* Destructs a variable *) val destVar : constr -> identifier -(* Destructs a sort. [is_Prop] recognizes the sort \textsf{Prop}, whether +(* Destructs a sort. [is_Prop] recognizes the sort \textsf{Prop}, whether [isprop] recognizes both \textsf{Prop} and \textsf{Set}. *) val destSort : constr -> sorts @@ -298,7 +300,7 @@ val destConstruct : constr -> constructor (* Destructs a term <p>Case c of lc1 | lc2 .. | lcn end *) val destCase : constr -> case_info * constr * constr * constr array -(* Destructs the $i$th function of the block +(* 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 @@ -330,6 +332,18 @@ 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 *) + +(* In [rel_context], more recent declaration is on top *) +type rel_context = rel_declaration list + +val empty_rel_context : rel_context +val add_rel_decl : rel_declaration -> rel_context -> rel_context + +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] *) val mkProd_or_LetIn : rel_declaration -> types -> types val mkNamedProd_or_LetIn : named_declaration -> types -> types @@ -352,7 +366,7 @@ 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$ +(* [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]$ *) val prodn : int -> (name * constr) list -> constr -> constr @@ -367,15 +381,15 @@ 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)]$. - Inverse of [decompose_lam] *) + Inverse of [it_destLam] *) val compose_lam : (name * constr) list -> constr -> constr -(* [to_lambda n l] +(* [to_lambda n l] = $[x_1:T_1]...[x_n:T_n]T$ where $l = (x_1:T_1)...(x_n:T_n)T$ *) val to_lambda : int -> constr -> constr -(* [to_prod n l] +(* [to_prod n l] = $(x_1:T_1)...(x_n:T_n)T$ where $l = [x_1:T_1]...[x_n:T_n]T$ *) val to_prod : int -> constr -> constr @@ -386,6 +400,9 @@ val to_prod : int -> constr -> constr 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. *) (* Transforms a product term $(x_1:T_1)..(x_n:T_n)T$ into the pair @@ -397,22 +414,53 @@ val decompose_prod : constr -> (name*constr) list * constr $([(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 +(* 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 +(* 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 + "(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 *) +val decompose_lam_assum : constr -> rel_context * constr + +(* 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) *) 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) *) +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)*) +val prod_n_assum : int -> types -> rel_context +val lam_n_assum : int -> constr -> rel_context + +(* 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 *) +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) *) +val strip_prod_assum : types -> types +val strip_lam_assum : constr -> constr + (* flattens application lists *) val collapse_appl : constr -> constr @@ -427,6 +475,21 @@ val under_casts : (constr -> constr) -> constr -> constr (* 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. + 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 *) +val mkArity : arity -> types + +(* Destructs an "arity" into its canonical form *) +val destArity : types -> arity + +(* Tells if a term has the form of an arity *) +val isArity : types -> bool + (*s Occur checks *) (* [closedn n M] is true iff [M] is a (deBruijn) closed term under n binders *) @@ -532,11 +595,11 @@ val compare_constr : (constr -> constr -> bool) -> constr -> constr -> bool val hcons_constr: (constant -> constant) * - (kernel_name -> kernel_name) * + (mutual_inductive -> mutual_inductive) * (dir_path -> dir_path) * (name -> name) * (identifier -> identifier) * - (string -> string) + (string -> string) -> (constr -> constr) * (types -> types) diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index f50a0b83..c465adfa 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: term_typing.ml 11309 2008-08-06 10:30:35Z herbelin $ *) +(* $Id$ *) open Util open Names @@ -25,7 +25,7 @@ open Typeops let constrain_type env j cst1 = function | None -> make_polymorphic_if_constant_for_ind env j, cst1 - | Some t -> + | 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); @@ -34,7 +34,7 @@ let constrain_type env j cst1 = function let local_constrain_type env j cst1 = function | None -> j.uj_type, cst1 - | Some t -> + | 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); @@ -59,7 +59,7 @@ let translate_local_assum env t = let safe_push_named (id,_,_ as d) env = let _ = try - let _ = lookup_named id env in + let _ = lookup_named id env in error ("Identifier "^string_of_id id^" already defined.") with Not_found -> () in push_named d env @@ -99,18 +99,18 @@ let infer_declaration env dcl = let global_vars_set_constant_type env = function | NonPolymorphicType t -> global_vars_set env t | PolymorphicArity (ctx,_) -> - Sign.fold_rel_context + Sign.fold_rel_context (fold_rel_declaration (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 + match body with | None -> global_vars_set_constant_type env typ | Some b -> - Idset.union - (global_vars_set env (Declarations.force 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 @@ -121,7 +121,7 @@ let build_constant_declaration env kn (body,typ,cst,op,boxed,inline) = const_body_code = tps; (* const_type_code = to_patch env typ;*) const_constraints = cst; - const_opaque = op; + const_opaque = op; const_inline = inline} (*s Global and local constant declaration. *) @@ -129,9 +129,9 @@ let build_constant_declaration env kn (body,typ,cst,op,boxed,inline) = let translate_constant env kn ce = build_constant_declaration env kn (infer_declaration env ce) -let translate_recipe env kn r = +let translate_recipe env kn r = build_constant_declaration env kn (Cooking.cook_constant env r) (* Insertion of inductive types. *) -let translate_mind env mie = check_inductive env mie +let translate_mind env mie = check_inductive env mie diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli index d84cfe91..69b13e3b 100644 --- a/kernel/term_typing.mli +++ b/kernel/term_typing.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: term_typing.mli 9795 2007-04-25 15:13:45Z soubiran $ i*) +(*i $Id$ i*) (*i*) open Names @@ -19,13 +19,13 @@ open Entries open Typeops (*i*) -val translate_local_def : env -> constr * types option -> +val translate_local_def : env -> constr * types option -> constr * types * Univ.constraints val translate_local_assum : env -> types -> types * Univ.constraints -val infer_declaration : env -> constant_entry -> +val infer_declaration : env -> constant_entry -> constr_substituted option * constant_type * constraints * bool * bool * bool val build_constant_declaration : env -> 'a -> @@ -34,8 +34,8 @@ val build_constant_declaration : env -> 'a -> val translate_constant : env -> constant -> constant_entry -> constant_body -val translate_mind : +val translate_mind : env -> mutual_inductive_entry -> mutual_inductive_body -val translate_recipe : +val translate_recipe : env -> constant -> Cooking.recipe -> constant_body diff --git a/kernel/type_errors.ml b/kernel/type_errors.ml index 1a49531b..2d26d27e 100644 --- a/kernel/type_errors.ml +++ b/kernel/type_errors.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: type_errors.ml 10533 2008-02-08 16:54:47Z msozeau $ *) +(* $Id$ *) open Names open Term @@ -80,10 +80,10 @@ let error_assumption env j = let error_reference_variables env id = raise (TypeError (env, ReferenceVariables id)) -let error_elim_arity env ind aritylst c pj okinds = +let error_elim_arity env ind aritylst c pj okinds = raise (TypeError (env, ElimArity (ind,aritylst,c,pj,okinds))) -let error_case_not_inductive env j = +let error_case_not_inductive env j = raise (TypeError (env, CaseNotInductive j)) let error_number_branches env cj expn = diff --git a/kernel/type_errors.mli b/kernel/type_errors.mli index 368e1723..9c7b6561 100644 --- a/kernel/type_errors.mli +++ b/kernel/type_errors.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: type_errors.mli 10533 2008-02-08 16:54:47Z msozeau $ i*) +(*i $Id$ i*) (*i*) open Names @@ -71,11 +71,11 @@ val error_unbound_var : env -> variable -> 'a val error_not_type : env -> unsafe_judgment -> 'a val error_assumption : env -> unsafe_judgment -> 'a - + val error_reference_variables : env -> constr -> 'a -val error_elim_arity : - env -> inductive -> sorts_family list -> constr -> unsafe_judgment -> +val error_elim_arity : + env -> inductive -> sorts_family list -> constr -> unsafe_judgment -> (sorts_family * sorts_family * arity_error) option -> 'a val error_case_not_inductive : env -> unsafe_judgment -> 'a @@ -88,11 +88,11 @@ val error_generalization : env -> name * types -> unsafe_judgment -> 'a val error_actual_type : env -> unsafe_judgment -> types -> 'a -val error_cant_apply_not_functional : +val error_cant_apply_not_functional : env -> unsafe_judgment -> unsafe_judgment array -> 'a -val error_cant_apply_bad_type : - env -> int * constr * constr -> +val error_cant_apply_bad_type : + env -> int * constr * constr -> unsafe_judgment -> unsafe_judgment array -> 'a val error_ill_formed_rec_body : diff --git a/kernel/typeops.ml b/kernel/typeops.ml index e548e6f5..27db208c 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: typeops.ml 10877 2008-04-30 21:58:41Z herbelin $ *) +(* $Id$ *) open Util open Names @@ -19,15 +19,15 @@ open Entries open Reduction open Inductive open Type_errors - + let conv = default_conv CONV let conv_leq = default_conv CUMUL let conv_leq_vecti env v1 v2 = - array_fold_left2_i + array_fold_left2_i (fun i c t1 t2 -> let c' = - try default_conv CUMUL env t1 t2 + try default_conv CUMUL env t1 t2 with NotConvertible -> raise (NotConvertibleVect i) in Constraint.union c c') Constraint.empty @@ -77,13 +77,13 @@ let judge_of_type u = uj_type = mkType uu } (*s Type of a de Bruijn index. *) - -let judge_of_relative env n = + +let judge_of_relative env n = try let (_,_,typ) = lookup_rel n env in { uj_val = mkRel n; uj_type = lift n typ } - with Not_found -> + with Not_found -> error_unbound_rel env n (* Type of variables *) @@ -91,7 +91,7 @@ let judge_of_variable env id = try let ty = named_type id env in make_judge (mkVar id) ty - with Not_found -> + with Not_found -> error_unbound_var env id (* Management of context of variables. *) @@ -164,7 +164,7 @@ let type_of_constant env cst = let judge_of_constant_knowing_parameters env cst jl = let c = mkConst cst in let cb = lookup_constant cst env in - let _ = check_args env c cb.const_hyps in + let _ = check_args env c cb.const_hyps in let paramstyp = Array.map (fun j -> j.uj_type) jl in let t = type_of_constant_knowing_parameters env cb.const_type paramstyp in make_judge c t @@ -198,25 +198,25 @@ let judge_of_letin env name defj typj j = let judge_of_apply env funj argjv = let rec apply_rec n typ cst = function - | [] -> + | [] -> { uj_val = mkApp (j_val funj, Array.map j_val argjv); uj_type = typ }, cst | hj::restjl -> (match kind_of_term (whd_betadeltaiota env typ) with | Prod (_,c1,c2) -> - (try + (try let c = conv_leq env hj.uj_type c1 in let cst' = Constraint.union cst c in apply_rec (n+1) (subst1 hj.uj_val c2) cst' restjl - with NotConvertible -> + with NotConvertible -> error_cant_apply_bad_type env (n,c1, hj.uj_type) funj argjv) | _ -> error_cant_apply_not_functional env funj argjv) - in + in apply_rec 1 funj.uj_type Constraint.empty @@ -226,7 +226,7 @@ let judge_of_apply env funj argjv = let sort_of_product env domsort rangsort = match (domsort, rangsort) with - (* Product rule (s,Prop,Prop) *) + (* Product rule (s,Prop,Prop) *) | (_, Prop Null) -> rangsort (* Product rule (Prop/Set,Set,Set) *) | (Prop _, Prop Pos) -> rangsort @@ -242,7 +242,7 @@ let sort_of_product env domsort rangsort = | (Prop Pos, Type u2) -> Type (sup type0_univ u2) (* Product rule (Prop,Type_i,Type_i) *) | (Prop Null, Type _) -> rangsort - (* Product rule (Type_i,Type_i,Type_i) *) + (* Product rule (Type_i,Type_i,Type_i) *) | (Type u1, Type u2) -> Type (sup u1 u2) (* [judge_of_product env name (typ1,s1) (typ2,s2)] implements the rule @@ -269,8 +269,8 @@ 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 = + try + let cst = match k with | VMcast -> vm_conv CUMUL env cj.uj_type expected_type | DEFAULTcast -> conv_leq env cj.uj_type expected_type in @@ -312,13 +312,13 @@ let judge_of_constructor env c = let _ = let ((kn,_),_) = c in let mib = lookup_mind kn env in - check_args env constr mib.mind_hyps in + check_args env constr mib.mind_hyps in let specif = lookup_mind_specif env (inductive_of_constructor c) in make_judge constr (type_of_constructor c specif) (* Case. *) -let check_branch_types env cj (lfj,explft) = +let check_branch_types env cj (lfj,explft) = try conv_leq_vecti env (Array.map j_type lfj) explft with NotConvertibleVect i -> @@ -368,16 +368,16 @@ let univ_combinator (cst,univ) (j,c') = let rec execute env cstr cu = match kind_of_term cstr with (* Atomic terms *) - | Sort (Prop c) -> + | Sort (Prop c) -> (judge_of_prop_contents c, cu) | Sort (Type u) -> (judge_of_type u, cu) - | Rel n -> + | Rel n -> (judge_of_relative env n, cu) - | Var id -> + | Var id -> (judge_of_variable env id, cu) | Const c -> @@ -391,21 +391,21 @@ let rec execute env cstr cu = | Ind ind -> (* Sort-polymorphism of inductive types *) judge_of_inductive_knowing_parameters env ind jl, cu1 - | Const cst -> + | Const cst -> (* Sort-polymorphism of constant *) judge_of_constant_knowing_parameters env cst jl, cu1 - | _ -> + | _ -> (* No sort-polymorphism *) execute env f cu1 in univ_combinator cu2 (judge_of_apply env j jl) - - | Lambda (name,c1,c2) -> + + | Lambda (name,c1,c2) -> let (varj,cu1) = execute_type env c1 cu in let env1 = push_rel (name,None,varj.utj_val) env in - let (j',cu2) = execute env1 c2 cu1 in + let (j',cu2) = execute env1 c2 cu1 in (judge_of_abstraction env name varj j', cu2) - + | Prod (name,c1,c2) -> let (varj,cu1) = execute_type env c1 cu in let env1 = push_rel (name,None,varj.utj_val) env in @@ -415,12 +415,12 @@ let rec execute env cstr cu = | LetIn (name,c1,c2,c3) -> let (j1,cu1) = execute env c1 cu in let (j2,cu2) = execute_type env c2 cu1 in - let (_,cu3) = + let (_,cu3) = univ_combinator cu2 (judge_of_cast env j1 DEFAULTcast j2) in let env1 = push_rel (name,Some j1.uj_val,j2.utj_val) env in let (j',cu4) = execute env1 c3 cu3 in (judge_of_letin env name j1 j2 j', cu4) - + | Cast (c,k, t) -> let (cj,cu1) = execute env c cu in let (tj,cu2) = execute_type env t cu1 in @@ -431,7 +431,7 @@ let rec execute env cstr cu = | Ind ind -> (judge_of_inductive env ind, cu) - | Construct c -> + | Construct c -> (judge_of_constructor env c, cu) | Case (ci,p,c,lf) -> @@ -440,13 +440,13 @@ let rec execute env cstr cu = let (lfj,cu3) = execute_array env lf cu2 in univ_combinator cu3 (judge_of_case env ci pj cj lfj) - + | Fix ((vn,i as vni),recdef) -> let ((fix_ty,recdef'),cu1) = execute_recdef env recdef i cu in let fix = (vni,recdef') in check_fix env fix; (make_judge (mkFix fix) fix_ty, cu1) - + | CoFix (i,recdef) -> let ((fix_ty,recdef'),cu1) = execute_recdef env recdef i cu in let cofix = (i,recdef') in @@ -460,10 +460,10 @@ let rec execute env cstr cu = | Evar _ -> anomaly "the kernel does not support existential variables" -and execute_type env constr cu = +and execute_type env constr cu = let (j,cu1) = execute env constr cu in (type_judgment env j, cu1) - + and execute_recdef env (names,lar,vdef) i cu = let (larj,cu1) = execute_array env lar cu in let lara = Array.map (assumption_of_judgment env) larj in @@ -476,7 +476,7 @@ 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) +and execute_list env = list_fold_map' (execute env) (* Derived functions *) let infer env constr = @@ -494,11 +494,11 @@ let infer_v env cv = let (jv,(cst,_)) = execute_array env cv (Constraint.empty, universes env) in (jv, cst) - + (* Typing of several terms. *) let infer_local_decl env id = function - | LocalDef c -> + | LocalDef c -> let (j,cst) = infer env c in (Name id, Some j.uj_val, j.uj_type), cst | LocalAssum c -> @@ -507,7 +507,7 @@ let infer_local_decl env id = function let infer_local_decls env decls = let rec inferec env = function - | (id, d) :: l -> + | (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 @@ -516,7 +516,7 @@ let infer_local_decls env decls = (* Exported typing functions *) -let typing env c = +let typing env c = let (j,cst) = infer env c in let _ = add_constraints cst env in j diff --git a/kernel/typeops.mli b/kernel/typeops.mli index c427055a..b0f15e75 100644 --- a/kernel/typeops.mli +++ b/kernel/typeops.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: typeops.mli 10877 2008-04-30 21:58:41Z herbelin $ i*) +(*i $Id$ i*) (*i*) open Names @@ -25,7 +25,7 @@ val infer_type : env -> types -> unsafe_type_judgment * constraints val infer_local_decls : env -> (identifier * local_entry) list - -> env * Sign.rel_context * constraints + -> env * rel_context * constraints (*s Basic operations of the typing machine. *) @@ -52,23 +52,23 @@ val judge_of_constant_knowing_parameters : env -> constant -> unsafe_judgment array -> unsafe_judgment (*s Type of application. *) -val judge_of_apply : +val judge_of_apply : env -> unsafe_judgment -> unsafe_judgment array -> unsafe_judgment * constraints (*s Type of an abstraction. *) -val judge_of_abstraction : - env -> name -> unsafe_type_judgment -> unsafe_judgment +val judge_of_abstraction : + env -> name -> unsafe_type_judgment -> unsafe_judgment -> unsafe_judgment (*s Type of a product. *) val judge_of_product : - env -> name -> unsafe_type_judgment -> unsafe_type_judgment + env -> name -> unsafe_type_judgment -> unsafe_type_judgment -> unsafe_judgment (* s Type of a let in. *) val judge_of_letin : - env -> name -> unsafe_judgment -> unsafe_type_judgment -> unsafe_judgment + env -> name -> unsafe_judgment -> unsafe_type_judgment -> unsafe_judgment -> unsafe_judgment (*s Type of a cast. *) @@ -80,7 +80,7 @@ val judge_of_cast : val judge_of_inductive : env -> inductive -> unsafe_judgment -val judge_of_inductive_knowing_parameters : +val judge_of_inductive_knowing_parameters : env -> inductive -> unsafe_judgment array -> unsafe_judgment val judge_of_constructor : env -> constructor -> unsafe_judgment @@ -91,7 +91,7 @@ val judge_of_case : env -> case_info -> unsafe_judgment * constraints (* Typecheck general fixpoint (not checking guard conditions) *) -val type_fixpoint : env -> name array -> types array +val type_fixpoint : env -> name array -> types array -> unsafe_judgment array -> constraints (* Kernel safe typing but applicable to partial proofs *) @@ -101,7 +101,7 @@ val type_of_constant : env -> constant -> types val type_of_constant_type : env -> constant_type -> types -val type_of_constant_knowing_parameters : +val type_of_constant_knowing_parameters : env -> constant_type -> constr array -> types (* Make a type polymorphic if an arity *) diff --git a/kernel/univ.ml b/kernel/univ.ml index 3d254ce6..16544eca 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: univ.ml 11596 2008-11-16 15:34:06Z letouzey $ *) +(* $Id$ *) (* Initial Caml version originates from CoC 4.8 [Dec 1988] *) (* Extension with algebraic universes by HH [Sep 2001] *) @@ -55,40 +55,38 @@ let cmp_univ_level u v = match u,v with 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 - -module UniverseOrdered = struct - type t = universe_level - let compare = cmp_univ_level -end - -let string_of_univ_level = function - | Set -> "0" - | Level (d,n) -> Names.string_of_dirpath d^"."^string_of_int n let make_univ (m,n) = Atom (Level (m,n)) let pr_uni_level u = str (string_of_univ_level u) let pr_uni = function - | Atom u -> + | Atom u -> pr_uni_level u | Max ([],[u]) -> str "(" ++ pr_uni_level u ++ str ")+1" | Max (gel,gtl) -> str "max(" ++ hov 0 - (prlist_with_sep pr_coma pr_uni_level gel ++ - (if gel <> [] & gtl <> [] then pr_coma () else mt ()) ++ - prlist_with_sep pr_coma + (prlist_with_sep pr_comma pr_uni_level gel ++ + (if gel <> [] & gtl <> [] then pr_comma () else mt ()) ++ + prlist_with_sep pr_comma (fun x -> str "(" ++ pr_uni_level x ++ str ")+1") gtl) ++ str ")" (* Returns the formal universe that lies juste above the universe variable u. Used to type the sort u. *) let super = function - | Atom u -> + | Atom u -> Max ([],[u]) | Max _ -> anomaly ("Cannot take the successor of a non variable universe:\n"^ @@ -121,18 +119,17 @@ type univ_entry = Canonical of canonical_arc | Equiv of universe_level * universe_level -module UniverseMap = Map.Make(UniverseOrdered) -type universes = univ_entry UniverseMap.t - +type universes = univ_entry UniverseLMap.t + let enter_equiv_arc u v g = - UniverseMap.add u (Equiv(u,v)) g + UniverseLMap.add u (Equiv(u,v)) g let enter_arc ca g = - UniverseMap.add ca.univ (Canonical ca) g + UniverseLMap.add ca.univ (Canonical ca) g let declare_univ u g = - if not (UniverseMap.mem u g) then + if not (UniverseLMap.mem u g) then enter_arc (terminal u) g else g @@ -162,20 +159,20 @@ let is_univ_variable = function let type1_univ = Max ([],[Set]) -let initial_universes = UniverseMap.empty +let initial_universes = UniverseLMap.empty (* Every universe_level has a unique canonical arc representative *) (* repr : universes -> universe_level -> canonical_arc *) (* canonical representative : we follow the Equiv links *) -let repr g u = +let repr g u = let rec repr_rec u = let a = - try UniverseMap.find u g + try UniverseLMap.find u g with Not_found -> anomalylabstrm "Univ.repr" - (str"Universe " ++ pr_uni_level u ++ str" undefined") + (str"Universe " ++ pr_uni_level u ++ str" undefined") in - match a with + match a with | Equiv(_,v) -> repr_rec v | Canonical arc -> arc in @@ -192,16 +189,16 @@ let collect g arcu = let rec coll_rec lt le = function | [],[] -> (lt, list_subtractq le lt) | arcv::lt', le' -> - if List.memq arcv lt then + if List.memq arcv lt then coll_rec lt le (lt',le') else coll_rec (arcv::lt) le ((can g (arcv.lt@arcv.le))@lt',le') - | [], arcw::le' -> - if (List.memq arcw lt) or (List.memq arcw le) then + | [], arcw::le' -> + if (List.memq arcw lt) or (List.memq arcw le) then coll_rec lt le ([],le') else coll_rec lt (arcw::le) (can g arcw.lt, (can g arcw.le)@le') - in + in coll_rec [] [] ([],[arcu]) (* reprleq : canonical_arc -> canonical_arc list *) @@ -211,19 +208,19 @@ let reprleq g arcu = | [] -> w | v :: vl -> let arcv = repr g v in - if List.memq arcv w || arcu==arcv then + if List.memq arcv w || arcu==arcv then searchrec w vl - else + else searchrec (arcv :: w) vl - in + in searchrec [] arcu.le (* between : universe_level -> canonical_arc -> canonical_arc list *) -(* between u v = {w|u<=w<=v, w canonical} *) +(* between u v = {w|u<=w<=v, w canonical} *) (* between is the most costly operation *) -let between g u arcv = +let between g u arcv = (* good are all w | u <= w <= v *) (* bad are all w | u <= w ~<= v *) (* find good and bad nodes in {w | u <= w} *) @@ -233,50 +230,50 @@ let between g u arcv = (good, bad, true) (* b or true *) else if List.memq arcu bad then input (* (good, bad, b or false) *) - else - let leq = reprleq g arcu in + else + let leq = reprleq g arcu in (* is some universe >= u good ? *) - let good, bad, b_leq = + let good, bad, b_leq = List.fold_left explore (good, bad, false) leq in if b_leq then arcu::good, bad, true (* b or true *) - else + else good, arcu::bad, b (* b or false *) in let good,_,_ = explore ([arcv],[],false) (repr g u) in good - + (* We assume compare(u,v) = LE with v canonical (see compare below). In this case List.hd(between g u v) = repr u - Otherwise, between g u v = [] + Otherwise, between g u v = [] *) type order = EQ | LT | LE | NLE (* compare : universe_level -> universe_level -> order *) -let compare g u v = - let arcu = repr g u +let compare g u v = + let arcu = repr g u and arcv = repr g v in - if arcu==arcv then + if arcu==arcv then EQ - else + else let (lt,leq) = collect g arcu in - if List.memq arcv lt then + if List.memq arcv lt then LT - else if List.memq arcv leq then + else if List.memq arcv leq then LE - else + else NLE (* Invariants : compare(u,v) = EQ <=> compare(v,u) = EQ compare(u,v) = LT or LE => compare(v,u) = NLE compare(u,v) = NLE => compare(v,u) = NLE or LE or LT - Adding u>=v is consistent iff compare(v,u) # LT + Adding u>=v is consistent iff compare(v,u) # LT and then it is redundant iff compare(u,v) # NLE - Adding u>v is consistent iff compare(v,u) = NLE + 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 = @@ -288,7 +285,7 @@ let compare_eq g u v = type check_function = universes -> universe -> universe -> bool let incl_list cmp l1 l2 = - List.for_all (fun x1 -> List.exists (fun x2 -> cmp x1 x2) l2) l1 + List.for_all (fun x1 -> List.exists (fun x2 -> cmp x1 x2) l2) l1 let compare_list cmp l1 l2 = incl_list cmp l1 l2 && incl_list cmp l2 l1 @@ -361,7 +358,7 @@ let merge g u v = (* redirected to it *) let redirect (g,w,w') arcv = let g' = enter_equiv_arc arcv.univ arcu.univ g in - (g',list_unionq arcv.lt w,arcv.le@w') + (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 @@ -395,7 +392,7 @@ 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 - | NLE -> + | NLE -> (match compare g v u with | LT -> error_inconsistency Le u v | LE -> merge g v u @@ -412,7 +409,7 @@ let enforce_univ_eq u v g = | EQ -> g | LT -> error_inconsistency Eq u v | LE -> merge g u v - | NLE -> + | NLE -> (match compare g v u with | LT -> error_inconsistency Eq u v | LE -> merge g v u @@ -427,13 +424,13 @@ let enforce_univ_lt u v g = | LT -> g | LE -> setlt g u v | EQ -> error_inconsistency Lt u v - | NLE -> + | NLE -> (match compare g v u with | NLE -> setlt g u v | _ -> error_inconsistency Lt u v) (* -let enforce_univ_relation g = function +let enforce_univ_relation g = function | Equiv (u,v) -> enforce_univ_eq u v g | Canonical {univ=u; lt=lt; le=le} -> let g' = List.fold_right (enforce_univ_lt u) lt g in @@ -443,7 +440,7 @@ let enforce_univ_relation g = function (* Merging 2 universe graphs *) (* let merge_universes sp u1 u2 = - UniverseMap.fold (fun _ a g -> enforce_univ_relation g a) u1 u2 + UniverseLMap.fold (fun _ a g -> enforce_univ_relation g a) u1 u2 *) @@ -461,14 +458,14 @@ let enforce_constraint cst g = module Constraint = Set.Make( - struct - type t = univ_constraint - let compare = Pervasives.compare + struct + type t = univ_constraint + let compare = Pervasives.compare end) - + type constraints = Constraint.t -type constraint_function = +type constraint_function = universe -> universe -> constraints -> constraints let constraint_add_leq v u c = @@ -515,17 +512,17 @@ let is_direct_constraint u = function | Atom u' -> u = u' | Max (le,lt) -> List.mem u le -(* +(* Solve a system of universe constraint of the form u_s11, ..., u_s1p1, w1 <= u1 ... u_sn1, ..., u_snpn, wn <= un -where +where - the ui (1 <= i <= n) are universe variables, - - the sjk select subsets of the ui for each equations, + - the sjk select subsets of the ui for each equations, - the wi are arbitrary complex universes that do not mention the ui. *) @@ -534,7 +531,7 @@ let is_direct_sort_constraint s v = match s with | None -> false let solve_constraints_system levels level_bounds = - let levels = + let levels = Array.map (Option.map (function Atom u -> u | _ -> anomaly "expects Atom")) levels in let v = Array.copy level_bounds in @@ -553,7 +550,7 @@ let solve_constraints_system levels level_bounds = v let subst_large_constraint u u' v = - match u with + match u with | Atom u -> if is_direct_constraint u v then sup u' (remove_large_constraint u v) else v @@ -571,16 +568,16 @@ let no_upper_constraints u cst = (* Pretty-printing *) let num_universes g = - UniverseMap.fold (fun _ _ -> succ) g 0 + 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 - UniverseMap.fold (fun _ a n -> n + (reln_len a)) g 0 - -let pr_arc = function + UniverseLMap.fold (fun _ a n -> n + (reln_len a)) g 0 + +let pr_arc = function | Canonical {univ=u; lt=[]; le=[]} -> mt () | Canonical {univ=u; lt=lt; le=le} -> @@ -590,43 +587,43 @@ let pr_arc = function (if lt <> [] & le <> [] then spc () else mt()) ++ prlist_with_sep pr_spc (fun v -> str "<= " ++ pr_uni_level v) le) ++ fnl () - | Equiv (u,v) -> + | Equiv (u,v) -> pr_uni_level u ++ str " = " ++ pr_uni_level v ++ fnl () let pr_universes g = - let graph = UniverseMap.fold (fun k a l -> (k,a)::l) g [] in + let graph = UniverseLMap.fold (fun k a l -> (k,a)::l) g [] in prlist (function (_,a) -> pr_arc a) graph - + let pr_constraints c = - Constraint.fold (fun (u1,op,u2) pp_std -> - let op_str = match op with + Constraint.fold (fun (u1,op,u2) pp_std -> + let op_str = match op with | Lt -> " < " | Leq -> " <= " | Eq -> " = " in pp_std ++ pr_uni_level u1 ++ str op_str ++ pr_uni_level u2 ++ fnl () ) c (str "") - -(* Dumping constrains to a file *) -let dump_universes output g = +(* Dumping constraints to a file *) + +let dump_universes output g = let dump_arc _ = function - | Canonical {univ=u; lt=lt; le=le} -> + | Canonical {univ=u; lt=lt; le=le} -> let u_str = string_of_univ_level u in - List.iter - (fun v -> + List.iter + (fun v -> Printf.fprintf output "%s < %s ;\n" u_str - (string_of_univ_level v)) + (string_of_univ_level v)) lt; - List.iter - (fun v -> + List.iter + (fun v -> Printf.fprintf output "%s <= %s ;\n" u_str - (string_of_univ_level v)) + (string_of_univ_level v)) le | Equiv (u,v) -> Printf.fprintf output "%s = %s ;\n" (string_of_univ_level u) (string_of_univ_level v) in - UniverseMap.iter dump_arc g + UniverseLMap.iter dump_arc g (* Hash-consing *) diff --git a/kernel/univ.mli b/kernel/univ.mli index 668e99a0..2bfcc2aa 100644 --- a/kernel/univ.mli +++ b/kernel/univ.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i $Id: univ.mli 11301 2008-08-04 19:41:18Z herbelin $ i*) +(*i $Id$ i*) (* Universes. *) @@ -53,7 +53,7 @@ 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. +(*s 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. *) @@ -68,12 +68,12 @@ val merge_constraints : constraints -> universes -> universes val fresh_local_univ : unit -> universe -val solve_constraints_system : universe option array -> universe array -> +val solve_constraints_system : universe option array -> universe array -> universe array val subst_large_constraint : universe -> universe -> universe -> universe -val subst_large_constraints : +val subst_large_constraints : (universe * universe) list -> universe -> universe val no_upper_constraints : universe -> constraints -> bool diff --git a/kernel/vconv.ml b/kernel/vconv.ml index 7c515735..a35d1d88 100644 --- a/kernel/vconv.ml +++ b/kernel/vconv.ml @@ -3,10 +3,10 @@ open Declarations open Term open Environ open Conv_oracle -open Reduction +open Reduction open Closure open Vm -open Csymtable +open Csymtable open Univ let val_of_constr env c = @@ -27,7 +27,7 @@ let rec compare_stack stk1 stk2 = | z1::stk1, z2::stk2 -> if compare_zipper z1 z2 then compare_stack stk1 stk2 else false - | _, _ -> false + | _, _ -> false (* Conversion *) let conv_vect fconv vect1 vect2 cu = @@ -42,13 +42,13 @@ let conv_vect fconv vect1 vect2 cu = let infos = ref (create_clos_infos betaiotazeta Environ.empty_env) -let rec conv_val pb k v1 v2 cu = - if v1 == v2 then cu +let rec conv_val pb k v1 v2 cu = + if v1 == v2 then cu else conv_whd pb k (whd_val v1) (whd_val v2) cu - -and conv_whd pb k whd1 whd2 cu = + +and conv_whd pb k whd1 whd2 cu = match whd1, whd2 with - | Vsort s1, Vsort s2 -> sort_cmp pb s1 s2 cu + | Vsort s1, Vsort s2 -> sort_cmp pb s1 s2 cu | Vprod p1, Vprod p2 -> let cu = conv_val CONV k (dom p1) (dom p2) cu in conv_fun pb k (codom p1) (codom p2) cu @@ -58,11 +58,11 @@ and conv_whd pb k whd1 whd2 cu = if nargs args1 <> nargs args2 then raise NotConvertible else conv_arguments k args1 args2 (conv_fix k f1 f2 cu) | Vcofix (cf1,_,None), Vcofix (cf2,_,None) -> conv_cofix k cf1 cf2 cu - | Vcofix (cf1,_,Some args1), Vcofix (cf2,_,Some args2) -> + | Vcofix (cf1,_,Some args1), Vcofix (cf2,_,Some args2) -> if nargs args1 <> nargs args2 then raise NotConvertible else conv_arguments k args1 args2 (conv_cofix k cf1 cf2 cu) - | Vconstr_const i1, Vconstr_const i2 -> - if i1 = i2 then cu else raise NotConvertible + | Vconstr_const i1, Vconstr_const i2 -> + if i1 = i2 then cu else raise NotConvertible | Vconstr_block b1, Vconstr_block b2 -> let sz = bsize b1 in if btag b1 = btag b2 && sz = bsize b2 then @@ -72,33 +72,33 @@ and conv_whd pb k whd1 whd2 cu = done; !rcu else raise NotConvertible - | Vatom_stk(a1,stk1), Vatom_stk(a2,stk2) -> + | Vatom_stk(a1,stk1), Vatom_stk(a2,stk2) -> conv_atom pb k a1 stk1 a2 stk2 cu - | _, Vatom_stk(Aiddef(_,v),stk) -> + | _, Vatom_stk(Aiddef(_,v),stk) -> conv_whd pb k whd1 (force_whd v stk) cu - | Vatom_stk(Aiddef(_,v),stk), _ -> + | Vatom_stk(Aiddef(_,v),stk), _ -> conv_whd pb k (force_whd v stk) whd2 cu | _, _ -> raise NotConvertible and conv_atom pb k a1 stk1 a2 stk2 cu = match a1, a2 with | Aind (kn1,i1), Aind(kn2,i2) -> - if mind_equiv_infos !infos (kn1,i1) (kn2,i2) && compare_stack stk1 stk2 + if eq_ind (kn1,i1) (kn2,i2) && compare_stack stk1 stk2 then conv_stack k stk1 stk2 cu else raise NotConvertible - | Aid ik1, Aid ik2 -> - if ik1 = ik2 && compare_stack stk1 stk2 then - conv_stack k stk1 stk2 cu + | Aid ik1, Aid ik2 -> + if ik1 = ik2 && compare_stack stk1 stk2 then + conv_stack k stk1 stk2 cu else raise NotConvertible | Aiddef(ik1,v1), Aiddef(ik2,v2) -> begin try - if ik1 = ik2 && compare_stack stk1 stk2 then - conv_stack k stk1 stk2 cu + if eq_table_key ik1 ik2 && compare_stack stk1 stk2 then + conv_stack k stk1 stk2 cu else raise NotConvertible with NotConvertible -> - if oracle_order ik1 ik2 then + if oracle_order 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 @@ -106,15 +106,15 @@ and conv_atom pb k a1 stk1 a2 stk2 cu = conv_whd pb k (force_whd v1 stk1) (Vatom_stk(a2,stk2)) cu | _, Aiddef(ik2,v2) -> conv_whd pb k (Vatom_stk(a1,stk1)) (force_whd v2 stk2) cu - | _, _ -> raise NotConvertible - + | _, _ -> raise NotConvertible + and conv_stack k stk1 stk2 cu = match stk1, stk2 with | [], [] -> cu | Zapp args1 :: stk1, Zapp args2 :: stk2 -> - conv_stack k stk1 stk2 (conv_arguments k args1 args2 cu) + conv_stack k stk1 stk2 (conv_arguments k args1 args2 cu) | Zfix(f1,args1) :: stk1, Zfix(f2,args2) :: stk2 -> - conv_stack k stk1 stk2 + conv_stack k stk1 stk2 (conv_arguments k args1 args2 (conv_fix k f1 f2 cu)) | Zswitch sw1 :: stk1, Zswitch sw2 :: stk2 -> if check_switch sw1 sw2 then @@ -122,7 +122,7 @@ and conv_stack k stk1 stk2 cu = let rcu = ref (conv_val CONV k vt1 vt2 cu) in let b1, b2 = branch_of_switch k sw1, branch_of_switch k sw2 in for i = 0 to Array.length b1 - 1 do - rcu := + rcu := conv_val CONV (k + fst b1.(i)) (snd b1.(i)) (snd b2.(i)) !rcu done; conv_stack k stk1 stk2 !rcu @@ -136,7 +136,7 @@ and conv_fun pb k f1 f2 cu = conv_val pb (k+arity) b1 b2 cu and conv_fix k f1 f2 cu = - if f1 == f2 then cu + if f1 == f2 then cu else if check_fix f1 f2 then let bf1, tf1 = reduce_fix k f1 in @@ -168,34 +168,34 @@ and conv_arguments k args1 args2 cu = else raise NotConvertible let rec conv_eq pb t1 t2 cu = - if t1 == t2 then cu + if t1 == t2 then cu else match kind_of_term t1, kind_of_term t2 with - | Rel n1, Rel n2 -> + | Rel n1, Rel n2 -> if n1 = n2 then cu else raise NotConvertible | Meta m1, Meta m2 -> if m1 = m2 then cu else raise NotConvertible - | Var id1, Var id2 -> + | Var id1, Var id2 -> if id1 = id2 then cu else raise NotConvertible | Sort s1, Sort s2 -> sort_cmp pb s1 s2 cu | Cast (c1,_,_), _ -> conv_eq pb c1 t2 cu | _, Cast (c2,_,_) -> conv_eq pb t1 c2 cu - | Prod (_,t1,c1), Prod (_,t2,c2) -> + | Prod (_,t1,c1), Prod (_,t2,c2) -> conv_eq pb c1 c2 (conv_eq CONV t1 t2 cu) | Lambda (_,t1,c1), Lambda (_,t2,c2) -> conv_eq CONV c1 c2 cu - | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> + | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> conv_eq pb c1 c2 (conv_eq CONV b1 b2 cu) | App (c1,l1), App (c2,l2) -> conv_eq_vect l1 l2 (conv_eq CONV c1 c2 cu) | Evar (e1,l1), Evar (e2,l2) -> if e1 = e2 then conv_eq_vect l1 l2 cu else raise NotConvertible - | Const c1, Const c2 -> - if c1 = c2 then cu else raise NotConvertible - | Ind c1, Ind c2 -> - if c1 = c2 then cu else raise NotConvertible - | Construct c1, Construct c2 -> - if c1 = c2 then cu else raise NotConvertible + | Const c1, Const c2 -> + if eq_constant c1 c2 then cu else raise NotConvertible + | Ind c1, Ind c2 -> + if eq_ind c1 c2 then cu else raise NotConvertible + | Construct c1, Construct c2 -> + if eq_constructor c1 c2 then cu else raise NotConvertible | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) -> let pcu = conv_eq CONV p1 p2 cu in let ccu = conv_eq CONV c1 c2 pcu in @@ -203,7 +203,7 @@ let rec conv_eq pb t1 t2 cu = | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) -> if ln1 = ln2 then conv_eq_vect tl1 tl2 (conv_eq_vect bl1 bl2 cu) else raise NotConvertible - | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) -> + | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) -> if ln1 = ln2 then conv_eq_vect tl1 tl2 (conv_eq_vect bl1 bl2 cu) else raise NotConvertible | _ -> raise NotConvertible @@ -216,7 +216,7 @@ and conv_eq_vect vt1 vt2 cu = rcu := conv_eq CONV vt1.(i) vt2.(i) !rcu done; !rcu else raise NotConvertible - + let vconv pb env t1 t2 = let cu = try conv_eq pb t1 t2 Constraint.empty @@ -227,7 +227,7 @@ let vconv pb env t1 t2 = let cu = conv_val pb (nb_rel env) v1 v2 Constraint.empty in cu in cu - + let _ = Reduction.set_vm_conv vconv let use_vm = ref false @@ -236,7 +236,7 @@ let set_use_vm b = use_vm := b; if b then Reduction.set_default_conv vconv else Reduction.set_default_conv Reduction.conv_cmp - + let use_vm _ = !use_vm diff --git a/kernel/vm.ml b/kernel/vm.ml index 4ed0592d..33893625 100644 --- a/kernel/vm.ml +++ b/kernel/vm.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: vm.ml 10739 2008-04-01 14:45:20Z herbelin $ *) +(* $Id$ *) open Names open Term @@ -39,11 +39,11 @@ external set_transp_values : bool -> unit = "coq_set_transp_value" (* Le code machine ************************) (*******************************************) -type tcode +type tcode let tcode_of_obj v = ((Obj.obj v):tcode) -let fun_code v = tcode_of_obj (Obj.field (Obj.repr v) 0) +let fun_code v = tcode_of_obj (Obj.field (Obj.repr v) 0) + - external mkAccuCode : int -> tcode = "coq_makeaccu" external mkPopStopCode : int -> tcode = "coq_pushpop" @@ -57,21 +57,21 @@ let accumulate = accumulate () external is_accumulate : tcode -> bool = "coq_is_accumulate_code" -let popstop_tbl = ref (Array.init 30 mkPopStopCode) +let popstop_tbl = ref (Array.init 30 mkPopStopCode) let popstop_code i = let len = Array.length !popstop_tbl in - if i < len then !popstop_tbl.(i) + if i < len then !popstop_tbl.(i) else begin popstop_tbl := Array.init (i+10) (fun j -> if j < len then !popstop_tbl.(j) else mkPopStopCode j); - !popstop_tbl.(i) + !popstop_tbl.(i) end let stop = popstop_code 0 - + (******************************************************) (* Types de donnees abstraites et fonctions associees *) (******************************************************) @@ -81,23 +81,23 @@ let val_of_obj v = ((Obj.obj v):values) let crasy_val = (val_of_obj (Obj.repr 0)) (* Abstract data *) -type vprod +type vprod type vfun type vfix type vcofix type vblock type arguments -type vm_env +type vm_env type vstack = values array type vswitch = { - sw_type_code : tcode; - sw_code : tcode; + sw_type_code : tcode; + sw_code : tcode; sw_annot : annot_switch; sw_stk : vstack; sw_env : vm_env - } + } (* Representation des types abstraits: *) (* + Les produits : *) @@ -105,10 +105,10 @@ type vswitch = { (* dom : values, codom : vfun *) (* *) (* + Les fonctions ont deux representations possibles : *) -(* - fonction non applique : vf = Ct_[ C | fv1 | ... | fvn] *) +(* - fonction non applique : vf = Ct_[ C | fv1 | ... | fvn] *) (* C:tcode, fvi : values *) (* Remarque : il n'y a pas de difference entre la fct et son *) -(* environnement. *) +(* environnement. *) (* - Application partielle : Ct_[Restart:C| vf | arg1 | ... argn] *) (* *) (* + Les points fixes : *) @@ -138,7 +138,7 @@ type vswitch = { (* -- 4_[accu|vswitch] : un case bloque par un accu *) (* -- 5_[fcofix] : une fonction de cofix *) (* -- 6_[fcofix|val] : une fonction de cofix, val represente *) -(* la valeur de la reduction de la fct applique a arg1 ... argn *) +(* la valeur de la reduction de la fct applique a arg1 ... argn *) (* Le type [arguments] est utiliser de maniere abstraite comme un *) (* tableau, il represente la structure de donnee suivante : *) (* tag[ _ | _ |v1|... | vn] *) @@ -146,7 +146,7 @@ type vswitch = { (* Ne pas changer ce type sans modifier le code C, *) (* en particulier le fichier "coq_values.h" *) -type atom = +type atom = | Aid of id_key | Aiddef of id_key * values | Aind of inductive @@ -164,7 +164,7 @@ type to_up = values type whd = | Vsort of sorts - | Vprod of vprod + | Vprod of vprod | Vfun of vfun | Vfix of vfix * arguments option | Vcofix of vcofix * to_up * arguments option @@ -177,16 +177,16 @@ type whd = (*************************************************) let rec whd_accu a stk = - let stk = + let stk = if Obj.size a = 2 then stk else Zapp (Obj.obj a) :: stk in let at = Obj.field a 1 in match Obj.tag at with - | i when i <= 2 -> + | i when i <= 2 -> Vatom_stk(Obj.magic at, stk) | 3 (* fix_app tag *) -> let fa = Obj.field at 1 in - let zfix = + let zfix = Zfix (Obj.obj (Obj.field fa 1), Obj.obj fa) in whd_accu (Obj.field at 0) (zfix :: stk) | 4 (* switch tag *) -> @@ -194,7 +194,7 @@ let rec whd_accu a stk = whd_accu (Obj.field at 0) (zswitch :: stk) | 5 (* cofix_tag *) -> begin match stk with - | [] -> + | [] -> let vcfx = Obj.obj (Obj.field at 0) in let to_up = Obj.obj a in Vcofix(vcfx, to_up, None) @@ -210,7 +210,7 @@ let rec whd_accu a stk = let vcofix = Obj.obj (Obj.field at 0) in let res = Obj.obj a in Vcofix(vcofix, res, None) - | [Zapp args] -> + | [Zapp args] -> let vcofix = Obj.obj (Obj.field at 0) in let res = Obj.obj a in Vcofix(vcofix, res, Some args) @@ -221,18 +221,18 @@ let rec whd_accu a stk = external kind_of_closure : Obj.t -> int = "coq_kind_of_closure" let whd_val : values -> whd = - fun v -> - let o = Obj.repr v in + fun v -> + let o = Obj.repr v in if Obj.is_int o then Vconstr_const (Obj.obj o) - else + else let tag = Obj.tag o in if tag = accu_tag then ( if Obj.size o = 1 then Obj.obj o (* sort *) - else + else if is_accumulate (fun_code o) then whd_accu o [] else (Vprod(Obj.obj o))) - else + else if tag = Obj.closure_tag || tag = Obj.infix_tag then ( match kind_of_closure o with | 0 -> Vfun(Obj.obj o) @@ -241,7 +241,7 @@ let whd_val : values -> whd = | 3 -> Vatom_stk(Aid(RelKey(int_tcode (fun_code o) 1)), []) | _ -> Util.anomaly "Vm.whd : kind_of_closure does not work") else Vconstr_block(Obj.obj o) - + (************************************************) @@ -263,16 +263,16 @@ external interprete : tcode -> values -> vm_env -> int -> values = (* Functions over arguments *) let nargs : arguments -> int = fun args -> (Obj.size (Obj.repr args)) - 2 -let arg args i = - if 0 <= i && i < (nargs args) then +let arg args i = + if 0 <= i && i < (nargs args) then val_of_obj (Obj.field (Obj.repr args) (i+2)) - else raise (Invalid_argument + else raise (Invalid_argument ("Vm.arg size = "^(string_of_int (nargs args))^ " acces "^(string_of_int i))) let apply_arguments vf vargs = let n = nargs vargs in - if n = 0 then vf + if n = 0 then vf else begin push_ra stop; @@ -283,7 +283,7 @@ let apply_arguments vf vargs = let apply_vstack vf vstk = let n = Array.length vstk in if n = 0 then vf - else + else begin push_ra stop; push_vstack vstk; @@ -295,23 +295,23 @@ let apply_vstack vf vstk = (**********************************************) let obj_of_atom : atom -> Obj.t = - fun a -> + fun a -> let res = Obj.new_block accu_tag 2 in Obj.set_field res 0 (Obj.repr accumulate); Obj.set_field res 1 (Obj.repr a); - res + res (* obj_of_str_const : structured_constant -> Obj.t *) let rec obj_of_str_const str = - match str with + match str with | Const_sorts s -> Obj.repr (Vsort s) | Const_ind ind -> obj_of_atom (Aind ind) | Const_b0 tag -> Obj.repr tag | Const_bn(tag, args) -> let len = Array.length args in let res = Obj.new_block tag len in - for i = 0 to len - 1 do - Obj.set_field res i (obj_of_str_const args.(i)) + for i = 0 to len - 1 do + Obj.set_field res i (obj_of_str_const args.(i)) done; res @@ -324,8 +324,8 @@ let val_of_atom a = val_of_obj (obj_of_atom a) let idkey_tbl = Hashtbl.create 31 let val_of_idkey key = - try Hashtbl.find idkey_tbl key - with Not_found -> + try Hashtbl.find idkey_tbl key + with Not_found -> let v = val_of_atom (Aid key) in Hashtbl.add idkey_tbl key v; v @@ -335,14 +335,16 @@ let val_of_rel_def k v = val_of_atom(Aiddef(RelKey k, v)) let val_of_named id = val_of_idkey (VarKey id) let val_of_named_def id v = val_of_atom(Aiddef(VarKey id, v)) - + let val_of_constant c = val_of_idkey (ConstKey c) -let val_of_constant_def n c v = +let val_of_constant_def n c v = let res = Obj.new_block accu_tag 2 in Obj.set_field res 0 (Obj.repr (mkAccuCond n)); Obj.set_field res 1 (Obj.repr (Aiddef(ConstKey c, v))); val_of_obj res +external val_of_annot_switch : annot_switch -> values = "%identity" + let mkrel_vstack k arity = let max = k + arity - 1 in Array.init arity (fun i -> val_of_rel (max - i)) @@ -354,7 +356,7 @@ let mkrel_vstack k arity = (* Functions over products *) -let dom : vprod -> values = fun p -> val_of_obj (Obj.field (Obj.repr p) 0) +let dom : vprod -> values = fun p -> val_of_obj (Obj.field (Obj.repr p) 0) let codom : vprod -> vfun = fun p -> (Obj.obj (Obj.field (Obj.repr p) 1)) (* Functions over vfun *) @@ -383,7 +385,7 @@ let current_fix vf = - (offset (Obj.repr vf) / 2) let unsafe_fb_code fb i = tcode_of_obj (Obj.field (Obj.repr fb) (2 * i)) let unsafe_rec_arg fb i = int_tcode (unsafe_fb_code fb i) 1 - + let rec_args vf = let fb = first (Obj.repr vf) in let size = Obj.size (last fb) in @@ -391,7 +393,7 @@ let rec_args vf = exception FALSE -let check_fix f1 f2 = +let check_fix f1 f2 = let i1, i2 = current_fix f1, current_fix f2 in (* Verification du point de depart *) if i1 = i2 then @@ -407,22 +409,22 @@ let check_fix f1 f2 = done; true with FALSE -> false - else false + else false else false (* Functions over vfix *) external atom_rel : unit -> atom array = "get_coq_atom_tbl" external realloc_atom_rel : int -> unit = "realloc_coq_atom_tbl" -let relaccu_tbl = +let relaccu_tbl = let atom_rel = atom_rel() in let len = Array.length atom_rel in for i = 0 to len - 1 do atom_rel.(i) <- Aid (RelKey i) done; - ref (Array.init len mkAccuCode) + ref (Array.init len mkAccuCode) let relaccu_code i = let len = Array.length !relaccu_tbl in - if i < len then !relaccu_tbl.(i) + if i < len then !relaccu_tbl.(i) else begin realloc_atom_rel i; @@ -432,7 +434,7 @@ let relaccu_code i = relaccu_tbl := Array.init nl (fun j -> if j < len then !relaccu_tbl.(j) else mkAccuCode j); - !relaccu_tbl.(i) + !relaccu_tbl.(i) end let reduce_fix k vf = @@ -441,8 +443,8 @@ let reduce_fix k vf = let fc_typ = ((Obj.obj (last fb)) : tcode array) in let ndef = Array.length fc_typ in let et = offset_closure fb (2*(ndef - 1)) in - let ftyp = - Array.map + let ftyp = + Array.map (fun c -> interprete c crasy_val (Obj.magic et) 0) fc_typ in (* Construction de l' environnement des corps des points fixes *) let e = Obj.dup fb in @@ -455,12 +457,12 @@ let reduce_fix k vf = let res = Obj.new_block Obj.closure_tag 2 in Obj.set_field res 0 (Obj.repr c); Obj.set_field res 1 (offset_closure e (2*i)); - ((Obj.obj res) : vfun) in + ((Obj.obj res) : vfun) in (Array.init ndef fix_body, ftyp) - + (* Functions over vcofix *) -let get_fcofix vcf i = +let get_fcofix vcf i = match whd_val (Obj.obj (Obj.field (Obj.repr vcf) (i+1))) with | Vcofix(vcfi, _, _) -> vcfi | _ -> assert false @@ -482,29 +484,29 @@ let check_cofix vcf1 vcf2 = let reduce_cofix k vcf = let fc_typ = ((Obj.obj (last (Obj.repr vcf))) : tcode array) in let ndef = Array.length fc_typ in - let ftyp = + let ftyp = Array.map (fun c -> interprete c crasy_val (Obj.magic vcf) 0) fc_typ in (* Construction de l'environnement des corps des cofix *) - let e = Obj.dup (Obj.repr vcf) in + let e = Obj.dup (Obj.repr vcf) in for i = 0 to ndef - 1 do - Obj.set_field e (i+1) (Obj.repr (val_of_rel (k+i))) + Obj.set_field e (i+1) (Obj.repr (val_of_rel (k+i))) done; - + let cofix_body i = let vcfi = get_fcofix vcf i in let c = Obj.field (Obj.repr vcfi) 0 in - Obj.set_field e 0 c; + Obj.set_field e 0 c; let atom = Obj.new_block cofix_tag 1 in let self = Obj.new_block accu_tag 2 in Obj.set_field self 0 (Obj.repr accumulate); Obj.set_field self 1 (Obj.repr atom); - apply_vstack (Obj.obj e) [|Obj.obj self|] in + apply_vstack (Obj.obj e) [|Obj.obj self|] in (Array.init ndef cofix_body, ftyp) (* Functions over vblock *) - + let btag : vblock -> int = fun b -> Obj.tag (Obj.repr b) let bsize : vblock -> int = fun b -> Obj.size (Obj.repr b) let bfield b i = @@ -514,15 +516,15 @@ let bfield b i = (* Functions over vswitch *) -let check_switch sw1 sw2 = sw1.sw_annot.rtbl = sw2.sw_annot.rtbl - +let check_switch sw1 sw2 = sw1.sw_annot.rtbl = sw2.sw_annot.rtbl + let case_info sw = sw.sw_annot.ci - -let type_of_switch sw = + +let type_of_switch sw = push_vstack sw.sw_stk; - interprete sw.sw_type_code crasy_val sw.sw_env 0 - -let branch_arg k (tag,arity) = + interprete sw.sw_type_code crasy_val sw.sw_env 0 + +let branch_arg k (tag,arity) = if arity = 0 then ((Obj.magic tag):values) else let b = Obj.new_block tag arity in @@ -533,38 +535,38 @@ let branch_arg k (tag,arity) = let apply_switch sw arg = let tc = sw.sw_annot.tailcall in - if tc then + if tc then (push_ra stop;push_vstack sw.sw_stk) - else + else (push_vstack sw.sw_stk; push_ra (popstop_code (Array.length sw.sw_stk))); interprete sw.sw_code arg sw.sw_env 0 - + let branch_of_switch k sw = let eval_branch (_,arity as ta) = let arg = branch_arg k ta in let v = apply_switch sw arg in (arity, v) - in + in Array.map eval_branch sw.sw_annot.rtbl - + (* Evaluation *) -let is_accu v = +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 + Obj.is_block o && Obj.tag o = accu_tag && + fun_code v == accumulate && Obj.tag (Obj.field o 1) < cofix_tag -let rec whd_stack v stk = +let rec whd_stack v stk = match stk with | [] -> whd_val v | Zapp args :: stkt -> whd_stack (apply_arguments v args) stkt - | Zfix (f,args) :: stkt -> + | Zfix (f,args) :: stkt -> let o = Obj.repr v in if Obj.is_block o && Obj.tag o = accu_tag then whd_accu (Obj.repr v) stk - else + else let v', stkt = match stkt with | Zapp args' :: stkt -> @@ -573,30 +575,30 @@ let rec whd_stack v stk = push_val v; push_arguments args; let v' = - interprete (fun_code f) (Obj.magic f) (Obj.magic f) + interprete (fun_code f) (Obj.magic f) (Obj.magic f) (nargs args+ nargs args') in v', stkt - | _ -> + | _ -> push_ra stop; push_val v; push_arguments args; let v' = - interprete (fun_code f) (Obj.magic f) (Obj.magic f) + interprete (fun_code f) (Obj.magic f) (Obj.magic f) (nargs args) in v', stkt in whd_stack v' stkt - | Zswitch sw :: stkt -> + | Zswitch sw :: stkt -> let o = Obj.repr v in if Obj.is_block o && Obj.tag o = accu_tag then if Obj.tag (Obj.field o 1) < cofix_tag then whd_accu (Obj.repr v) stk else - let to_up = + let to_up = match whd_accu (Obj.repr v) [] with | Vcofix (_, to_up, _) -> to_up | _ -> assert false in whd_stack (apply_switch sw to_up) stkt - else whd_stack (apply_switch sw v) stkt + else whd_stack (apply_switch sw v) stkt let rec force_whd v stk = match whd_stack v stk with diff --git a/kernel/vm.mli b/kernel/vm.mli index 279ac937..5ecc8d99 100644 --- a/kernel/vm.mli +++ b/kernel/vm.mli @@ -9,11 +9,11 @@ val set_drawinstr : unit -> unit val transp_values : unit -> bool val set_transp_values : bool -> unit (* le code machine *) -type tcode +type tcode (* Les valeurs ***********) -type vprod +type vprod type vfun type vfix type vcofix @@ -21,7 +21,7 @@ type vblock type vswitch type arguments -type atom = +type atom = | Aid of id_key | Aiddef of id_key * values | Aind of inductive @@ -39,30 +39,32 @@ type to_up type whd = | Vsort of sorts - | Vprod of vprod + | Vprod of vprod | Vfun of vfun | Vfix of vfix * arguments option | Vcofix of vcofix * to_up * arguments option | Vconstr_const of int | Vconstr_block of vblock | Vatom_stk of atom * stack - + (** Constructors *) val val_of_str_const : structured_constant -> values -val val_of_rel : int -> values -val val_of_rel_def : int -> values -> values +val val_of_rel : int -> values +val val_of_rel_def : int -> values -> values val val_of_named : identifier -> values val val_of_named_def : identifier -> values -> values -val val_of_constant : constant -> values +val val_of_constant : constant -> values 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 @@ -71,18 +73,18 @@ val dom : vprod -> values val codom : vprod -> vfun (* Function *) -val body_of_vfun : int -> vfun -> values +val body_of_vfun : int -> vfun -> values val decompose_vfun2 : int -> vfun -> vfun -> int * values * values (* Fix *) val current_fix : vfix -> int val check_fix : vfix -> vfix -> bool -val rec_args : vfix -> int array +val rec_args : vfix -> int array val reduce_fix : int -> vfix -> vfun array * values array (* bodies , types *) (* CoFix *) -val current_cofix : vcofix -> int +val current_cofix : vcofix -> int val check_cofix : vcofix -> vcofix -> bool val reduce_cofix : int -> vcofix -> values array * values array (* bodies , types *) |