From 6b649aba925b6f7462da07599fe67ebb12a3460e Mon Sep 17 00:00:00 2001 From: Samuel Mimram Date: Wed, 28 Jul 2004 21:54:47 +0000 Subject: Imported Upstream version 8.0pl1 --- kernel/closure.ml | 1140 +++++++++++++++++++++++++++++++++++++++++++++ kernel/closure.mli | 207 +++++++++ kernel/conv_oracle.ml | 43 ++ kernel/conv_oracle.mli | 35 ++ kernel/cooking.ml | 172 +++++++ kernel/cooking.mli | 42 ++ kernel/declarations.ml | 193 ++++++++ kernel/declarations.mli | 141 ++++++ kernel/doc.tex | 11 + kernel/entries.ml | 101 ++++ kernel/entries.mli | 101 ++++ kernel/environ.ml | 295 ++++++++++++ kernel/environ.mli | 159 +++++++ kernel/esubst.ml | 137 ++++++ kernel/esubst.mli | 42 ++ kernel/indtypes.ml | 548 ++++++++++++++++++++++ kernel/indtypes.mli | 46 ++ kernel/inductive.ml | 831 +++++++++++++++++++++++++++++++++ kernel/inductive.mli | 71 +++ kernel/mod_typing.ml | 324 +++++++++++++ kernel/mod_typing.mli | 25 + kernel/modops.ml | 245 ++++++++++ kernel/modops.mli | 96 ++++ kernel/names.ml | 355 ++++++++++++++ kernel/names.mli | 176 +++++++ kernel/reduction.ml | 412 ++++++++++++++++ kernel/reduction.mli | 55 +++ kernel/safe_typing.ml | 572 +++++++++++++++++++++++ kernel/safe_typing.mli | 127 +++++ kernel/sign.ml | 192 ++++++++ kernel/sign.mli | 95 ++++ kernel/subtyping.ml | 246 ++++++++++ kernel/subtyping.mli | 19 + kernel/term.ml | 1186 +++++++++++++++++++++++++++++++++++++++++++++++ kernel/term.mli | 525 +++++++++++++++++++++ kernel/term_typing.ml | 118 +++++ kernel/term_typing.mli | 34 ++ kernel/type_errors.ml | 114 +++++ kernel/type_errors.mli | 103 ++++ kernel/typeops.ml | 489 +++++++++++++++++++ kernel/typeops.mli | 92 ++++ kernel/univ.ml | 469 +++++++++++++++++++ kernel/univ.mli | 61 +++ 43 files changed, 10445 insertions(+) create mode 100644 kernel/closure.ml create mode 100644 kernel/closure.mli create mode 100644 kernel/conv_oracle.ml create mode 100644 kernel/conv_oracle.mli create mode 100644 kernel/cooking.ml create mode 100644 kernel/cooking.mli create mode 100644 kernel/declarations.ml create mode 100644 kernel/declarations.mli create mode 100644 kernel/doc.tex create mode 100644 kernel/entries.ml create mode 100644 kernel/entries.mli create mode 100644 kernel/environ.ml create mode 100644 kernel/environ.mli create mode 100644 kernel/esubst.ml create mode 100644 kernel/esubst.mli create mode 100644 kernel/indtypes.ml create mode 100644 kernel/indtypes.mli create mode 100644 kernel/inductive.ml create mode 100644 kernel/inductive.mli create mode 100644 kernel/mod_typing.ml create mode 100644 kernel/mod_typing.mli create mode 100644 kernel/modops.ml create mode 100644 kernel/modops.mli create mode 100644 kernel/names.ml create mode 100644 kernel/names.mli create mode 100644 kernel/reduction.ml create mode 100644 kernel/reduction.mli create mode 100644 kernel/safe_typing.ml create mode 100644 kernel/safe_typing.mli create mode 100644 kernel/sign.ml create mode 100644 kernel/sign.mli create mode 100644 kernel/subtyping.ml create mode 100644 kernel/subtyping.mli create mode 100644 kernel/term.ml create mode 100644 kernel/term.mli create mode 100644 kernel/term_typing.ml create mode 100644 kernel/term_typing.mli create mode 100644 kernel/type_errors.ml create mode 100644 kernel/type_errors.mli create mode 100644 kernel/typeops.ml create mode 100644 kernel/typeops.mli create mode 100644 kernel/univ.ml create mode 100644 kernel/univ.mli (limited to 'kernel') diff --git a/kernel/closure.ml b/kernel/closure.ml new file mode 100644 index 00000000..1a635ccf --- /dev/null +++ b/kernel/closure.ml @@ -0,0 +1,1140 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* red_kind + val fVAR : identifier -> red_kind + val no_red : reds + val red_add : reds -> red_kind -> reds + val red_sub : reds -> red_kind -> reds + val red_add_transparent : reds -> transparent_state -> reds + val mkflags : red_kind list -> reds + val red_set : reds -> red_kind -> bool + val red_get_const : reds -> bool * evaluable_global_reference list +end + +module RedFlags = (struct + + (* [r_const=(true,cl)] means all constants but those in [cl] *) + (* [r_const=(false,cl)] means only those in [cl] *) + (* [r_delta=true] just mean [r_const=(true,[])] *) + + type reds = { + r_beta : bool; + r_delta : bool; + r_const : transparent_state; + r_zeta : bool; + r_evar : bool; + r_iota : bool } + + type red_kind = BETA | DELTA | IOTA | ZETA + | CONST of constant | VAR of identifier + let fBETA = BETA + let fDELTA = DELTA + let fIOTA = IOTA + let fZETA = ZETA + let fCONST kn = CONST kn + let fVAR id = VAR id + let no_red = { + r_beta = false; + r_delta = false; + r_const = all_opaque; + r_zeta = false; + r_evar = false; + r_iota = false } + + let red_add red = function + | BETA -> { red with r_beta = true } + | DELTA -> { red with r_delta = true; r_const = all_transparent } + | CONST kn -> + let (l1,l2) = red.r_const in + { red with r_const = l1, KNpred.add kn l2 } + | IOTA -> { red with r_iota = true } + | ZETA -> { red with r_zeta = true } + | VAR id -> + let (l1,l2) = red.r_const in + { red with r_const = Idpred.add id l1, l2 } + + let red_sub red = function + | BETA -> { red with r_beta = false } + | DELTA -> { red with r_delta = false } + | CONST kn -> + let (l1,l2) = red.r_const in + { red with r_const = l1, KNpred.remove kn l2 } + | IOTA -> { red with r_iota = false } + | ZETA -> { red with r_zeta = false } + | VAR id -> + let (l1,l2) = red.r_const in + { red with r_const = Idpred.remove id l1, l2 } + + let red_add_transparent red 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 -> + let (_,l) = red.r_const in + let c = KNpred.mem kn l in + incr_cnt c delta + | VAR id -> (* En attendant d'avoir des kn pour les Var *) + let (l,_) = red.r_const in + let c = Idpred.mem id l in + incr_cnt c delta + | ZETA -> incr_cnt red.r_zeta zeta + | IOTA -> incr_cnt red.r_iota iota + | DELTA -> (* Used for Rel/Var defined in context *) + incr_cnt red.r_delta delta + + let red_get_const red = + let p1,p2 = red.r_const in + let (b1,l1) = Idpred.elements p1 in + let (b2,l2) = KNpred.elements p2 in + if b1=b2 then + let l1' = List.map (fun x -> EvalVarRef x) l1 in + let l2' = List.map (fun x -> EvalConstRef x) l2 in + (b1, l1' @ l2') + else error "unrepresentable pair of predicate" + +end : RedFlagsSig) + +open RedFlags + +let betadeltaiota = mkflags [fBETA;fDELTA;fZETA;fIOTA] +let betadeltaiotanolet = mkflags [fBETA;fDELTA;fIOTA] +let betaiota = mkflags [fBETA;fIOTA] +let beta = mkflags [fBETA] +let betaiotazeta = mkflags [fBETA;fIOTA;fZETA] +let unfold_red kn = + let flag = match kn with + | EvalVarRef id -> fVAR id + | EvalConstRef kn -> fCONST kn + in (* Remove fZETA for finer behaviour ? *) + mkflags [fBETA;flag;fIOTA;fZETA] + +(************************* Obsolète +(* [r_const=(true,cl)] means all constants but those in [cl] *) +(* [r_const=(false,cl)] means only those in [cl] *) +type reds = { + r_beta : bool; + r_const : bool * constant_path list * identifier list; + r_zeta : bool; + r_evar : bool; + r_iota : bool } + +let betadeltaiota_red = { + r_beta = true; + r_const = true,[],[]; + r_zeta = true; + r_evar = true; + r_iota = true } + +let betaiota_red = { + r_beta = true; + r_const = false,[],[]; + r_zeta = false; + r_evar = false; + r_iota = true } + +let beta_red = { + r_beta = true; + r_const = false,[],[]; + r_zeta = false; + r_evar = false; + r_iota = false } + +let no_red = { + r_beta = false; + r_const = false,[],[]; + r_zeta = false; + r_evar = false; + r_iota = false } + +let betaiotazeta_red = { + r_beta = true; + r_const = false,[],[]; + r_zeta = true; + r_evar = false; + r_iota = true } + +let unfold_red kn = + let c = match kn with + | EvalVarRef id -> false,[],[id] + | EvalConstRef kn -> false,[kn],[] + in { + r_beta = true; + r_const = c; + r_zeta = true; (* false for finer behaviour ? *) + r_evar = false; + r_iota = true } + +(* Sets of reduction kinds. + Main rule: delta implies all consts (both global (= by + kernel_name) and local (= by Rel or Var)), all evars, and zeta (= letin's). + Rem: reduction of a Rel/Var bound to a term is Delta, but reduction of + a LetIn expression is Letin reduction *) + +type red_kind = + BETA | DELTA | ZETA | IOTA + | CONST of constant_path list | CONSTBUT of constant_path list + | VAR of identifier | VARBUT of identifier + +let rec red_add red = function + | BETA -> { red with r_beta = true } + | DELTA -> + (match red.r_const with + | _,_::_,[] | _,[],_::_ -> error "Conflict in the reduction flags" + | _ -> { red with r_const = true,[],[]; r_zeta = true; r_evar = true }) + | CONST cl -> + (match red.r_const with + | true,_,_ -> error "Conflict in the reduction flags" + | _,l1,l2 -> { red with r_const = false, list_union cl l1, l2 }) + | CONSTBUT cl -> + (match red.r_const with + | false,_::_,_ | false,_,_::_ -> + error "Conflict in the reduction flags" + | _,l1,l2 -> + { red with r_const = true, list_union cl l1, l2; + r_zeta = true; r_evar = true }) + | IOTA -> { red with r_iota = true } + | ZETA -> { red with r_zeta = true } + | VAR id -> + (match red.r_const with + | true,_,_ -> error "Conflict in the reduction flags" + | _,l1,l2 -> { red with r_const = false, l1, list_union [id] l2 }) + | VARBUT cl -> + (match red.r_const with + | false,_::_,_ | false,_,_::_ -> + error "Conflict in the reduction flags" + | _,l1,l2 -> + { red with r_const = true, l1, list_union [cl] l2; + r_zeta = true; r_evar = true }) + +let red_delta_set red = + let b,_,_ = red.r_const in b + +let red_local_const = red_delta_set + +(* to know if a redex is allowed, only a subset of red_kind is used ... *) +let red_set red = function + | BETA -> incr_cnt red.r_beta beta + | CONST [kn] -> + let (b,l,_) = red.r_const in + let c = List.mem kn l in + incr_cnt ((b & not c) or (c & not b)) delta + | VAR id -> (* En attendant d'avoir des kn pour les Var *) + let (b,_,l) = red.r_const in + let c = List.mem id l in + incr_cnt ((b & not c) or (c & not b)) delta + | ZETA -> incr_cnt red.r_zeta zeta + | EVAR -> incr_cnt red.r_zeta evar + | IOTA -> incr_cnt red.r_iota iota + | DELTA -> red_delta_set red (*Used for Rel/Var defined in context*) + (* Not for internal use *) + | CONST _ | CONSTBUT _ | VAR _ | VARBUT _ -> failwith "not implemented" + +(* Gives the constant list *) +let red_get_const red = + let b,l1,l2 = red.r_const in + let l1' = List.map (fun x -> EvalConstRef x) l1 in + let l2' = List.map (fun x -> EvalVarRef x) l2 in + b, l1' @ l2' +fin obsolète **************) +(* specification of the reduction function *) + + +(* Flags of reduction and cache of constants: 'a is a type that may be + * mapped to constr. 'a infos implements a cache for constants and + * abstractions, storing a representation (of type 'a) of the body of + * this constant or abstraction. + * * i_tab is the cache table of the results + * * i_repr is the function to get the representation from the current + * state of the cache and the body of the constant. The result + * is stored in the table. + * * i_rels = (4,[(1,c);(3,d)]) means there are 4 free rel variables + * and only those with index 1 and 3 have bodies which are c and d resp. + * * i_vars is the list of _defined_ named variables. + * + * ref_value_cache searchs in the tab, otherwise uses i_repr to + * compute the result and store it in the table. If the constant can't + * be unfolded, returns None, but does not store this failure. * This + * doesn't take the RESET into account. You mustn't keep such a table + * after a Reset. * This type is not exported. Only its two + * instantiations (cbv or lazy) are. + *) + +type table_key = + | ConstKey of constant + | VarKey of identifier + | FarRelKey of int + (* FarRel: index in the rel_context part of _initial_ environment *) + +type 'a infos = { + i_flags : reds; + i_repr : 'a infos -> constr -> 'a; + i_env : env; + i_rels : int * (int * constr) list; + i_vars : (identifier * constr) list; + i_tab : (table_key, 'a) Hashtbl.t } + +let info_flags info = info.i_flags + +let ref_value_cache info ref = + try + Some (Hashtbl.find info.i_tab ref) + with Not_found -> + try + let body = + match ref with + | FarRelKey n -> + let (s,l) = info.i_rels in lift n (List.assoc (s-n) l) + | VarKey id -> List.assoc id info.i_vars + | ConstKey cst -> constant_value info.i_env cst + in + let v = info.i_repr info body in + Hashtbl.add info.i_tab ref v; + Some v + with + | Not_found (* List.assoc *) + | NotEvaluableConst _ (* Const *) + -> None + +let defined_vars flags env = +(* if red_local_const (snd flags) then*) + fold_named_context + (fun env (id,b,t) e -> + match b with + | None -> e + | Some body -> (id, body)::e) + env ~init:[] +(* else []*) + +let defined_rels flags env = +(* if red_local_const (snd flags) then*) + fold_rel_context + (fun env (id,b,t) (i,subs) -> + match b with + | None -> (i+1, subs) + | Some body -> (i+1, (i,body) :: subs)) + env ~init:(0,[]) +(* else (0,[])*) + + +let rec mind_equiv info kn1 kn2 = + kn1 = kn2 || + match (lookup_mind kn1 info.i_env).mind_equiv with + Some kn1' -> mind_equiv info kn2 kn1' + | None -> match (lookup_mind kn2 info.i_env).mind_equiv with + Some kn2' -> mind_equiv info kn2' kn1 + | None -> false + +let create mk_cl flgs env = + { i_flags = flgs; + i_repr = mk_cl; + i_env = env; + i_rels = defined_rels flgs env; + i_vars = defined_vars flgs env; + i_tab = Hashtbl.create 17 } + + +(**********************************************************************) +(* The type of (machine) stacks (= lambda-bar-calculus' contexts) *) + +type 'a stack_member = + | Zapp of 'a list + | Zcase of case_info * 'a * 'a array + | Zfix of 'a * 'a stack + | Zshift of int + | Zupdate of 'a + +and 'a stack = 'a stack_member list + +let empty_stack = [] +let append_stack_list = function + | ([],s) -> s + | (l1, Zapp l :: s) -> Zapp (l1@l) :: s + | (l1, s) -> Zapp l1 :: s +let append_stack v s = append_stack_list (Array.to_list v, s) + +(* Collapse the shifts in the stack *) +let zshift n s = + match (n,s) with + (0,_) -> s + | (_,Zshift(k)::s) -> Zshift(n+k)::s + | _ -> Zshift(n)::s + +let rec stack_args_size = function + | Zapp l::s -> List.length l + stack_args_size s + | Zshift(_)::s -> stack_args_size s + | Zupdate(_)::s -> stack_args_size s + | _ -> 0 + +(* When used as an argument stack (only Zapp can appear) *) +let rec decomp_stack = function + | Zapp[v]::s -> Some (v, s) + | Zapp(v::l)::s -> Some (v, (Zapp l :: s)) + | Zapp [] :: s -> decomp_stack s + | _ -> None +let rec decomp_stackn = function + | Zapp [] :: s -> decomp_stackn s + | Zapp l :: s -> (Array.of_list l, s) + | _ -> assert false +let array_of_stack s = + let rec stackrec = function + | [] -> [] + | Zapp args :: s -> args :: (stackrec s) + | _ -> assert false + in Array.of_list (List.concat (stackrec s)) +let rec list_of_stack = function + | [] -> [] + | Zapp args :: s -> args @ (list_of_stack s) + | _ -> assert false +let rec app_stack = function + | f, [] -> f + | f, (Zapp [] :: s) -> app_stack (f, s) + | f, (Zapp args :: s) -> + app_stack (applist (f, args), s) + | _ -> assert false +let rec stack_assign s p c = match s with + | Zapp args :: s -> + let q = List.length args in + if p >= q then + Zapp args :: stack_assign s (p-q) c + else + (match list_chop p args with + (bef, _::aft) -> Zapp (bef@c::aft) :: s + | _ -> assert false) + | _ -> s +let rec stack_tail p s = + if p = 0 then s else + match s with + | Zapp args :: s -> + let q = List.length args in + if p >= q then stack_tail (p-q) s + else Zapp (list_skipn p args) :: s + | _ -> failwith "stack_tail" +let rec stack_nth s p = match s with + | Zapp args :: s -> + let q = List.length args in + if p >= q then stack_nth s (p-q) + else List.nth args p + | _ -> raise Not_found + + +(**********************************************************************) +(* Lazy reduction: the one used in kernel operations *) + +(* type of shared terms. fconstr and frterm are mutually recursive. + * Clone of the constr structure, but completely mutable, and + * annotated with reduction state (reducible or not). + * - FLIFT is a delayed shift; allows sharing between 2 lifted copies + * of a given term. + * - FCLOS is a delayed substitution applied to a constr + * - FLOCKED is used to erase the content of a reference that must + * be updated. This is to allow the garbage collector to work + * before the term is computed. + *) + +(* Norm means the term is fully normalized and cannot create a redex + when substituted + Cstr means the term is in head normal form and that it can + create a redex when substituted (i.e. constructor, fix, lambda) + Whnf means we reached the head normal form and that it cannot + create a redex when substituted + Red is used for terms that might be reduced +*) +type red_state = Norm | Cstr | Whnf | Red + +let neutr = function + | (Whnf|Norm) -> Whnf + | (Red|Cstr) -> Red + +type fconstr = { + mutable norm: red_state; + mutable term: fterm } + +and fterm = + | FRel of int + | FAtom of constr (* Metas and Sorts *) + | FCast of fconstr * fconstr + | FFlex of table_key + | FInd of inductive + | FConstruct of constructor + | FApp of fconstr * fconstr array + | FFix of fixpoint * fconstr subs + | FCoFix of cofixpoint * fconstr subs + | FCases of case_info * fconstr * fconstr * fconstr array + | FLambda of int * (name * constr) list * constr * fconstr subs + | FProd of name * fconstr * fconstr + | FLetIn of name * fconstr * fconstr * constr * fconstr subs + | FEvar of existential_key * fconstr array + | FLIFT of int * fconstr + | FCLOS of constr * fconstr subs + | FLOCKED + +let fterm_of v = v.term +let set_norm v = v.norm <- Norm +let is_val v = v.norm = Norm + +(* Could issue a warning if no is still Red, pointing out that we loose + sharing. *) +let update v1 (no,t) = + if !share then + (v1.norm <- no; + v1.term <- t; + v1) + else {norm=no;term=t} + +(* Lifting. Preserves sharing (useful only for cell with norm=Red). + lft_fconstr always create a new cell, while lift_fconstr avoids it + when the lift is 0. *) +let rec lft_fconstr n ft = + match ft.term with + | (FInd _|FConstruct _|FFlex(ConstKey _|VarKey _)|FAtom _) -> ft + | FRel i -> {norm=Norm;term=FRel(i+n)} + | FLambda(k,tys,f,e) -> {norm=Cstr; term=FLambda(k,tys,f,subs_shft(n,e))} + | FFix(fx,e) -> {norm=Cstr; term=FFix(fx,subs_shft(n,e))} + | FCoFix(cfx,e) -> {norm=Cstr; term=FCoFix(cfx,subs_shft(n,e))} + | FLIFT(k,m) -> lft_fconstr (n+k) m + | FLOCKED -> anomaly "lft_constr found locked term" + | _ -> {norm=ft.norm; term=FLIFT(n,ft)} +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 + | Inl(n,mt) -> lift_fconstr n mt + | Inr(k,None) -> {norm=Norm; term= FRel k} + | Inr(k,Some p) -> + lift_fconstr (k-p) {norm=Norm;term=FFlex(FarRelKey p)} + +(* since the head may be reducible, we might introduce lifts of 0 *) +let compact_stack head stk = + let rec strip_rec depth = function + | Zshift(k)::s -> strip_rec (depth+k) s + | Zupdate(m)::s -> + (* Be sure to create a new cell otherwise sharing would be + lost by the update operation *) + let h' = lft_fconstr depth head in + let _ = update m (h'.norm,h'.term) in + strip_rec depth s + | stk -> zshift depth stk in + strip_rec 0 stk + +(* Put an update mark in the stack, only if needed *) +let zupdate m s = + if !share & m.norm = Red + then + let s' = compact_stack m s in + let _ = m.term <- FLOCKED in + Zupdate(m)::s' + else s + +(* Closure optimization: *) +let rec compact_constr (lg, subs as s) c k = + match kind_of_term c with + Rel i -> + if i < k then c,s else + (try mkRel (k + lg - list_index (i-k+1) subs), (lg,subs) + with Not_found -> mkRel (k+lg), (lg+1, (i-k+1)::subs)) + | (Sort _|Var _|Meta _|Ind _|Const _|Construct _) -> c,s + | Evar(ev,v) -> + let (v',s) = compact_vect s v k in + if v==v' then c,s else mkEvar(ev,v'),s + | Cast(a,b) -> + let (a',s) = compact_constr s a k in + let (b',s) = compact_constr s b k in + if a==a' && b==b' then c,s else mkCast(a',b'), s + | App(f,v) -> + let (f',s) = compact_constr s f k in + let (v',s) = compact_vect s v k in + if f==f' && v==v' then c,s else mkApp(f',v'), s + | Lambda(n,a,b) -> + let (a',s) = compact_constr s a k in + let (b',s) = compact_constr s b (k+1) in + if a==a' && b==b' then c,s else mkLambda(n,a',b'), s + | Prod(n,a,b) -> + let (a',s) = compact_constr s a k in + let (b',s) = compact_constr s b (k+1) in + if a==a' && b==b' then c,s else mkProd(n,a',b'), s + | LetIn(n,a,ty,b) -> + let (a',s) = compact_constr s a k in + let (ty',s) = compact_constr s ty k in + let (b',s) = compact_constr s b (k+1) in + if a==a' && ty==ty' && b==b' then c,s else mkLetIn(n,a',ty',b'), s + | Fix(fi,(na,ty,bd)) -> + let (ty',s) = compact_vect s ty k in + let (bd',s) = compact_vect s bd (k+Array.length ty) in + if ty==ty' && bd==bd' then c,s else mkFix(fi,(na,ty',bd')), s + | CoFix(i,(na,ty,bd)) -> + let (ty',s) = compact_vect s ty k in + let (bd',s) = compact_vect s bd (k+Array.length ty) in + if ty==ty' && bd==bd' then c,s else mkCoFix(i,(na,ty',bd')), s + | Case(ci,p,a,br) -> + let (p',s) = compact_constr s p k in + let (a',s) = compact_constr s a k in + let (br',s) = compact_vect s br k in + if p==p' && a==a' && br==br' then c,s else mkCase(ci,p',a',br'),s +and compact_vect s v k = compact_v [] s v k (Array.length v - 1) +and compact_v acc s v k i = + if i < 0 then + let v' = Array.of_list acc in + if array_for_all2 (==) v v' then v,s else v',s + else + let (a',s') = compact_constr s v.(i) k in + compact_v (a'::acc) s' v k (i-1) + +(* Computes the minimal environment of a closure. + Idea: if the subs is not identity, the term will have to be + reallocated entirely (to propagate the substitution). So, + computing the set of free variables does not change the + complexity. *) +let optimise_closure env c = + if is_subs_id env then (env,c) else + let (c',(_,s)) = compact_constr (0,[]) c 1 in + let env' = List.fold_left + (fun subs i -> subs_cons (clos_rel env i, subs)) (ESID 0) s in + (env',c') + +let mk_lambda env t = +(* let (env,t) = optimise_closure env t in*) + let (rvars,t') = decompose_lam t in + FLambda(List.length rvars, List.rev rvars, t', env) + +let destFLambda clos_fun t = + match t.term with + FLambda(_,[(na,ty)],b,e) -> (na,clos_fun e ty,clos_fun (subs_lift e) b) + | FLambda(n,(na,ty)::tys,b,e) -> + (na,clos_fun e ty,{norm=Cstr;term=FLambda(n-1,tys,b,subs_lift e)}) + | _ -> assert false + +(* Optimization: do not enclose variables in a closure. + Makes variable access much faster *) +let mk_clos e t = + match kind_of_term t with + | Rel i -> clos_rel e i + | Var x -> { norm = Red; term = FFlex (VarKey x) } + | Const c -> { norm = Red; term = FFlex (ConstKey c) } + | Meta _ | Sort _ -> { norm = Norm; term = FAtom t } + | Ind kn -> { norm = Norm; term = FInd kn } + | Construct kn -> { norm = Cstr; term = FConstruct kn } + | (CoFix _|Lambda _|Fix _|Prod _|Evar _|App _|Case _|Cast _|LetIn _) -> + {norm = Red; term = FCLOS(t,e)} + +let mk_clos_vect env v = Array.map (mk_clos env) v + +(* Translate the head constructor of t from constr to fconstr. This + function is parameterized by the function to apply on the direct + subterms. + Could be used insted of mk_clos. *) +let mk_clos_deep clos_fun env t = + match kind_of_term t with + | (Rel _|Ind _|Const _|Construct _|Var _|Meta _ | Sort _) -> + mk_clos env t + | Cast (a,b) -> + { norm = Red; + term = FCast (clos_fun env a, clos_fun env b)} + | App (f,v) -> + { norm = Red; + term = FApp (clos_fun env f, Array.map (clos_fun env) v) } + | Case (ci,p,c,v) -> + { norm = Red; + term = FCases (ci, clos_fun env p, clos_fun env c, + Array.map (clos_fun env) v) } + | Fix fx -> + { norm = Cstr; term = FFix (fx, env) } + | CoFix cfx -> + { norm = Cstr; term = FCoFix(cfx,env) } + | Lambda _ -> + { norm = Cstr; term = mk_lambda env t } + | Prod (n,t,c) -> + { norm = Whnf; + term = FProd (n, clos_fun env t, clos_fun (subs_lift env) c) } + | LetIn (n,b,t,c) -> + { norm = Red; + term = FLetIn (n, clos_fun env b, clos_fun env t, c, env) } + | Evar(ev,args) -> + { norm = Whnf; term = FEvar(ev,Array.map (clos_fun env) args) } + +(* A better mk_clos? *) +let mk_clos2 = mk_clos_deep mk_clos + +(* The inverse of mk_clos_deep: move back to constr *) +let rec to_constr constr_fun lfts v = + match v.term with + | FRel i -> mkRel (reloc_rel i lfts) + | FFlex (FarRelKey p) -> mkRel (reloc_rel p lfts) + | FFlex (VarKey x) -> mkVar x + | FAtom c -> + (match kind_of_term c with + | Sort s -> mkSort s + | Meta m -> mkMeta m + | _ -> assert false) + | FCast (a,b) -> + mkCast (constr_fun lfts a, constr_fun lfts b) + | FFlex (ConstKey op) -> mkConst op + | FInd op -> mkInd op + | FConstruct op -> mkConstruct op + | FCases (ci,p,c,ve) -> + mkCase (ci, constr_fun lfts p, + constr_fun lfts c, + Array.map (constr_fun lfts) ve) + | FFix ((op,(lna,tys,bds)),e) -> + let n = Array.length bds in + let ftys = Array.map (mk_clos e) tys in + let fbds = Array.map (mk_clos (subs_liftn n e)) bds in + let lfts' = el_liftn n lfts in + mkFix (op, (lna, Array.map (constr_fun lfts) ftys, + Array.map (constr_fun lfts') fbds)) + | FCoFix ((op,(lna,tys,bds)),e) -> + let n = Array.length bds in + let ftys = Array.map (mk_clos e) tys in + let fbds = Array.map (mk_clos (subs_liftn n e)) bds in + let lfts' = el_liftn (Array.length bds) lfts in + mkCoFix (op, (lna, Array.map (constr_fun lfts) ftys, + Array.map (constr_fun lfts') fbds)) + | FApp (f,ve) -> + mkApp (constr_fun lfts f, + Array.map (constr_fun lfts) ve) + | FLambda _ -> + let (na,ty,bd) = destFLambda mk_clos2 v in + mkLambda (na, constr_fun lfts ty, + constr_fun (el_lift lfts) bd) + | FProd (n,t,c) -> + mkProd (n, constr_fun lfts t, + constr_fun (el_lift lfts) c) + | FLetIn (n,b,t,f,e) -> + let fc = mk_clos2 (subs_lift e) f in + mkLetIn (n, constr_fun lfts b, + constr_fun lfts t, + constr_fun (el_lift lfts) fc) + | FEvar (ev,args) -> mkEvar(ev,Array.map (constr_fun lfts) args) + | FLIFT (k,a) -> to_constr constr_fun (el_shft k lfts) a + | FCLOS (t,env) -> + let fr = mk_clos2 env t in + let unfv = update v (fr.norm,fr.term) in + to_constr constr_fun lfts unfv + | FLOCKED -> (*anomaly "Closure.to_constr: found locked term"*) +mkVar(id_of_string"_LOCK_") + +(* This function defines the correspondance between constr and + fconstr. When we find a closure whose substitution is the identity, + then we directly return the constr to avoid possibly huge + reallocation. *) +let term_of_fconstr = + let rec term_of_fconstr_lift lfts v = + match v.term with + | FCLOS(t,env) when is_subs_id env & is_lift_id lfts -> t + | FLambda(_,tys,f,e) when is_subs_id e & is_lift_id lfts -> + compose_lam (List.rev tys) f + | FFix(fx,e) when is_subs_id e & is_lift_id lfts -> mkFix fx + | FCoFix(cfx,e) when is_subs_id e & is_lift_id lfts -> mkCoFix cfx + | _ -> to_constr term_of_fconstr_lift lfts v in + term_of_fconstr_lift ELID + + + +(* fstrong applies unfreeze_fun recursively on the (freeze) term and + * yields a term. Assumes that the unfreeze_fun never returns a + * FCLOS term. +let rec fstrong unfreeze_fun lfts v = + to_constr (fstrong unfreeze_fun) lfts (unfreeze_fun v) +*) + +let rec zip zfun m stk = + match stk with + | [] -> m + | Zapp args :: s -> + let args = Array.of_list args in + zip zfun {norm=neutr m.norm; term=FApp(m, Array.map zfun args)} s + | Zcase(ci,p,br)::s -> + let t = FCases(ci, zfun p, m, Array.map zfun br) in + zip zfun {norm=neutr m.norm; term=t} s + | Zfix(fx,par)::s -> + zip zfun fx (par @ append_stack_list ([m], s)) + | Zshift(n)::s -> + zip zfun (lift_fconstr n m) s + | Zupdate(rf)::s -> + zip zfun (update rf (m.norm,m.term)) s + +let fapp_stack (m,stk) = zip (fun x -> x) m stk + +(*********************************************************************) + +(* The assertions in the functions below are granted because they are + called only when m is a constructor, a cofix + (strip_update_shift_app), a fix (get_nth_arg) or an abstraction + (strip_update_shift, through get_arg). *) + +(* optimised for the case where there are no shifts... *) +let strip_update_shift head stk = + assert (head.norm <> Red); + let rec strip_rec h depth = function + | Zshift(k)::s -> strip_rec (lift_fconstr k h) (depth+k) s + | Zupdate(m)::s -> + strip_rec (update m (h.norm,h.term)) depth s + | stk -> (depth,stk) in + strip_rec head 0 stk + +(* optimised for the case where there are no shifts... *) +let strip_update_shift_app head stk = + assert (head.norm <> Red); + let rec strip_rec rstk h depth = function + | Zshift(k) as e :: s -> + strip_rec (e::rstk) (lift_fconstr k h) (depth+k) s + | (Zapp args :: s) as stk -> + strip_rec (Zapp args :: rstk) + {norm=h.norm;term=FApp(h,Array.of_list args)} depth s + | Zupdate(m)::s -> + strip_rec rstk (update m (h.norm,h.term)) depth s + | stk -> (depth,List.rev rstk, stk) in + strip_rec [] head 0 stk + + +let rec get_nth_arg head n stk = + assert (head.norm <> Red); + let rec strip_rec rstk h depth n = function + | Zshift(k) as e :: s -> + strip_rec (e::rstk) (lift_fconstr k h) (depth+k) n s + | Zapp args::s' -> + let q = List.length args in + if n >= q + then + strip_rec (Zapp args::rstk) + {norm=h.norm;term=FApp(h,Array.of_list args)} depth (n-q) s' + else + (match list_chop n args with + (bef, v::aft) -> + let stk' = + List.rev (if n = 0 then rstk else (Zapp bef :: rstk)) in + (Some (stk', v), append_stack_list (aft,s')) + | _ -> assert false) + | Zupdate(m)::s -> + strip_rec rstk (update m (h.norm,h.term)) depth n s + | s -> (None, List.rev rstk @ s) in + strip_rec [] head 0 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 -> + let hd = update r (Cstr,FLambda(n,tys,f,e)) in + get_args n tys f e s + | Zshift k :: s -> + get_args n tys f (subs_shft (k,e)) s + | Zapp l :: s -> + let na = List.length l in + if n == na then + let e' = List.fold_left (fun e arg -> subs_cons(arg,e)) e l in + (Inl e',s) + else if n < na then (* more arguments *) + let (args,eargs) = list_chop n l in + let e' = List.fold_left (fun e arg -> subs_cons(arg,e)) e args in + (Inl e', Zapp eargs :: s) + else (* more lambdas *) + let (_,etys) = list_chop na tys in + let e' = List.fold_left (fun e arg -> subs_cons(arg,e)) e l in + get_args (n-na) etys f e' s + | _ -> (Inr {norm=Cstr;term=FLambda(n,tys,f,e)}, stk) + + +(* Iota reduction: extract the arguments to be passed to the Case + branches *) +let rec reloc_rargs_rec depth stk = + match stk with + Zapp args :: s -> + Zapp (lift_fconstr_list depth args) :: reloc_rargs_rec depth s + | Zshift(k)::s -> if k=depth then s else reloc_rargs_rec (depth-k) s + | _ -> stk + +let reloc_rargs depth stk = + if depth = 0 then stk else reloc_rargs_rec depth stk + +let rec drop_parameters depth n stk = + match stk with + Zapp args::s -> + let q = List.length args in + if n > q then drop_parameters depth (n-q) s + else if n = q then reloc_rargs depth s + else + let aft = list_skipn n args in + reloc_rargs depth (append_stack_list (aft,s)) + | Zshift(k)::s -> drop_parameters (depth-k) n s + | [] -> assert (n=0); [] + | _ -> assert false (* we know that n < stack_args_size(stk) *) + + +(* Iota reduction: expansion of a fixpoint. + * Given a fixpoint and a substitution, returns the corresponding + * fixpoint body, and the substitution in which it should be + * evaluated: its first variables are the fixpoint bodies + * + * FCLOS(fix Fi {F0 := T0 .. Fn-1 := Tn-1}, S) + * -> (S. FCLOS(F0,S) . ... . FCLOS(Fn-1,S), Ti) + *) +(* does not deal with FLIFT *) +let contract_fix_vect fix = + let (thisbody, make_body, env, nfix) = + match fix with + | FFix (((reci,i),(_,_,bds as rdcl)),env) -> + (bds.(i), + (fun j -> { norm = Cstr; term = FFix (((reci,j),rdcl),env) }), + env, Array.length bds) + | FCoFix ((i,(_,_,bds as rdcl)),env) -> + (bds.(i), + (fun j -> { norm = Cstr; term = FCoFix ((j,rdcl),env) }), + env, Array.length bds) + | _ -> anomaly "Closure.contract_fix_vect: not a (co)fixpoint" + in + let rec subst_bodies_from_i i env = + if i = nfix then + (env, thisbody) + else + subst_bodies_from_i (i+1) (subs_cons (make_body i, env)) + in + subst_bodies_from_i 0 env + + +(*********************************************************************) +(* A machine that inspects the head of a term until it finds an + atom or a subterm that may produce a redex (abstraction, + constructor, cofix, letin, constant), or a neutral term (product, + inductive) *) +let rec knh m stk = + match m.term with + | FLIFT(k,a) -> knh a (zshift k stk) + | FCLOS(t,e) -> knht e t (zupdate m stk) + | FLOCKED -> anomaly "Closure.knh: found lock" + | FApp(a,b) -> knh a (append_stack b (zupdate m stk)) + | FCases(ci,p,t,br) -> knh t (Zcase(ci,p,br)::zupdate m stk) + | FFix(((ri,n),(_,_,_)),_) -> + (match get_nth_arg m ri.(n) stk with + (Some(pars,arg),stk') -> knh arg (Zfix(m,pars)::stk') + | (None, stk') -> (m,stk')) + | FCast(t,_) -> knh t stk +(* cases where knh stops *) + | (FFlex _|FLetIn _|FConstruct _|FEvar _| + FCoFix _|FLambda _|FRel _|FAtom _|FInd _|FProd _) -> + (m, stk) + +(* The same for pure terms *) +and knht e t stk = + match kind_of_term t with + | App(a,b) -> + knht e a (append_stack (mk_clos_vect e b) stk) + | Case(ci,p,t,br) -> + knht e t (Zcase(ci, mk_clos e p, mk_clos_vect e br)::stk) + | Fix _ -> knh (mk_clos2 e t) stk + | Cast(a,b) -> knht e a stk + | Rel n -> knh (clos_rel e n) stk + | (Lambda _|Prod _|Construct _|CoFix _|Ind _| + LetIn _|Const _|Var _|Evar _|Meta _|Sort _) -> + (mk_clos2 e t, stk) + + +(************************************************************************) + +(* Computes a normal form from the result of knh. *) +let rec knr info m stk = + match m.term with + | 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)) + | 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 + | None -> (set_norm m; (m,stk))) + | FFlex(VarKey id) when red_set info.i_flags (fVAR id) -> + (match ref_value_cache info (VarKey id) with + Some v -> kni info v stk + | None -> (set_norm m; (m,stk))) + | FFlex(FarRelKey k) when red_set info.i_flags fDELTA -> + (match ref_value_cache info (FarRelKey k) with + Some v -> kni info v stk + | None -> (set_norm m; (m,stk))) + | FConstruct(ind,c) when red_set info.i_flags fIOTA -> + (match strip_update_shift_app m stk with + (depth, args, Zcase(ci,_,br)::s) -> + assert (ci.ci_npar>=0); + let rargs = drop_parameters depth ci.ci_npar args in + kni info br.(c-1) (rargs@s) + | (_, cargs, Zfix(fx,par)::s) -> + let rarg = fapp_stack(m,cargs) in + let stk' = par @ append_stack [|rarg|] s in + let (fxe,fxbd) = contract_fix_vect fx.term in + knit info fxe fxbd stk' + | (_,args,s) -> (m,args@s)) + | FCoFix _ when red_set info.i_flags fIOTA -> + (match strip_update_shift_app m stk with + (_, args, ((Zcase _::_) as stk')) -> + let (fxe,fxbd) = contract_fix_vect m.term in + knit info fxe fxbd (args@stk') + | (_,args,s) -> (m,args@s)) + | FLetIn (_,v,_,bd,e) when red_set info.i_flags fZETA -> + knit info (subs_cons(v,e)) bd stk + | _ -> (m,stk) + +(* Computes the weak head normal form of a term *) +and kni info m stk = + let (hm,s) = knh m stk in + knr info hm s +and knit info e t stk = + let (ht,s) = knht e t stk in + knr info ht s + +let kh info v stk = fapp_stack(kni info v stk) + +(************************************************************************) + +let rec zip_term zfun m stk = + match stk with + | [] -> m + | Zapp args :: s -> + let args = Array.of_list args in + zip_term zfun (mkApp(m, Array.map zfun args)) s + | Zcase(ci,p,br)::s -> + let t = mkCase(ci, zfun p, m, Array.map zfun br) in + zip_term zfun t s + | Zfix(fx,par)::s -> + let h = mkApp(zip_term zfun (zfun fx) par,[|m|]) in + zip_term zfun h s + | Zshift(n)::s -> + zip_term zfun (lift n m) s + | Zupdate(rf)::s -> + zip_term zfun m s + +(* Computes the strong normal form of a term. + 1- Calls kni + 2- tries to rebuild the term. If a closure still has to be computed, + calls itself recursively. *) +let rec kl info m = + if is_val m then (incr prune; term_of_fconstr m) + else + let (nm,s) = kni info m [] in + let _ = fapp_stack(nm,s) in (* to unlock Zupdates! *) + zip_term (kl info) (norm_head info nm) s + +(* no redex: go up for atoms and already normalized terms, go down + otherwise. *) +and norm_head info m = + if is_val m then (incr prune; term_of_fconstr m) else + match m.term with + | FLambda(n,tys,f,e) -> + let (e',rvtys) = + List.fold_left (fun (e,ctxt) (na,ty) -> + (subs_lift e, (na,kl info (mk_clos e ty))::ctxt)) + (e,[]) tys in + let bd = kl info (mk_clos e' f) in + List.fold_left (fun b (na,ty) -> mkLambda(na,ty,b)) bd rvtys + | FLetIn(na,a,b,f,e) -> + let c = mk_clos (subs_lift e) f in + mkLetIn(na, kl info a, kl info b, kl info c) + | FProd(na,dom,rng) -> + mkProd(na, kl info dom, kl info rng) + | FCoFix((n,(na,tys,bds)),e) -> + let ftys = Array.map (mk_clos e) tys in + let fbds = + Array.map (mk_clos (subs_liftn (Array.length na) e)) bds in + mkCoFix(n,(na, Array.map (kl info) ftys, Array.map (kl info) fbds)) + | FEvar(i,args) -> mkEvar(i, Array.map (kl info) args) + | t -> term_of_fconstr m + +(* Initialization and then normalization *) + +(* weak reduction *) +let whd_val info v = + with_stats (lazy (term_of_fconstr (kh info v []))) + +(* strong reduction *) +let norm_val info v = + with_stats (lazy (kl info v)) + +let inject = mk_clos (ESID 0) + +let whd_stack infos m stk = + let k = kni infos m stk in + let _ = fapp_stack k in (* to unlock Zupdates! *) + k + +(* cache of constants: the body is computed only when needed. *) +type clos_infos = fconstr infos + +let create_clos_infos flgs env = + create (fun _ -> inject) flgs env + +let unfold_reference = ref_value_cache diff --git a/kernel/closure.mli b/kernel/closure.mli new file mode 100644 index 00000000..e58b91eb --- /dev/null +++ b/kernel/closure.mli @@ -0,0 +1,207 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* '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 + a LetIn expression is Letin reduction *) + +type transparent_state = Idpred.t * KNpred.t + +val all_opaque : transparent_state +val all_transparent : transparent_state + +(* Sets of reduction kinds. *) +module type RedFlagsSig = sig + type reds + type red_kind + + (* The different kind of reduction *) + (* Const/Var means the reference as argument should be unfolded *) + (* Constbut/Varbut means all references except the ones as argument + of Constbut/Varbut should be unfolded (there may be several such + Constbut/Varbut *) + val fBETA : red_kind + val fDELTA : red_kind + val fIOTA : red_kind + val fZETA : red_kind + val fCONST : constant -> red_kind + val fVAR : identifier -> red_kind + + (* No reduction at all *) + val no_red : reds + + (* Adds a reduction kind to a set *) + val red_add : reds -> red_kind -> reds + + (* Removes a reduction kind to a set *) + val red_sub : reds -> red_kind -> reds + + (* Adds a reduction kind to a set *) + val red_add_transparent : reds -> transparent_state -> reds + + (* Build a reduction set from scratch = iter [red_add] on [no_red] *) + val mkflags : red_kind list -> reds + + (* Tests if a reduction kind is set *) + val red_set : reds -> red_kind -> bool + + (* Gives the constant list *) + val red_get_const : reds -> bool * evaluable_global_reference list +end + +module RedFlags : RedFlagsSig +open RedFlags + +val beta : reds +val betaiota : reds +val betadeltaiota : reds +val betaiotazeta : reds +val betadeltaiotanolet : reds + +val unfold_red : evaluable_global_reference -> reds + +(************************************************************************) + +type table_key = + | ConstKey of constant + | VarKey of identifier + | FarRelKey of int + (* FarRel: index in the [rel_context] part of {\em initial} environment *) + +type 'a infos +val ref_value_cache: 'a infos -> table_key -> 'a option +val info_flags: 'a infos -> reds +val create: ('a infos -> constr -> 'a) -> reds -> env -> 'a infos + +(************************************************************************) +(*s A [stack] is a context of arguments, arguments are pushed by + [append_stack] one array at a time but popped with [decomp_stack] + one by one *) + +type 'a stack_member = + | Zapp of 'a list + | Zcase of case_info * 'a * 'a array + | Zfix of 'a * 'a stack + | Zshift of int + | Zupdate of 'a + +and 'a stack = 'a stack_member list + +val empty_stack : 'a stack +val append_stack : 'a array -> 'a stack -> 'a stack + +val decomp_stack : 'a stack -> ('a * 'a stack) option +val list_of_stack : 'a stack -> 'a list +val array_of_stack : 'a stack -> 'a array +val stack_assign : 'a stack -> int -> 'a -> 'a stack +val stack_args_size : 'a stack -> int +val app_stack : constr * constr stack -> constr +val stack_tail : int -> 'a stack -> 'a stack +val stack_nth : 'a stack -> int -> 'a + +(************************************************************************) +(*s Lazy reduction. *) + +(* [fconstr] is the type of frozen constr *) + +type fconstr + +(* [fconstr] can be accessed by using the function [fterm_of] and by + matching on type [fterm] *) + +type fterm = + | FRel of int + | FAtom of constr (* Metas and Sorts *) + | FCast of fconstr * fconstr + | FFlex of table_key + | FInd of inductive + | FConstruct of constructor + | FApp of fconstr * fconstr array + | FFix of fixpoint * fconstr subs + | FCoFix of cofixpoint * fconstr subs + | FCases of case_info * fconstr * fconstr * fconstr array + | FLambda of int * (name * constr) list * constr * fconstr subs + | FProd of name * fconstr * fconstr + | FLetIn of name * fconstr * fconstr * constr * fconstr subs + | FEvar of existential_key * fconstr array + | FLIFT of int * fconstr + | FCLOS of constr * fconstr subs + | FLOCKED + +(* To lazy reduce a constr, create a [clos_infos] with + [create_clos_infos], inject the term to reduce with [inject]; then use + a reduction function *) + +val inject : constr -> fconstr +val fterm_of : fconstr -> fterm +val term_of_fconstr : fconstr -> constr +val destFLambda : + (fconstr subs -> constr -> fconstr) -> fconstr -> name * fconstr * fconstr + +(* Global and local constant cache *) +type clos_infos +val create_clos_infos : reds -> env -> clos_infos + +(* Reduction function *) + +(* [norm_val] is for strong normalization *) +val norm_val : clos_infos -> fconstr -> constr + +(* [whd_val] is for weak head normalization *) +val whd_val : clos_infos -> fconstr -> constr + +(* [whd_stack] performs weak head normalization in a given stack. It + stops whenever a reduction is blocked. *) +val whd_stack : + clos_infos -> fconstr -> fconstr stack -> fconstr * fconstr stack + +(* Conversion auxiliary functions to do step by step normalisation *) + +(* [unfold_reference] unfolds references in a [fconstr] *) +val unfold_reference : clos_infos -> table_key -> fconstr option + +(* [mind_equiv] checks whether two mutual inductives are intentionally equal *) +val mind_equiv : clos_infos -> mutual_inductive -> mutual_inductive -> bool + +(************************************************************************) +(*i This is for lazy debug *) + +val lift_fconstr : int -> fconstr -> fconstr +val lift_fconstr_vect : int -> fconstr array -> fconstr array + +val mk_clos : fconstr subs -> constr -> fconstr +val mk_clos_vect : fconstr subs -> constr array -> fconstr array +val mk_clos_deep : + (fconstr subs -> constr -> fconstr) -> + fconstr subs -> constr -> fconstr + +val kni: clos_infos -> fconstr -> fconstr stack -> fconstr * fconstr stack +val knr: clos_infos -> fconstr -> fconstr stack -> fconstr * fconstr stack +val kl : clos_infos -> fconstr -> constr + +val to_constr : (lift -> fconstr -> constr) -> lift -> fconstr -> constr +val optimise_closure : fconstr subs -> constr -> fconstr subs * constr + +(* End of cbn debug section i*) diff --git a/kernel/conv_oracle.ml b/kernel/conv_oracle.ml new file mode 100644 index 00000000..dba373ce --- /dev/null +++ b/kernel/conv_oracle.ml @@ -0,0 +1,43 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* is_opaque_cst cst + | VarKey id -> is_opaque_var id + | FarRelKey _ -> false + +(* Unfold the first only if it is not opaque and the second is opaque *) +let oracle_order k1 k2 = is_opaque k2 & not (is_opaque k1) + +(* summary operations *) + +let init() = (cst_transp := KNpred.full; var_transp := Idpred.full) +let freeze () = (!var_transp, !cst_transp) +let unfreeze (vo,co) = (cst_transp := co; var_transp := vo) diff --git a/kernel/conv_oracle.mli b/kernel/conv_oracle.mli new file mode 100644 index 00000000..77de9b8a --- /dev/null +++ b/kernel/conv_oracle.mli @@ -0,0 +1,35 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* table_key -> bool + +(* Changing the oracle *) +val set_opaque_const : constant -> unit +val set_transparent_const : constant -> unit + +val set_opaque_var : identifier -> unit +val set_transparent_var : identifier -> unit + +val is_opaque_cst : constant -> bool +val is_opaque_var : identifier -> bool + +(*****************************) + +(* transparent state summary operations *) +val init : unit -> unit +val freeze : unit -> transparent_state +val unfreeze : transparent_state -> unit diff --git a/kernel/cooking.ml b/kernel/cooking.ml new file mode 100644 index 00000000..d69efe3a --- /dev/null +++ b/kernel/cooking.ml @@ -0,0 +1,172 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* + (try + match List.assoc ci.ci_ind indl with + | DO_ABSTRACT (ind,abs_vars) -> + let n' = Array.length abs_vars + ci.ci_npar in + let ci' = { ci with + ci_ind = ind; + ci_npar = n' } in + mkCase (ci',p,t,br) + | _ -> raise Not_found + with + | Not_found -> c') + + | Ind spi -> + (try + (match List.assoc spi indl with + | NOT_OCCUR -> failure () + | DO_ABSTRACT (oper',abs_vars) -> + mkApp (mkInd oper', abs_vars) + | DO_REPLACE _ -> assert false) + with + | Not_found -> c') + + | Construct spi -> + (try + (match List.assoc spi cstrl with + | NOT_OCCUR -> failure () + | DO_ABSTRACT (oper',abs_vars) -> + mkApp (mkConstruct oper', abs_vars) + | DO_REPLACE _ -> assert false) + with + | Not_found -> c') + + | Const kn -> + (try + (match List.assoc kn constl with + | NOT_OCCUR -> failure () + | DO_ABSTRACT (oper',abs_vars) -> + mkApp (mkConst oper', abs_vars) + | DO_REPLACE cb -> substrec (replfun (kn,cb))) + with + | Not_found -> c') + + | _ -> c' + in + if (constl,indl,cstrl) = ([],[],[]) then fun x -> x else substrec + +let expmod_constr modlist c = + let simpfun = + if modlist = ([],[],[]) then fun x -> x else nf_betaiota in + let expfun (kn,cb) = + if cb.const_opaque then + errorlabstrm "expmod_constr" + (str"Cannot unfold the value of " ++ + str(string_of_kn kn) ++ spc () ++ + str"You cannot declare local lemmas as being opaque" ++ spc () ++ + str"and then require that theorems which use them" ++ spc () ++ + str"be transparent"); + match cb.const_body with + | Some body -> Declarations.force body + | None -> assert false + in + let c' = modify_opers expfun modlist c in + match kind_of_term c' with + | Cast (value,typ) -> mkCast (simpfun value,simpfun typ) + | _ -> simpfun c' + +let expmod_type modlist c = + type_app (expmod_constr modlist) c + +let abstract_constant ids_to_abs hyps (body,typ) = + let abstract_once_typ ((hyps,typ) as sofar) id = + match hyps with + | (hyp,c,t as decl)::rest when hyp = id -> + let typ' = mkNamedProd_wo_LetIn decl typ in + (rest, typ') + | _ -> + sofar + in + let abstract_once_body ((hyps,body) as sofar) id = + match hyps with + | (hyp,c,t as decl)::rest when hyp = id -> + let body' = mkNamedLambda_or_LetIn decl body in + (rest, body') + | _ -> + sofar + in + let (_,typ') = + List.fold_left abstract_once_typ (hyps,typ) ids_to_abs + in + let body' = match body with + None -> None + | Some l_body -> + Some (Declarations.from_val + (let body = Declarations.force l_body in + let (_,body') = + List.fold_left abstract_once_body (hyps,body) ids_to_abs + in + body')) + in + (body',typ') + +let cook_constant env r = + let cb = r.d_from in + let typ = expmod_type r.d_modlist cb.const_type in + let body = + option_app + (fun lconstr -> + Declarations.from_val + (expmod_constr r.d_modlist (Declarations.force lconstr))) + cb.const_body + in + let hyps = + Sign.fold_named_context + (fun d ctxt -> + Sign.add_named_decl + (map_named_declaration (expmod_constr r.d_modlist) d) + ctxt) + cb.const_hyps + ~init:empty_named_context in + let body,typ = abstract_constant r.d_abstract hyps (body,typ) in + (body, typ, cb.const_constraints, cb.const_opaque) diff --git a/kernel/cooking.mli b/kernel/cooking.mli new file mode 100644 index 00000000..54526e99 --- /dev/null +++ b/kernel/cooking.mli @@ -0,0 +1,42 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* recipe -> constr_substituted option * constr * constraints * bool + +(*s Utility functions used in module [Discharge]. *) + +val expmod_constr : work_list -> constr -> constr +val expmod_type : work_list -> types -> types + + diff --git a/kernel/declarations.ml b/kernel/declarations.ml new file mode 100644 index 00000000..8943b0b5 --- /dev/null +++ b/kernel/declarations.ml @@ -0,0 +1,193 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* c + | LazyConstr (subst,c) -> + let c' = subst_mps subst c in + cs := Constr c'; + c' + +let subst_constr_subst subst cs = match !cs with + Constr c -> ref (LazyConstr (subst,c)) + | LazyConstr (subst',c) -> + let subst'' = join subst' subst in + ref (LazyConstr (subst'',c)) + +type constant_body = { + const_hyps : section_context; (* New: younger hyp at top *) + const_body : constr_substituted option; + const_type : types; + const_constraints : constraints; + const_opaque : bool } + +(*s Inductive types (internal representation with redundant + information). *) + +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 + if kn==kn' then r else Imbr (kn',i) + +type wf_paths = recarg Rtree.t + +let mk_norec = Rtree.mk_node Norec [||] + +let mk_paths r recargs = + Rtree.mk_node r + (Array.map (fun l -> Rtree.mk_node Norec (Array.of_list l)) recargs) + +let dest_recarg p = fst (Rtree.dest_node p) + +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 (_,cstrs) = Rtree.dest_node p in + Array.length (snd (Rtree.dest_node cstrs.(j-1))) + +let subst_wf_paths sub p = Rtree.smartmap (subst_recarg sub) p + +(* [mind_typename] is the name of the inductive; [mind_arity] is + the arity generalized over global parameters; [mind_lc] is the list + of types of constructors generalized over global parameters and + relative to the global context enriched with the arities of the + inductives *) + +type one_inductive_body = { + mind_typename : identifier; + mind_nparams : int; + mind_params_ctxt : rel_context; + mind_nrealargs : int; + mind_nf_arity : types; + mind_user_arity : types; + mind_sort : sorts; + mind_kelim : sorts_family list; + mind_consnames : identifier array; + mind_nf_lc : types array; (* constrs and arity with pre-expanded ccl *) + mind_user_lc : types array; + mind_recargs : wf_paths; + } + +type mutual_inductive_body = { + mind_finite : bool; + mind_ntypes : int; + mind_hyps : section_context; + mind_packets : one_inductive_body array; + mind_constraints : constraints; + mind_equiv : kernel_name option + } + +(* TODO: should be changed to non-coping after Term.subst_mps *) +let subst_const_body sub cb = + { const_body = option_app (subst_constr_subst sub) cb.const_body; + const_type = type_app (Term.subst_mps sub) cb.const_type; + const_hyps = (assert (cb.const_hyps=[]); []); + const_constraints = cb.const_constraints; + const_opaque = cb.const_opaque} + +let subst_mind_packet sub mbp = + { mind_consnames = mbp.mind_consnames; + mind_typename = mbp.mind_typename; + mind_nf_lc = + array_smartmap (type_app (Term.subst_mps sub)) mbp.mind_nf_lc; + mind_nf_arity = type_app (Term.subst_mps sub) mbp.mind_nf_arity; + mind_user_lc = + array_smartmap (type_app (Term.subst_mps sub)) mbp.mind_user_lc; + mind_user_arity = type_app (Term.subst_mps sub) mbp.mind_user_arity; + mind_sort = mbp.mind_sort; + mind_nrealargs = mbp.mind_nrealargs; + mind_kelim = mbp.mind_kelim; + mind_nparams = mbp.mind_nparams; + mind_params_ctxt = + map_rel_context (Term.subst_mps sub) mbp.mind_params_ctxt; + mind_recargs = subst_wf_paths sub mbp.mind_recargs (*wf_paths*); +} + +let subst_mind sub mib = + { mind_finite = mib.mind_finite ; + mind_ntypes = mib.mind_ntypes ; + mind_hyps = (assert (mib.mind_hyps=[]); []) ; + mind_packets = array_smartmap (subst_mind_packet sub) mib.mind_packets ; + mind_constraints = mib.mind_constraints ; + mind_equiv = option_app (subst_kn sub) mib.mind_equiv; +} + + +(*s Modules: signature component specifications, module types, and + module declarations *) + +type specification_body = + | SPBconst of constant_body + | SPBmind of mutual_inductive_body + | SPBmodule of module_specification_body + | SPBmodtype of module_type_body + +and module_signature_body = (label * specification_body) list + +and module_type_body = + | MTBident of kernel_name + | MTBfunsig of mod_bound_id * module_type_body * module_type_body + | MTBsig of mod_self_id * module_signature_body + +and module_specification_body = + { msb_modtype : module_type_body; + msb_equiv : module_path option; + msb_constraints : constraints } + + +type structure_elem_body = + | SEBconst of constant_body + | SEBmind of mutual_inductive_body + | SEBmodule of module_body + | SEBmodtype of module_type_body + +and module_structure_body = (label * structure_elem_body) list + +and module_expr_body = + | MEBident of module_path + | MEBfunctor of mod_bound_id * module_type_body * module_expr_body + | MEBstruct of mod_self_id * module_structure_body + | MEBapply of module_expr_body * module_expr_body + * constraints + +and module_body = + { mod_expr : module_expr_body option; + mod_user_type : module_type_body option; + mod_type : module_type_body; + mod_equiv : module_path option; + mod_constraints : constraints } diff --git a/kernel/declarations.mli b/kernel/declarations.mli new file mode 100644 index 00000000..3252ddee --- /dev/null +++ b/kernel/declarations.mli @@ -0,0 +1,141 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* constr_substituted +val force : constr_substituted -> constr + +type constant_body = { + const_hyps : section_context; (* New: younger hyp at top *) + const_body : constr_substituted option; + const_type : types; + const_constraints : constraints; + const_opaque : bool } + +val subst_const_body : substitution -> constant_body -> constant_body + +(*s Inductive types (internal representation with redundant + information). *) + +type recarg = + | Norec + | Mrec of int + | Imbr of inductive + +val subst_recarg : substitution -> recarg -> recarg + +type wf_paths = recarg Rtree.t + +val mk_norec : wf_paths +val mk_paths : recarg -> wf_paths list array -> wf_paths +val dest_recarg : wf_paths -> recarg +val dest_subterms : wf_paths -> wf_paths list array +val recarg_length : wf_paths -> int -> int + +val subst_wf_paths : substitution -> wf_paths -> wf_paths + +(* [mind_typename] is the name of the inductive; [mind_arity] is + the arity generalized over global parameters; [mind_lc] is the list + of types of constructors generalized over global parameters and + relative to the global context enriched with the arities of the + inductives *) + +type one_inductive_body = { + mind_typename : identifier; + mind_nparams : int; + mind_params_ctxt : rel_context; + mind_nrealargs : int; + mind_nf_arity : types; + mind_user_arity : types; + mind_sort : sorts; + mind_kelim : sorts_family list; + mind_consnames : identifier array; + mind_nf_lc : types array; (* constrs and arity with pre-expanded ccl *) + mind_user_lc : types array; + mind_recargs : wf_paths; + } + +type mutual_inductive_body = { + mind_finite : bool; + mind_ntypes : int; + mind_hyps : section_context; + mind_packets : one_inductive_body array; + mind_constraints : constraints; + mind_equiv : kernel_name option; + } + + +val subst_mind : substitution -> mutual_inductive_body -> mutual_inductive_body + + +(*s Modules: signature component specifications, module types, and + module declarations *) + +type specification_body = + | SPBconst of constant_body + | SPBmind of mutual_inductive_body + | SPBmodule of module_specification_body + | SPBmodtype of module_type_body + +and module_signature_body = (label * specification_body) list + +and module_type_body = + | MTBident of kernel_name + | MTBfunsig of mod_bound_id * module_type_body * module_type_body + | MTBsig of mod_self_id * module_signature_body + +and module_specification_body = + { msb_modtype : module_type_body; + msb_equiv : module_path option; + msb_constraints : constraints } + (* type_of(equiv) <: modtype (if given) + + substyping of past With_Module mergers *) + + +type structure_elem_body = + | SEBconst of constant_body + | SEBmind of mutual_inductive_body + | SEBmodule of module_body + | SEBmodtype of module_type_body + +and module_structure_body = (label * structure_elem_body) list + +and module_expr_body = + | MEBident of module_path + | MEBfunctor of mod_bound_id * module_type_body * module_expr_body + | MEBstruct of mod_self_id * module_structure_body + | MEBapply of module_expr_body * module_expr_body (* (F A) *) + * constraints (* type_of(A) <: input_type_of(F) *) + +and module_body = + { mod_expr : module_expr_body option; + mod_user_type : module_type_body option; + mod_type : module_type_body; + mod_equiv : module_path option; + mod_constraints : constraints } + (* type_of(mod_expr) <: mod_user_type (if given) *) + (* if equiv given then constraints are empty *) + + + diff --git a/kernel/doc.tex b/kernel/doc.tex new file mode 100644 index 00000000..4a9fc355 --- /dev/null +++ b/kernel/doc.tex @@ -0,0 +1,11 @@ + +\newpage +\section*{The Coq kernel} + +\ocwsection \label{kernel} +This chapter describes the \Coq\ kernel, which is a type checker for the \CCI. +The modules of the kernel are organized as follows. + +\bigskip +\begin{center}\epsfig{file=kernel.dep.ps,width=\linewidth}\end{center} + diff --git a/kernel/entries.ml b/kernel/entries.ml new file mode 100644 index 00000000..d833499e --- /dev/null +++ b/kernel/entries.ml @@ -0,0 +1,101 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* true + | _ -> false + with Not_found -> + false + +let push_rel d env = + { env with + env_rel_context = add_rel_decl d env.env_rel_context } + +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, type_app (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 } + +let fold_rel_context f env ~init = + snd (Sign.fold_rel_context + (fun d (env,e) -> (push_rel d env, f env d e)) + (rel_context env) ~init:(reset_rel_context env,init)) + + +(* Named context *) +let lookup_named id env = + Sign.lookup_named id env.env_named_context + +(* A local const is evaluable if it is defined and not opaque *) +let evaluable_named id env = + try + match lookup_named id env with + (_,Some _,_) -> true + | _ -> false + with Not_found -> + false + +let push_named d env = + { env with + env_named_context = Sign.add_named_decl d env.env_named_context } + +let reset_context env = + { env with + env_named_context = empty_named_context; + env_rel_context = empty_rel_context } + +let reset_with_named_context ctxt env = + { env with + env_named_context = ctxt; + env_rel_context = empty_rel_context } + +let fold_named_context f env ~init = + snd (Sign.fold_named_context + (fun d (env,e) -> (push_named d env, f env d e)) + (named_context env) ~init:(reset_context env,init)) + +let fold_named_context_reverse f ~init env = + Sign.fold_named_context_reverse f ~init:init (named_context env) + +(* Global constants *) +let lookup_constant kn env = + KNmap.find kn env.env_globals.env_constants + +let add_constant kn cb env = + let new_constants = KNmap.add kn cb 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 + +type const_evaluation_result = NoBody | Opaque + +exception NotEvaluableConst of const_evaluation_result + +let constant_value env kn = + let cb = lookup_constant kn env in + if cb.const_opaque then raise (NotEvaluableConst Opaque); + match cb.const_body with + | Some l_body -> Declarations.force l_body + | None -> raise (NotEvaluableConst NoBody) + +let constant_opt_value env cst = + try Some (constant_value env cst) + with NotEvaluableConst _ -> None + +(* 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 + +(* Mutual Inductives *) +let lookup_mind kn env = + KNmap.find kn env.env_globals.env_inductives + +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 + env_inductives = new_inds } in + { env with env_globals = new_globals } + +(* Universe constraints *) +let set_universes g env = + if env.env_stratification.env_universes == g then env + else + { env with env_stratification = + { env.env_stratification with env_universes = g } } + +let add_constraints c env = + if c == Constraint.empty then + env + else + let s = env.env_stratification in + { env with env_stratification = + { s with env_universes = merge_constraints c s.env_universes } } + +let set_engagement c env = (* Unsafe *) + { env with env_stratification = + { env.env_stratification with env_engagement = Some c } } + +(* Lookup of section variables *) +let lookup_constant_variables c env = + let cmap = lookup_constant c env in + Sign.vars_of_named_context cmap.const_hyps + +let lookup_inductive_variables (kn,i) env = + let mis = lookup_mind kn env in + Sign.vars_of_named_context mis.mind_hyps + +let lookup_constructor_variables (ind,_) env = + lookup_inductive_variables ind env + +(* Returns the list of global variables in a term *) + +let vars_of_global env constr = + match kind_of_term constr with + Var id -> [id] + | Const kn -> lookup_constant_variables kn env + | Ind ind -> lookup_inductive_variables ind env + | Construct cstr -> lookup_constructor_variables cstr env + | _ -> [] + +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 + 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 + contained in the types of the needed variables. *) + +let keep_hyps env needed = + let really_needed = + Sign.fold_named_context_reverse + (fun need (id,copt,t) -> + if Idset.mem id need then + let globc = + match copt with + | None -> Idset.empty + | Some c -> global_vars_set env c in + Idset.union + (global_vars_set env t) + (Idset.union globc need) + else need) + ~init:needed + (named_context env) in + Sign.fold_named_context + (fun (id,_,_ as d) nsign -> + if Idset.mem id really_needed then add_named_decl d nsign + else nsign) + (named_context env) + ~init:empty_named_context + + +(* Modules *) + +let add_modtype ln mtb env = + let new_modtypes = KNmap.add ln mtb env.env_globals.env_modtypes in + 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 new_mods = MPmap.add mp mb env.env_globals.env_modules in + let new_globals = + { env.env_globals with + env_modules = new_mods } in + { env with env_globals = new_globals } + +let lookup_module mp env = + MPmap.find mp env.env_globals.env_modules + +let lookup_modtype ln env = + KNmap.find ln env.env_globals.env_modtypes + +(*s Judgments. *) + +type unsafe_judgment = { + uj_val : constr; + uj_type : types } + +let make_judge v tj = + { uj_val = v; + uj_type = tj } + +let j_val j = j.uj_val +let j_type j = j.uj_type + +type unsafe_type_judgment = { + utj_val : constr; + utj_type : sorts } + diff --git a/kernel/environ.mli b/kernel/environ.mli new file mode 100644 index 00000000..4e54761b --- /dev/null +++ b/kernel/environ.mli @@ -0,0 +1,159 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Univ.universes +val rel_context : env -> rel_context +val named_context : env -> named_context + +type engagement = ImpredicativeSet + +val engagement : env -> engagement option + +(* is the local context empty *) +val empty_context : env -> bool + +(************************************************************************) +(*s Context of de Bruijn variables (rel_context) *) +val push_rel : rel_declaration -> env -> env +val push_rel_context : rel_context -> env -> env +val push_rec_types : rec_declaration -> env -> env + +(* Looks up in the context of local vars referred by indice ([rel_context]) *) +(* raises [Not_found] if the index points out of the context *) +val lookup_rel : int -> env -> rel_declaration +val evaluable_rel : int -> env -> bool + +(*s Recurrence on [rel_context] *) +val fold_rel_context : + (env -> rel_declaration -> 'a -> 'a) -> env -> init:'a -> 'a + +(************************************************************************) +(* Context of variables (section variables and goal assumptions) *) +val push_named : named_declaration -> env -> env + +(* Looks up in the context of local vars referred by names ([named_context]) *) +(* raises [Not_found] if the identifier is not found *) +val lookup_named : variable -> env -> named_declaration +val evaluable_named : variable -> env -> bool + +(*s Recurrence on [named_context]: older declarations processed first *) +val fold_named_context : + (env -> named_declaration -> 'a -> 'a) -> env -> init:'a -> 'a + +(* Recurrence on [named_context] starting from younger decl *) +val fold_named_context_reverse : + ('a -> named_declaration -> 'a) -> init:'a -> env -> 'a + +(* This forgets named and rel contexts *) +val reset_context : env -> env +(* This forgets rel context and sets a new named context *) +val reset_with_named_context : named_context -> env -> env + +(************************************************************************) +(*s Global constants *) +(*s Add entries to global environment *) +val add_constant : constant -> constant_body -> env -> env + +(* Looks up in the context of global constant names *) +(* raises [Not_found] if the required path is not found *) +val lookup_constant : constant -> env -> constant_body +val evaluable_constant : constant -> env -> bool + +(*s [constant_value env c] raises [NotEvaluableConst Opaque] if + [c] is opaque and [NotEvaluableConst NoBody] if it has no + body and [Not_found] if it does not exist in [env] *) +type const_evaluation_result = NoBody | Opaque +exception NotEvaluableConst of const_evaluation_result + +val constant_value : env -> constant -> constr +val constant_type : env -> constant -> types +val constant_opt_value : env -> constant -> constr option + +(************************************************************************) +(*s Inductive types *) +val add_mind : mutual_inductive -> mutual_inductive_body -> env -> env + +(* Looks up in the context of global inductive names *) +(* raises [Not_found] if the required path is not found *) +val lookup_mind : mutual_inductive -> env -> mutual_inductive_body + +(************************************************************************) +(*s Modules *) +val add_modtype : kernel_name -> module_type_body -> env -> env + +(* [shallow_add_module] does not add module components *) +val shallow_add_module : module_path -> module_body -> env -> env + +val lookup_module : module_path -> env -> module_body +val lookup_modtype : kernel_name -> env -> module_type_body + +(************************************************************************) +(*s Universe constraints *) +val set_universes : Univ.universes -> env -> env +val add_constraints : Univ.constraints -> env -> env + +val set_engagement : engagement -> env -> env + +(************************************************************************) +(* Sets of referred section variables *) +(* [global_vars_set env c] returns the list of [id]'s occurring as + [VAR id] in [c] *) +val global_vars_set : env -> constr -> Idset.t +(* the constr must be an atomic construction *) +val vars_of_global : env -> constr -> identifier list + +val keep_hyps : env -> Idset.t -> section_context + +(************************************************************************) +(*s Unsafe judgments. We introduce here the pre-type of judgments, which is + actually only a datatype to store a term with its type and the type of its + type. *) + +type unsafe_judgment = { + uj_val : constr; + uj_type : types } + +val make_judge : constr -> types -> unsafe_judgment +val j_val : unsafe_judgment -> constr +val j_type : unsafe_judgment -> types + +type unsafe_type_judgment = { + utj_val : constr; + utj_type : sorts } + + + + + + diff --git a/kernel/esubst.ml b/kernel/esubst.ml new file mode 100644 index 00000000..38db01fc --- /dev/null +++ b/kernel/esubst.ml @@ -0,0 +1,137 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* n *) + (* i.e under n binders *) + +(* compose a relocation of magnitude n *) +let rec el_shft_rec n = function + | ELSHFT(el,k) -> el_shft_rec (k+n) el + | el -> ELSHFT(el,n) +let el_shft n el = if n = 0 then el else el_shft_rec n el + +(* cross n binders *) +let rec el_liftn_rec n = function + | ELID -> ELID + | ELLFT(k,el) -> el_liftn_rec (n+k) el + | el -> ELLFT(n, el) +let el_liftn n el = if n = 0 then el else el_liftn_rec n el + +let el_lift el = el_liftn_rec 1 el + +(* relocation of de Bruijn n in an explicit lift *) +let rec reloc_rel n = function + | ELID -> n + | ELLFT(k,el) -> + if n <= k then n else (reloc_rel (n-k) el) + k + | ELSHFT(el,k) -> (reloc_rel (n+k) el) + +let rec is_lift_id = function + | ELID -> true + | ELSHFT(e,n) -> n=0 & is_lift_id e + | ELLFT (_,e) -> is_lift_id e + +(*********************) +(* Substitutions *) +(*********************) + +(* (bounded) explicit substitutions of type 'a *) +type 'a subs = + | ESID of int (* ESID(n) = %n END bounded identity *) + | CONS of 'a * 'a subs (* CONS(t,S) = (S.t) parallel substitution *) + | 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) *) + +(* operations of subs: collapses constructors when possible. + * Needn't be recursive if we always use these functions + *) + +let subs_cons(x,s) = CONS(x,s) + +let subs_liftn n = function + | ESID p -> ESID (p+n) (* bounded identity lifted extends by p *) + | LIFT (p,lenv) -> LIFT (p+n, lenv) + | lenv -> LIFT (n,lenv) + +let subs_lift a = subs_liftn 1 a +let subs_liftn n a = if n = 0 then a else subs_liftn n a + +let subs_shft = function + | (0, s) -> s + | (n, SHIFT (k,s1)) -> SHIFT (k+n, s1) + | (n, s) -> SHIFT (n,s) +let subs_shft (n,a) = if n = 0 then a else subs_shft(n,a) + +let subs_shift_cons = function + (0, s, t) -> CONS(t,s) +| (k, SHIFT(n,s1), t) -> CONS(t,SHIFT(k+n, s1)) +| (k, s, t) -> CONS(t,SHIFT(k, s));; + +(* Tests whether a substitution is extensionnaly equal to the identity *) +let rec is_subs_id = function + ESID _ -> true + | LIFT(_,s) -> is_subs_id s + | SHIFT(0,s) -> is_subs_id s + | _ -> false + +(* Expands de Bruijn k in the explicit substitution subs + * lams accumulates de shifts to perform when retrieving the i-th value + * the rules used are the following: + * + * [id]k --> k + * [S.t]1 --> t + * [S.t]k --> [S](k-1) if k > 1 + * [^n o S] k --> [^n]([S]k) + * [(%n S)] k --> k if k <= n + * [(%n S)] k --> [^n]([S](k-n)) + * + * 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 (k,subs) with + | (1, CONS (def,_)) -> Inl(lams,def) + | (_, CONS (_,l)) -> exp_rel lams (pred k) l + | (_, LIFT (n,_)) when k<=n -> Inr(lams+k,None) + | (_, LIFT (n,l)) -> exp_rel (n+lams) (k-n) l + | (_, SHIFT (n,s)) -> exp_rel (n+lams) k s + | (_, ESID n) when k<=n -> Inr(lams+k,None) + | (_, ESID n) -> Inr(lams+k,Some (k-n)) + +let expand_rel k subs = exp_rel 0 k subs + +let rec comp mk_cl s1 s2 = + match (s1, s2) with + | _, ESID _ -> s1 + | ESID _, _ -> s2 + | SHIFT(k,s), _ -> subs_shft(k, comp mk_cl s s2) + | _, CONS(x,s') -> CONS(mk_cl(s1,x), comp mk_cl s1 s') + | CONS(x,s), SHIFT(k,s') -> comp mk_cl s (subs_shft(k-1, s')) + | CONS(x,s), LIFT(k,s') -> CONS(x,comp mk_cl s (subs_liftn (k-1) s')) + | LIFT(k,s), SHIFT(k',s') -> + if k + if k [n] i.e under n binders. *) +type lift = + | ELID + | ELSHFT of lift * int + | ELLFT of int * lift + +val el_shft : int -> lift -> lift +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]. [ESID n] = %n~END = bounded identity. + [CONS(t,S)] = $S.t$ i.e. parallel substitution. [SHIFT(n,S)] = + $(\uparrow n~o~S)$ i.e. terms in S are relocated with n vars. + [LIFT(n,S)] = $(\%n~S)$ stands for $((\uparrow n~o~S).n...1)$. *) +type 'a subs = + | ESID of int + | CONS of 'a * 'a subs + | SHIFT of int * 'a subs + | LIFT of int * 'a subs + +val subs_cons: 'a * '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 -> '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 \ No newline at end of file diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml new file mode 100644 index 00000000..88f837aa --- /dev/null +++ b/kernel/indtypes.ml @@ -0,0 +1,548 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* idset + | c::cl -> + if Idset.mem c idset then + raise (InductiveError (SameNamesConstructors (id,c))) + else + check (Idset.add c idset) cl + in + check + +(* [mind_check_names mie] checks the names of an inductive types declaration, + and raises the corresponding exceptions when two types or two constructors + have the same name. *) + +let mind_check_names mie = + let rec check indset cstset = function + | [] -> () + | ind::inds -> + let id = ind.mind_entry_typename in + let cl = ind.mind_entry_consnames in + if Idset.mem id indset then + raise (InductiveError (SameNamesTypes id)) + else + let cstset' = check_constructors_names id cstset cl in + check (Idset.add id indset) cstset' inds + in + check Idset.empty Idset.empty mie.mind_entry_inds +(* The above verification is not necessary from the kernel point of + vue since inductive and constructors are not referred to by their + name, but only by the name of the inductive packet and an index. *) + +let mind_check_arities env mie = + let check_arity id c = + if not (is_arity env c) then + raise (InductiveError (NotAnArity id)) + in + List.iter + (fun {mind_entry_typename=id; mind_entry_arity=ar} -> check_arity id ar) + mie.mind_entry_inds + +(************************************************************************) +(************************************************************************) + +(* Typing the arities and constructor types *) + +let is_info_arity env c = + match dest_arity env c with + | (_,Prop Null) -> false + | (_,Prop Pos) -> true + | (_,Type _) -> true + +let is_info_type env t = + let s = t.utj_type in + if s = mk_Set then true + else if s = mk_Prop then false + else + try is_info_arity env t.utj_val + with UserError _ -> true + +(* [infos] is a sequence of pair [islogic,issmall] for each type in + the product of a constructor or arity *) + +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 +let is_logic_arity infos = + List.for_all (fun (logic,small) -> logic || small) 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, conjonction of logical properties +*) +let is_unit constrsinfos = + match constrsinfos with (* One info = One constructor *) + | [constrinfos] -> is_logic_constr constrinfos + | [] -> (* type without constructors *) true + | _ -> false + +let rec infos_and_sort env t = + match kind_of_term t with + | Prod (name,c1,c2) -> + let (varj,_) = infer_type env c1 in + let env1 = Environ.push_rel (name,None,varj.utj_val) env in + let logic = not (is_info_type env varj) in + let small = Term.is_small varj.utj_type in + (logic,small) :: (infos_and_sort env1 c2) + | Cast (c,_) -> infos_and_sort env c + | _ -> [] + +let small_unit constrsinfos = + let issmall = List.for_all is_small constrsinfos + and isunit = is_unit constrsinfos in + issmall, isunit + +(* This (re)computes informations relevant to extraction and the sort of an + arity or type constructor; we do not to recompute universes constraints *) + +(* [smax] is the max of the sorts of the products of the constructor type *) + +let enforce_type_constructor env arsort smax cst = + match smax, arsort with + | Type uc, Type ua -> enforce_geq ua uc cst + | Type uc, Prop Pos when engagement env <> Some ImpredicativeSet -> + error "Large non-propositional inductive types must be in Type" + | _,_ -> cst + +let type_one_constructor env_ar_par params arsort c = + let infos = infos_and_sort env_ar_par c in + + (* Each constructor is typed-checked here *) + let (j,cst) = infer_type env_ar_par c in + let full_cstr_type = it_mkProd_or_LetIn j.utj_val params in + + (* If the arity is at some level Type arsort, then the sort of the + constructor must be below arsort; here we consider constructors with the + global parameters (which add a priori more constraints on their sort) *) + let cst2 = enforce_type_constructor env_ar_par arsort j.utj_type cst in + + (infos, full_cstr_type, cst2) + +let infer_constructor_packet env_ar params arsort vc = + let env_ar_par = push_rel_context params env_ar in + let (constrsinfos,jlc,cst) = + List.fold_right + (fun c (infosl,l,cst) -> + let (infos,ct,cst') = + type_one_constructor env_ar_par params arsort c in + (infos::infosl,ct::l, Constraint.union cst cst')) + vc + ([],[],Constraint.empty) in + let vc' = Array.of_list jlc in + let issmall,isunit = small_unit constrsinfos in + (issmall,isunit,vc', cst) + +(* Type-check an inductive definition. Does not check positivity + conditions. *) +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; + (* We first type params and arity of each inductive definition *) + (* This allows to build the environment of arities and to share *) + (* the set of constraints *) + let cst, arities, rev_params_arity_list = + List.fold_left + (fun (cst,arities,l) ind -> + (* Params are typed-checked here *) + let params = ind.mind_entry_params in + let env_params, params, cst1 = + infer_local_decls env params in + (* Arities (without params) are typed-checked here *) + let arity, cst2 = + infer_type env_params ind.mind_entry_arity in + (* We do not need to generate the universe of full_arity; if + later, after the validation of the inductive definition, + full_arity is used as argument or subject to cast, an + upper universe will be generated *) + let id = ind.mind_entry_typename in + let full_arity = it_mkProd_or_LetIn arity.utj_val params in + Constraint.union cst (Constraint.union cst1 cst2), + Sign.add_rel_decl (Name id, None, full_arity) arities, + (params, id, full_arity, arity.utj_val)::l) + (Constraint.empty,empty_rel_context,[]) + mie.mind_entry_inds in + + let env_arities = push_rel_context arities env in + + let params_arity_list = List.rev rev_params_arity_list in + + (* Now, we type the constructors (without params) *) + let inds,cst = + List.fold_right2 + (fun ind (params,id,full_arity,short_arity) (inds,cst) -> + let (_,arsort) = dest_arity env full_arity in + let lc = ind.mind_entry_lc in + let (issmall,isunit,lc',cst') = + infer_constructor_packet env_arities params arsort lc in + let consnames = ind.mind_entry_consnames in + let ind' = (params,id,full_arity,consnames,issmall,isunit,lc') + in + (ind'::inds, Constraint.union cst cst')) + mie.mind_entry_inds + params_arity_list + ([],cst) in + (env_arities, Array.of_list inds, cst) + +(************************************************************************) +(************************************************************************) +(* Positivity *) + +type ill_formed_ind = + | LocalNonPos of int + | LocalNotEnoughArgs of int + | LocalNotConstructor + | LocalNonPar of int * int + +exception IllFormedInd of ill_formed_ind + +(* [mind_extract_params mie] extracts the params from an inductive types + declaration, and checks that they are all present (and all the same) + for all the given types. *) + +let mind_extract_params = decompose_prod_n_assum + +let explain_ind_err ntyp env0 nbpar c err = + let (lpar,c') = mind_extract_params nbpar c in + let env = push_rel_context lpar env0 in + match err with + | LocalNonPos kt -> + raise (InductiveError (NonPos (env,c',mkRel (kt+nbpar)))) + | LocalNotEnoughArgs kt -> + raise (InductiveError + (NotEnoughArgs (env,c',mkRel (kt+nbpar)))) + | LocalNotConstructor -> + raise (InductiveError + (NotConstructor (env,c',mkRel (ntyp+nbpar)))) + | LocalNonPar (n,l) -> + raise (InductiveError + (NonPar (env,c',n,mkRel (nbpar-n+1), mkRel (l+nbpar)))) + +let failwith_non_pos_vect n ntypes v = + for i = 0 to Array.length v - 1 do + for k = n to n + ntypes - 1 do + if not (noccurn k v.(i)) then raise (IllFormedInd (LocalNonPos (k-n+1))) + done + done; + anomaly "failwith_non_pos_vect: some k in [n;n+ntypes-1] should occur in v" + +(* Check the inductive type is called with the expected parameters *) +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 + raise (IllFormedInd (LocalNotEnoughArgs l)); + let (lpar,largs') = array_chop nparams largs in + let nhyps = List.length hyps in + let rec check k index = function + | [] -> () + | (_,Some _,_)::hyps -> check k (index+1) hyps + | _::hyps -> + match kind_of_term (whd_betadeltaiota env lpar.(k)) with + | 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 + failwith_non_pos_vect n ntypes largs' + +(* 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 + lc + else + let make_abs = + list_tabulate + (function i -> lambda_implicit_lift npars (mkRel (i+1))) ntyps + in + Array.map (substl make_abs) lc + +(* [env] is the typing environment + [n] is the dB of the last inductive type + [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) + +let ienv_push_inductive (env, n, ntypes, ra_env) (mi,lpar) = + let auxntyp = 1 in + let env' = + push_rel (Anonymous,None, + hnf_prod_applist env (type_of_inductive env mi) lpar) env in + let ra_env' = + (Imbr mi,Rtree.mk_param 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') + +(* The recursive function that checks positivity and builds the list + of recursive arguments *) +let check_positivity_one (env, _,ntypes,_ as ienv) hyps i indlc = + let nparams = rel_context_length hyps in + (* check the inductive types occur positively in [c] *) + let rec check_pos (env, n, ntypes, ra_env as ienv) c = + let x,largs = decompose_app (whd_betadeltaiota env c) in + match kind_of_term x with + | Prod (na,b,d) -> + assert (largs = []); + if not (noccur_between n ntypes b) then + raise (IllFormedInd (LocalNonPos n)); + check_pos (ienv_push_var ienv (na, b, mk_norec)) d + | Rel k -> + let (ra,rarg) = + try List.nth ra_env (k-1) + with Failure _ | Invalid_argument _ -> (Norec,mk_norec) in + (match ra with + Mrec _ -> check_correct_par ienv hyps (k-n+1) largs + | _ -> + if not (List.for_all (noccur_between n ntypes) largs) + then raise (IllFormedInd (LocalNonPos n))); + rarg + | Ind ind_kn -> + (* If the inductive type being defined appears in a + parameter, then we have an imbricated type *) + if List.for_all (noccur_between n ntypes) largs then mk_norec + else check_positive_imbr ienv (ind_kn, largs) + | err -> + if noccur_between n ntypes x && + List.for_all (noccur_between n ntypes) largs + then mk_norec + else raise (IllFormedInd (LocalNonPos n)) + + (* accesses to the environment are not factorised, but does it worth + it? *) + and check_positive_imbr (env,n,ntypes,ra_env as ienv) (mi, largs) = + let (mib,mip) = lookup_mind_specif env mi in + let auxnpar = mip.mind_nparams in + let (lpar,auxlargs) = + 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)); + (* We do not deal with imbricated mutual inductive types *) + 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 + (* Extends the environment with a variable corresponding to + the inductive def *) + 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 = + (* 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 c') + auxlcvect + in + (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 c = + let rec check_constr_rec (env,n,ntypes,ra_env as ienv) lrec c = + let x,largs = decompose_app (whd_betadeltaiota env c) in + match kind_of_term x with + + | Prod (na,b,d) -> + assert (largs = []); + let recarg = check_pos ienv b in + let ienv' = ienv_push_var ienv (na,b,mk_norec) in + check_constr_rec ienv' (recarg::lrec) d + + | hd -> + if check_head then + if hd = Rel (n+ntypes-i-1) then + check_correct_par ienv hyps (ntypes-i) largs + else + raise (IllFormedInd LocalNotConstructor) + else + if not (List.for_all (noccur_between n ntypes) largs) + then raise (IllFormedInd (LocalNonPos n)); + List.rev lrec + in check_constr_rec ienv [] c + in + mk_paths (Mrec i) + (Array.map + (fun c -> + let c = body_of_type c in + let sign, rawc = mind_extract_params nparams c in + let env' = push_rel_context sign env in + try + check_constructors ienv true rawc + with IllFormedInd err -> + explain_ind_err (ntypes-i) env nparams c err) + indlc) + +let check_positivity env_ar inds = + let ntypes = Array.length inds in + let lra_ind = + List.rev (list_tabulate (fun j -> (Mrec j, Rtree.mk_param j)) ntypes) in + let check_one i (params,_,_,_,_,_,lc) = + let nparams = rel_context_length params in + let ra_env = + list_tabulate (fun _ -> (Norec,mk_norec)) nparams @ lra_ind in + let ienv = (env_ar, 1+nparams, ntypes, ra_env) in + check_positivity_one ienv params i lc in + Rtree.mk_rec (Array.mapi check_one inds) + + +(************************************************************************) +(************************************************************************) +(* Build the inductive packet *) + +(* Elimination sorts *) +let is_recursive = Rtree.is_infinite +(* let rec one_is_rec rvec = + List.exists (function Mrec(i) -> List.mem i listind + | Imbr(_,lvec) -> array_exists one_is_rec lvec + | Norec -> false) rvec + in + array_exists one_is_rec +*) + +let all_sorts = [InProp;InSet;InType] +let impredicative_sorts = [InProp;InSet] +let logical_sorts = [InProp] + +let allowed_sorts env issmall isunit = function + | Type _ -> all_sorts + | Prop Pos -> + if issmall then all_sorts + else impredicative_sorts + | Prop Null -> +(* Added InType which is derivable :when the type is unit and small *) +(* unit+small types have all elimination + In predicative system, the + other inductive definitions have only Prop elimination. + In impredicative system, large unit type have also Set elimination +*) if isunit then + if issmall then all_sorts + else if Environ.engagement env = None + then logical_sorts else impredicative_sorts + else logical_sorts + +let build_inductive env env_ar finite inds recargs cst = + let ntypes = Array.length inds in + (* Compute the set of used section variables *) + let ids = + Array.fold_left + (fun acc (_,_,ar,_,_,_,lc) -> + Idset.union (Environ.global_vars_set env (body_of_type ar)) + (Array.fold_left + (fun acc c -> + Idset.union (global_vars_set env (body_of_type c)) acc) + acc + lc)) + Idset.empty inds in + let hyps = keep_hyps env ids in + (* Check one inductive *) + let build_one_packet (params,id,ar,cnames,issmall,isunit,lc) recarg = + (* Arity in normal form *) + let nparamargs = rel_context_nhyps params in + let (ar_sign,ar_sort) = dest_arity env ar in + let nf_ar = + if isArity (body_of_type ar) then ar + else it_mkProd_or_LetIn (mkSort ar_sort) ar_sign in + (* Type of constructors in normal form *) + let splayed_lc = Array.map (dest_prod_assum env_ar) lc in + let nf_lc = + array_map2 (fun (d,b) c -> it_mkProd_or_LetIn b d) splayed_lc lc in + let nf_lc = if nf_lc = lc then lc else nf_lc in + (* Elimination sorts *) + let isunit = isunit && ntypes = 1 && (not (is_recursive recargs.(0))) in + let kelim = allowed_sorts env issmall isunit ar_sort in + (* Build the inductive packet *) + { mind_typename = id; + mind_nparams = nparamargs; + mind_params_ctxt = params; + mind_user_arity = ar; + mind_nf_arity = nf_ar; + mind_nrealargs = rel_context_nhyps ar_sign - nparamargs; + mind_sort = ar_sort; + mind_kelim = kelim; + mind_consnames = Array.of_list cnames; + mind_user_lc = lc; + mind_nf_lc = nf_lc; + mind_recargs = recarg; + } in + let packets = array_map2 build_one_packet inds recargs in + (* Build the mutual inductive *) + { mind_ntypes = ntypes; + mind_finite = finite; + mind_hyps = hyps; + mind_packets = packets; + mind_constraints = cst; + mind_equiv = None; + } + +(************************************************************************) +(************************************************************************) + +let check_inductive env mie = + (* First type-check the inductive definition *) + let (env_arities, inds, cst) = typecheck_inductive env mie in + (* Then check positivity conditions *) + let recargs = check_positivity env_arities inds in + (* Build the inductive packets *) + build_inductive env env_arities mie.mind_entry_finite inds recargs cst + diff --git a/kernel/indtypes.mli b/kernel/indtypes.mli new file mode 100644 index 00000000..f5e6d047 --- /dev/null +++ b/kernel/indtypes.mli @@ -0,0 +1,46 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* mutual_inductive_entry -> mutual_inductive_body diff --git a/kernel/inductive.ml b/kernel/inductive.ml new file mode 100644 index 00000000..07e9b8ea --- /dev/null +++ b/kernel/inductive.ml @@ -0,0 +1,831 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* = Array.length mib.mind_packets then + error "Inductive.lookup_mind_specif: invalid inductive index"; + (mib, mib.mind_packets.(tyi)) + +let find_rectype env c = + let (t, l) = decompose_app (whd_betadeltaiota env c) in + match kind_of_term t with + | Ind ind -> (ind, l) + | _ -> raise Not_found + +let find_inductive env c = + let (t, l) = decompose_app (whd_betadeltaiota env c) in + match kind_of_term t with + | Ind ind + when (fst (lookup_mind_specif env ind)).mind_finite -> (ind, l) + | _ -> raise Not_found + +let find_coinductive env c = + let (t, l) = decompose_app (whd_betadeltaiota env c) in + match kind_of_term t with + | Ind ind + when not (fst (lookup_mind_specif env ind)).mind_finite -> (ind, l) + | _ -> raise Not_found + +(************************************************************************) + +(* Build the substitution that replaces Rels by the appropriate *) +(* inductives *) +let ind_subst mind mib = + let ntypes = mib.mind_ntypes in + let make_Ik k = mkInd (mind,ntypes-k-1) in + list_tabulate make_Ik ntypes + +(* Instantiate inductives in constructor type *) +let constructor_instantiate mind mib c = + let s = ind_subst mind mib in + type_app (substl s) c + +(* Instantiate the parameters of the inductive type *) +(* TODO: verify the arg of LetIn correspond to the value in the + signature ? *) +let instantiate_params t args sign = + let fail () = + anomaly "instantiate_params: type, ctxt and args mismatch" in + let (rem_args, subs, ty) = + Sign.fold_rel_context + (fun (_,copt,_) (largs,subs,ty) -> + match (copt, largs, kind_of_term ty) with + | (None, a::args, Prod(_,_,t)) -> (args, a::subs, t) + | (Some b,_,LetIn(_,_,_,t)) -> (largs, (substl subs b)::subs, t) + | _ -> fail()) + sign + ~init:(args,[],t) + in + if rem_args <> [] then fail(); + type_app (substl subs) ty + +let full_inductive_instantiate mip params t = + instantiate_params t params mip.mind_params_ctxt + +let full_constructor_instantiate (((mind,_),mib,mip),params) = + let inst_ind = constructor_instantiate mind mib in + (fun t -> + instantiate_params (inst_ind t) params mip.mind_params_ctxt) + +(************************************************************************) +(************************************************************************) + +(* Functions to build standard types related to inductive *) + +(* Type of an inductive type *) + +let type_of_inductive env i = + let (_,mip) = lookup_mind_specif env i in + mip.mind_user_arity + +(************************************************************************) +(* Type of a constructor *) + +let type_of_constructor env cstr = + let ind = inductive_of_constructor cstr in + let (mib,mip) = lookup_mind_specif env ind in + let specif = mip.mind_user_lc in + let i = index_of_constructor cstr in + let nconstr = Array.length mip.mind_consnames in + 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 specif = mip.mind_nf_lc in + Array.map (constructor_instantiate kn mib) specif + +let arities_of_constructors env ind = + arities_of_specif (fst ind) (lookup_mind_specif env ind) + + + +(************************************************************************) + +let is_info_arity env c = + match dest_arity env c with + | (_,Prop Null) -> false + | (_,Prop Pos) -> true + | (_,Type _) -> true + +let error_elim_expln env kp ki = + if is_info_arity env kp && not (is_info_arity env ki) then + NonInformativeToInformative + else + match (kind_of_term kp,kind_of_term ki) with + | Sort (Type _), Sort (Prop _) -> StrongEliminationOnNonSmallType + | _ -> WrongArity + +(* Type of case predicates *) + +let local_rels ctxt = + let (rels,_) = + Sign.fold_rel_context_reverse + (fun (rels,n) (_,copt,_) -> + match copt with + None -> (mkRel n :: rels, n+1) + | Some _ -> (rels, n+1)) + ~init:([],1) + ctxt + in + rels + +(* Get type of inductive, with parameters instantiated *) +let get_arity mip params = + let arity = mip.mind_nf_arity in + destArity (full_inductive_instantiate mip params arity) + +let build_dependent_inductive ind mip params = + let arsign,_ = get_arity mip params in + let nrealargs = mip.mind_nrealargs in + applist + (mkInd ind, (List.map (lift nrealargs) params)@(local_rels arsign)) + + +(* This exception is local *) +exception LocalArity of (constr * constr * arity_error) option + +let is_correct_arity env c pj ind mip params = + let kelim = mip.mind_kelim in + let arsign,s = get_arity mip params in + let nodep_ar = it_mkProd_or_LetIn (mkSort s) arsign in + let rec srec env pt t u = + let pt' = whd_betadeltaiota env pt in + let t' = whd_betadeltaiota env t in + match kind_of_term pt', kind_of_term t' with + | Prod (na1,a1,a2), Prod (_,a1',a2') -> + let univ = + try conv env a1 a1' + with NotConvertible -> raise (LocalArity None) in + srec (push_rel (na1,None,a1) env) a2 a2' (Constraint.union u univ) + | Prod (_,a1,a2), _ -> + let k = whd_betadeltaiota env a2 in + let ksort = match kind_of_term k with + | Sort s -> family_of_sort s + | _ -> raise (LocalArity None) in + let dep_ind = build_dependent_inductive ind mip params in + let univ = + try conv env a1 dep_ind + with NotConvertible -> raise (LocalArity None) in + if List.exists ((=) ksort) kelim then + (true, Constraint.union u univ) + else + raise (LocalArity (Some(k,t',error_elim_expln env k t'))) + | k, Prod (_,_,_) -> + raise (LocalArity None) + | k, ki -> + let ksort = match k with + | Sort s -> family_of_sort s + | _ -> raise (LocalArity None) in + if List.exists ((=) ksort) kelim then + (false, u) + else + raise (LocalArity (Some(pt',t',error_elim_expln env pt' t'))) + in + try srec env pj.uj_type nodep_ar Constraint.empty + with LocalArity kinds -> + let create_sort = function + | InProp -> mkProp + | InSet -> mkSet + | InType -> mkSort type_0 in + let listarity = List.map create_sort kelim +(* let listarity = + (List.map (fun s -> make_arity env true indf (create_sort s)) kelim) + @(List.map (fun s -> make_arity env false indf (create_sort s)) kelim)*) + in + error_elim_arity env ind listarity c pj kinds + + +(************************************************************************) +(* Type of case branches *) + +(* [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 mib mip params dep p = + let build_one_branch i cty = + let typi = full_constructor_instantiate ((ind,mib,mip),params) cty in + let (args,ccl) = decompose_prod_assum typi in + let nargs = rel_context_length args in + let (_,allargs) = decompose_app ccl in + let (lparams,vargs) = list_chop mip.mind_nparams 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 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 type_case_branches env (ind,largs) pj c = + let (mib,mip) = lookup_mind_specif env ind in + let nparams = mip.mind_nparams 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 mip params in + let lc = build_branches_type ind mib mip params dep p in + let ty = build_case_type dep p c realargs in + (lc, ty, univ) + + +(************************************************************************) +(* Checking the case annotation is relevent *) + +let check_case_info env indsp ci = + let (mib,mip) = lookup_mind_specif env indsp in + if + (indsp <> ci.ci_ind) or + (mip.mind_nparams <> ci.ci_npar) + then raise (TypeError(env,WrongCaseInfo(indsp,ci))) + +(************************************************************************) +(************************************************************************) + +(* Guard conditions for fix and cofix-points *) + +(* 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 *) + +(* A powerful notion of subterm *) + +(* To each inductive definition corresponds an array describing the + structure of recursive arguments for each constructor, we call it + the recursive spec of the type (it has type recargs vect). For + checking the guard, we start from the decreasing argument (Rel n) + with its recursive spec. During checking the guardness condition, + we collect patterns variables corresponding to subterms of n, each + of them with its recursive spec. They are organised in a list lst + of type (int * recargs) list which is sorted with respect to the + first argument. +*) + +(*************************) +(* Environment annotated with marks on recursive arguments: + it is a triple (env,lst,n) where + - env is the typing environment + - lst is a mapping from de Bruijn indices to list of recargs + (tells which subterms of that variable are recursive) + - n is the de Bruijn index of the fixpoint for which we are + checking the guard condition. + + Below are functions to handle such environment. + *) +type size = Large | Strict + +let size_glb s1 s2 = + match s1,s2 with + Strict, Strict -> Strict + | _ -> Large + +type subterm_spec = + Subterm of (size * wf_paths) + | Dead_code + | Not_subterm + +let spec_of_tree t = + if t=mk_norec then Not_subterm else Subterm(Strict,t) + +let subterm_spec_glb = + let glb2 s1 s2 = + match s1,s2 with + _, Dead_code -> s1 + | Dead_code, _ -> s2 + | Not_subterm, _ -> Not_subterm + | _, Not_subterm -> Not_subterm + | Subterm (a1,t1), Subterm (a2,t2) -> + if t1=t2 then Subterm (size_glb a1 a2, t1) + (* 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 *) + rel_min : int; + (* inductive of recarg of each fixpoint *) + inds : inductive array; + (* the recarg information of inductive family *) + recvec : wf_paths array; + (* dB of variables denoting subterms *) + genv : subterm_spec list; + } + +let make_renv env minds recarg (kn,tyi) = + let mib = Environ.lookup_mind kn env in + let mind_recvec = + Array.map (fun mip -> mip.mind_recargs) mib.mind_packets in + { env = env; + rel_min = recarg+2; + inds = minds; + recvec = mind_recvec; + genv = [Subterm(Large,mind_recvec.(tyi))] } + +let push_var renv (x,ty,spec) = + { renv with + env = push_rel (x,None,ty) renv.env; + rel_min = renv.rel_min+1; + genv = spec:: renv.genv } + +let assign_var_spec renv (i,spec) = + { renv with genv = list_assign renv.genv (i-1) spec } + +let push_var_renv renv (x,ty) = + push_var renv (x,ty,Not_subterm) + +(* Fetch recursive information about a variable p *) +let subterm_var p renv = + try List.nth renv.genv (p-1) + with Failure _ | Invalid_argument _ -> Not_subterm + +(* Add a variable and mark it as strictly smaller with information [spec]. *) +let add_subterm renv (x,a,spec) = + push_var renv (x,a,spec_of_tree spec) + +let push_ctxt_renv renv ctxt = + let n = rel_context_length ctxt in + { renv with + env = push_rel_context ctxt renv.env; + rel_min = renv.rel_min+n; + genv = iterate (fun ge -> Not_subterm::ge) n renv.genv } + +let push_fix_renv renv (_,v,_ as recdef) = + let n = Array.length v in + { renv with + env = push_rec_types recdef renv.env; + rel_min = renv.rel_min+n; + genv = iterate (fun ge -> Not_subterm::ge) n renv.genv } + + +(******************************) +(* Computing the recursive subterms of a term (propagation of size + information through Cases). *) + +(* + c is a branch of an inductive definition corresponding to the spec + lrec. mind_recvec is the recursive spec of the inductive + definition of the decreasing argument n. + + case_branches_specif renv lrec lc will pass the lambdas + of c corresponding to pattern variables and collect possibly new + subterms variables and returns the bodies of the branches with the + correct envs and decreasing args. +*) + +let lookup_subterms env ind = + let (_,mip) = lookup_mind_specif env ind in + mip.mind_recargs + +(*********************************) + +(* finds the inductive type of the recursive argument of a fixpoint *) +let inductive_of_fix env recarg body = + let (ctxt,b) = decompose_lam_n_assum recarg body in + let env' = push_rel_context ctxt env in + let (_,ty,_) = destLambda(whd_betadeltaiota env' b) in + let (i,_) = decompose_app (whd_betadeltaiota env' ty) in + destInd i + +(* + subterm_specif env c ind + + subterm_specif should test if [c] (building objects of inductive + type [ind], not necassarily the same as that of the recursive + argument) is a subterm of the recursive argument of the fixpoint we + are checking and fails with Not_found if not. In case it is, it + should send its recursive specification (i.e. on which arguments we + are allowed to make recursive calls). This recursive spec should be + the same size as the number of constructors of the type of c. + + Returns: + - [Some lc] if [c] is a strict subterm of the rec. arg. (or a Meta) + - [None] otherwise +*) + +let rec subterm_specif renv t ind = + let f,l = decompose_app (whd_betadeltaiota renv.env t) in + match kind_of_term f with + | Rel k -> subterm_var k renv + + | Case (ci,_,c,lbr) -> + if Array.length lbr = 0 then Dead_code + else + let lbr_spec = case_branches_specif renv c ci.ci_ind lbr in + let stl = + Array.map (fun (renv',br') -> subterm_specif renv' br' ind) + lbr_spec in + subterm_spec_glb stl + + | Fix ((recindxs,i),(_,typarray,bodies as recdef)) -> +(* when proving that the fixpoint f(x)=e is less than n, it is enough + to prove that e is less than n assuming f is less than n + furthermore when f is applied to a term which is strictly less than + n, one may assume that x itself is strictly less than n +*) + let nbfix = Array.length typarray in + let recargs = lookup_subterms renv.env ind in + (* pushing the fixpoints *) + let renv' = push_fix_renv renv recdef in + let renv' = + assign_var_spec renv' (nbfix-i, Subterm(Strict,recargs)) in + let decrArg = recindxs.(i) in + let theBody = bodies.(i) in + let nbOfAbst = decrArg+1 in + let sign,strippedBody = decompose_lam_n_assum nbOfAbst theBody in + (* pushing the fix parameters *) + let renv'' = push_ctxt_renv renv' sign in + let renv'' = + if List.length l < nbOfAbst then renv'' + else + let decrarg_ind = inductive_of_fix renv''.env decrArg theBody in + let theDecrArg = List.nth l decrArg in + let arg_spec = subterm_specif renv theDecrArg decrarg_ind in + assign_var_spec renv'' (1, arg_spec) in + subterm_specif renv'' strippedBody ind + + | Lambda (x,a,b) -> + assert (l=[]); + subterm_specif (push_var_renv renv (x,a)) b ind + + (* A term with metas is considered OK *) + | Meta _ -> Dead_code + (* Other terms are not subterms *) + | _ -> Not_subterm + +(* Propagation of size information through Cases: if the matched + object is a recursive subterm then compute the information + associated to its own subterms. + Rq: if branch is not eta-long, then the recursive information + is not propagated *) +and case_branches_specif renv c ind lbr = + let c_spec = subterm_specif renv c ind in + let rec push_branch_args renv lrec c = + let c' = strip_outer_cast (whd_betadeltaiota renv.env c) in + match lrec, kind_of_term c' with + | (ra::lr,Lambda (x,a,b)) -> + let renv' = push_var renv (x,a,ra) in + push_branch_args renv' lr b + | (_,_) -> (renv,c') in + match c_spec with + Subterm (_,t) -> + 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 -> + 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); + array_map2 (push_branch_args renv) sub_spec lbr + | Not_subterm -> Array.map (fun c -> (renv,c)) lbr + +(* Check term c can be applied to one of the mutual fixpoints. *) +let check_is_subterm renv c ind = + match subterm_specif renv c ind with + Subterm (Strict,_) | Dead_code -> true + | _ -> false + +(************************************************************************) + +exception FixGuardError of env * guard_error + +let error_illegal_rec_call renv fx arg = + let (_,le_vars,lt_vars) = + List.fold_left + (fun (i,le,lt) sbt -> + match sbt with + (Subterm(Strict,_) | Dead_code) -> (i+1, le, i::lt) + | (Subterm(Large,_)) -> (i+1, i::le, lt) + | _ -> (i+1, le ,lt)) + (1,[],[]) renv.genv in + raise (FixGuardError (renv.env, + RecursionOnIllegalTerm(fx,arg,le_vars,lt_vars))) + +let error_partial_apply renv fx = + raise (FixGuardError (renv.env,NotEnoughArgumentsForFixCall fx)) + + +(* Check if [def] is a guarded fixpoint body with decreasing arg. + given [recpos], the decreasing arguments of each mutually defined + fixpoint. *) +let check_one_fix renv recpos def = + let nfi = Array.length recpos in + let rec check_rec_call renv t = + (* if [t] does not make recursive calls, it is guarded: *) + noccur_with_meta renv.rel_min nfi t or + (* Rq: why not try and expand some definitions ? *) + let f,l = decompose_app (whd_betaiotazeta renv.env t) in + match kind_of_term f with + | Rel p -> + (* Test if it is a recursive call: *) + if renv.rel_min <= p & p < renv.rel_min+nfi then + (* the position of the invoked fixpoint: *) + let glob = renv.rel_min+nfi-1-p in + (* the decreasing arg of the rec call: *) + let np = recpos.(glob) in + if List.length l <= np then error_partial_apply renv glob; + match list_chop np l with + (la,(z::lrest)) -> + (* Check the decreasing arg is smaller *) + if not (check_is_subterm renv z renv.inds.(glob)) then + error_illegal_rec_call renv glob z; + List.for_all (check_rec_call renv) (la@lrest) + | _ -> assert false + (* otherwise check the arguments are guarded: *) + else List.for_all (check_rec_call renv) l + + | Case (ci,p,c_0,lrest) -> + List.for_all (check_rec_call renv) (c_0::p::l) && + (* compute the recarg information for the arguments of + each branch *) + let lbr = case_branches_specif renv c_0 ci.ci_ind lrest in + array_for_all (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/1 := [y1:T1]...[yp:Tp]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 + 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.for_all (check_rec_call renv) l && + array_for_all (check_rec_call renv) typarray && + let nbfix = Array.length typarray in + let decrArg = recindxs.(i) in + let renv' = push_fix_renv renv recdef in + if (List.length l < (decrArg+1)) then + array_for_all (check_rec_call renv') bodies + else + let ok_vect = + Array.mapi + (fun j body -> + if i=j then + let decrarg_ind = + inductive_of_fix renv'.env decrArg body in + let theDecrArg = List.nth l decrArg in + let arg_spec = + subterm_specif renv theDecrArg decrarg_ind in + check_nested_fix_body renv' (decrArg+1) arg_spec body + else check_rec_call renv' body) + bodies in + array_for_all (fun b -> b) ok_vect + + | Const kn as c -> + (try List.for_all (check_rec_call renv) l + with (FixGuardError _ ) as e -> + if evaluable_constant kn renv.env then + check_rec_call renv + (applist(constant_value renv.env kn, l)) + else raise e) + + (* The cases below simply check recursively the condition on the + subterms *) + | Cast (a,b) -> + List.for_all (check_rec_call renv) (a::b::l) + + | Lambda (x,a,b) -> + check_rec_call (push_var_renv renv (x,a)) b && + List.for_all (check_rec_call renv) (a::l) + + | Prod (x,a,b) -> + check_rec_call (push_var_renv renv (x,a)) b && + List.for_all (check_rec_call renv) (a::l) + + | CoFix (i,(_,typarray,bodies as recdef)) -> + array_for_all (check_rec_call renv) typarray && + List.for_all (check_rec_call renv) l && + let renv' = push_fix_renv renv recdef in + array_for_all (check_rec_call renv') bodies + + | Evar (_,la) -> + array_for_all (check_rec_call renv) la && + List.for_all (check_rec_call renv) l + + | Meta _ -> true + + | (App _ | LetIn _) -> + anomaly "check_rec_call: should have been reduced" + + | (Ind _ | Construct _ | Var _ | Sort _) -> + List.for_all (check_rec_call renv) l + + and check_nested_fix_body renv decr recArgsDecrArg body = + if decr = 0 then + check_rec_call (assign_var_spec renv (1,recArgsDecrArg)) body + else + match kind_of_term body with + | Lambda (x,a,b) -> + let renv' = push_var_renv renv (x,a) in + check_rec_call renv a && + check_nested_fix_body renv' (decr-1) recArgsDecrArg b + | _ -> anomaly "Not enough abstractions in fix body" + + in + check_rec_call renv def + + +let inductive_of_mutfix env ((nvect,bodynum),(names,types,bodies as recdef)) = + let nbfix = Array.length bodies in + if nbfix = 0 + or Array.length nvect <> nbfix + or Array.length types <> nbfix + or Array.length names <> nbfix + or bodynum < 0 + or bodynum >= nbfix + then anomaly "Ill-formed fix term"; + let fixenv = push_rec_types recdef env in + let raise_err i err = + error_ill_formed_rec_body fixenv err names i in + (* Check the i-th definition with recarg k *) + let find_ind i k def = + if k < 0 then anomaly "negative recarg position"; + (* 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 = + match kind_of_term (whd_betadeltaiota env def) with + | 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 + with Not_found -> raise_err i RecursionNotOnInductiveType in + (mind, (env', b)) + else check_occur env' (n+1) b + else anomaly "check_one_fix: Bad occurrence of recursive call" + | _ -> raise_err i NotEnoughAbstractionInFixBody in + check_occur fixenv 1 def in + (* Do it on every fixpoint *) + let rv = array_map2_i find_ind nvect bodies in + (Array.map fst rv, Array.map snd rv) + + +let check_fix env ((nvect,_),(names,_,bodies as recdef) as fix) = + let (minds, rdef) = inductive_of_mutfix env fix in + for i = 0 to Array.length bodies - 1 do + let (fenv,body) = rdef.(i) in + let renv = make_renv fenv minds nvect.(i) minds.(i) in + try + let _ = check_one_fix renv nvect body in () + with FixGuardError (fixenv,err) -> + error_ill_formed_rec_body fixenv err names i + done + +(* +let cfkey = Profile.declare_profile "check_fix";; +let check_fix env fix = Profile.profile3 cfkey check_fix env fix;; +*) + +(************************************************************************) +(* Scrape *) + +let rec scrape_mind env kn = + match (Environ.lookup_mind kn env).mind_equiv with + | None -> kn + | Some kn' -> scrape_mind env kn' + +(************************************************************************) +(* Co-fixpoints. *) + +exception CoFixGuardError of env * guard_error + +let anomaly_ill_typed () = + anomaly "check_one_cofix: too many arguments applied to constructor" + +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 + | _ -> + (try find_coinductive env b + with Not_found -> + raise (CoFixGuardError (env, CodomainNotInductiveType b))) + +let check_one_cofix env nbfix def deftype = + let rec check_rec_call env alreadygrd n vlra t = + if noccur_with_meta n nbfix t then + true + else + let c,args = decompose_app (whd_betadeltaiota env t) in + match kind_of_term c with + | Meta _ -> true + + | Rel p when n <= p && p < n+nbfix -> + (* recursive call *) + if alreadygrd then + if List.for_all (noccur_with_meta n nbfix) args then + true + else + raise (CoFixGuardError (env,NestedRecursiveOccurrences)) + else + raise (CoFixGuardError (env,UnguardedRecursiveCall t)) + + | Construct (_,i as cstr_kn) -> + 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 mip.mind_nparams args in + let rec process_args_of_constr = function + | (t::lr), (rar::lrar) -> + if rar = mk_norec then + if noccur_with_meta n nbfix t + then process_args_of_constr (lr, lrar) + else raise (CoFixGuardError + (env,RecCallInNonRecArgOfConstructor t)) + else + let spec = dest_subterms rar in + check_rec_call env true n spec t && + process_args_of_constr (lr, lrar) + | [],_ -> true + | _ -> anomaly_ill_typed () + in process_args_of_constr (realargs, lra) + + | Lambda (x,a,b) -> + assert (args = []); + if (noccur_with_meta n nbfix a) then + check_rec_call (push_rel (x, None, a) env) + alreadygrd (n+1) vlra b + else + raise (CoFixGuardError (env,RecCallInTypeOfAbstraction a)) + + | CoFix (j,(_,varit,vdefs as recdef)) -> + if (List.for_all (noccur_with_meta n nbfix) args) + 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_for_all + (check_rec_call env' alreadygrd (n+1) vlra) vdefs) + && + (List.for_all (check_rec_call env alreadygrd (n+1) vlra) args) + else + raise (CoFixGuardError (env,RecCallInTypeOfDef c)) + else + raise (CoFixGuardError (env,UnguardedRecursiveCall c)) + + | Case (_,p,tm,vrest) -> + if (noccur_with_meta n nbfix p) then + if (noccur_with_meta n nbfix tm) then + if (List.for_all (noccur_with_meta n nbfix) args) then + (array_for_all (check_rec_call env alreadygrd n vlra) vrest) + else + raise (CoFixGuardError (env,RecCallInCaseFun c)) + else + raise (CoFixGuardError (env,RecCallInCaseArg c)) + else + raise (CoFixGuardError (env,RecCallInCasePred c)) + + | _ -> 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 + satisfies the guarded condition *) + +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 + let _ = check_one_cofix fixenv nbfix bodies.(i) types.(i) + in () + with CoFixGuardError (errenv,err) -> + error_ill_formed_rec_body errenv err names i + done diff --git a/kernel/inductive.mli b/kernel/inductive.mli new file mode 100644 index 00000000..ad44fa64 --- /dev/null +++ b/kernel/inductive.mli @@ -0,0 +1,71 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* types -> inductive * constr list +val find_inductive : env -> types -> inductive * constr list +val find_coinductive : env -> types -> inductive * constr list + +(*s Fetching information in the environment about an inductive type. + Raises [Not_found] if the inductive type is not found. *) +val lookup_mind_specif : + env -> inductive -> mutual_inductive_body * one_inductive_body + +(*s Functions to build standard types related to inductive *) + +val type_of_inductive : env -> inductive -> types + +(* Return type as quoted by the user *) +val type_of_constructor : env -> constructor -> types + +(* Return constructor types in normal form *) +val arities_of_constructors : env -> inductive -> types array + +(* Transforms inductive specification into types (in nf) *) +val arities_of_specif : mutual_inductive -> + mutual_inductive_body * one_inductive_body -> types array + +(* [type_case_branches env (I,args) (p:A) c] computes useful types + about the following Cases expression: +

Cases (c :: (I args)) of b1..bn end + It computes the type of every branch (pattern variables are + introduced by products), the type for the whole expression, and + the universe constraints generated. + *) +val type_case_branches : + env -> inductive * constr list -> unsafe_judgment -> constr + -> types array * types * constraints + +(* Check a [case_info] actually correspond to a Case expression on the + given inductive type. *) +val check_case_info : env -> inductive -> case_info -> unit + +(* Find the ultimate inductive in the mind_equiv chain *) + +val scrape_mind : env -> mutual_inductive -> mutual_inductive + +(*s Guard conditions for fix and cofix-points. *) +val check_fix : env -> fixpoint -> unit +val check_cofix : env -> cofixpoint -> unit diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml new file mode 100644 index 00000000..5e8c7001 --- /dev/null +++ b/kernel/mod_typing.ml @@ -0,0 +1,324 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* mb + | _ -> raise Not_path + +let rec replace_first p k = function + | [] -> [] + | h::t when p h -> k::t + | h::t -> h::(replace_first p k t) + +let rec list_split_assoc k rev_before = function + | [] -> raise Not_found + | (k',b)::after when k=k' -> rev_before,b,after + | h::tail -> list_split_assoc k (h::rev_before) tail + +let rec list_fold_map2 f e = function + | [] -> (e,[],[]) + | h::t -> + let e',h1',h2' = f e h in + let e'',t1',t2' = list_fold_map2 f e' t in + e'',h1'::t1',h2'::t2' + +let type_modpath env mp = + strengthen env (lookup_module mp env).mod_type mp + +let rec translate_modtype env mte = + match mte with + | MTEident ln -> MTBident ln + | MTEfunsig (arg_id,arg_e,body_e) -> + let arg_b = translate_modtype env arg_e in + let env' = + add_module (MPbound arg_id) (module_body_of_type arg_b) env in + let body_b = translate_modtype env' body_e in + MTBfunsig (arg_id,arg_b,body_b) + | MTEsig (msid,sig_e) -> + let str_b,sig_b = translate_entry_list env msid false sig_e in + MTBsig (msid,sig_b) + | MTEwith (mte, with_decl) -> + let mtb = translate_modtype env mte in + merge_with env mtb with_decl + +and merge_with env mtb with_decl = + let msid,sig_b = match (Modops.scrape_modtype env mtb) with + | MTBsig(msid,sig_b) -> msid,sig_b + | _ -> error_signature_expected mtb + in + let id = match with_decl with + | With_Definition (id,_) | With_Module (id,_) -> id + 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 env' = Modops.add_signature (MPself msid) before env in + let new_spec = match with_decl with + | With_Definition (id,c) -> + let cb = match spec with + SPBconst cb -> cb + | _ -> error_not_a_constant l + in + begin + match cb.const_body with + | None -> + let (j,cst1) = Typeops.infer env' c in + let cst2 = + Reduction.conv_leq env' j.uj_type cb.const_type in + let cst = + Constraint.union + (Constraint.union cb.const_constraints cst1) + cst2 + in + SPBconst {cb with + const_body = + Some (Declarations.from_val j.uj_val); + const_constraints = cst} + | Some b -> + let cst1 = Reduction.conv env' c (Declarations.force b) in + let cst = Constraint.union cb.const_constraints cst1 in + SPBconst {cb with + const_body = Some (Declarations.from_val c); + const_constraints = cst} + end +(* and what about msid's ????? Don't they clash ? *) + | With_Module (id, mp) -> + let old = match spec with + SPBmodule msb -> msb + | _ -> error_not_a_module (string_of_label l) + in + let mtb = type_modpath env' mp in + (* here, using assertions in substitutions, + we check that there is no msid bound in mtb *) + begin + try + let _ = subst_modtype (map_msid msid (MPself msid)) mtb in + () + with + Failure _ -> error_circular_with_module id + end; + let cst = + try check_subtypes env' mtb old.msb_modtype + with Failure _ -> error_with_incorrect (label_of_id id) in + let equiv = + match old.msb_equiv with + | None -> Some mp + | Some mp' -> + check_modpath_equiv env' mp mp'; + Some mp + in + let msb = + {msb_modtype = mtb; + msb_equiv = equiv; + msb_constraints = Constraint.union old.msb_constraints cst } + in + SPBmodule msb + in + MTBsig(msid, before@(l,new_spec)::after) + with + Not_found -> error_no_such_label l + | Reduction.NotConvertible -> error_with_incorrect l + +and translate_entry_list env msid is_definition sig_e = + let mp = MPself msid in + let do_entry env (l,e) = + let kn = make_kn mp empty_dirpath l in + match e with + | SPEconst ce -> + let cb = translate_constant env ce in + begin match cb.const_hyps with + | (_::_) -> error_local_context (Some l) + | [] -> + add_constant kn cb env, (l, SEBconst cb), (l, SPBconst cb) + end + | SPEmind mie -> + let mib = translate_mind env mie in + begin match mib.mind_hyps with + | (_::_) -> error_local_context (Some l) + | [] -> + add_mind kn mib env, (l, SEBmind mib), (l, SPBmind mib) + end + | SPEmodule me -> + let mb = translate_module env is_definition me in + let mspec = + { msb_modtype = mb.mod_type; + msb_equiv = mb.mod_equiv; + msb_constraints = mb.mod_constraints } + in + let mp' = MPdot (mp,l) in + add_module mp' mb env, (l, SEBmodule mb), (l, SPBmodule mspec) + | SPEmodtype mte -> + let mtb = translate_modtype env mte in + add_modtype kn mtb env, (l, SEBmodtype mtb), (l, SPBmodtype mtb) + in + let _,str_b,sig_b = list_fold_map2 do_entry env sig_e + in + str_b,sig_b + +(* if [is_definition=true], [mod_entry_expr] may be any expression. + Otherwise it must be a path *) + +and translate_module env is_definition me = + match me.mod_entry_expr, me.mod_entry_type with + | None, None -> + anomaly "Mod_typing.translate_module: empty type and expr in module entry" + | None, Some mte -> + let mtb = translate_modtype env mte in + { mod_expr = None; + mod_user_type = Some mtb; + mod_type = mtb; + mod_equiv = None; + mod_constraints = Constraint.empty } + | Some mexpr, _ -> + let meq_o = (* do we have a transparent module ? *) + try (* TODO: transparent field in module_entry *) + match me.mod_entry_type with + | None -> Some (path_of_mexpr mexpr) + | Some _ -> None + with + | Not_path -> None + in + let meb,mtb1 = + if is_definition then + translate_mexpr env mexpr + else + let mp = + try + path_of_mexpr mexpr + with + | Not_path -> error_declaration_not_path mexpr + in + MEBident mp, type_modpath env mp + in + let mtb, mod_user_type, cst = + match me.mod_entry_type with + | None -> mtb1, None, Constraint.empty + | Some mte -> + let mtb2 = translate_modtype env mte in + let cst = + try check_subtypes env mtb1 mtb2 + with Failure _ -> error "not subtype" in + mtb2, Some mtb2, cst + in + { mod_type = mtb; + mod_user_type = mod_user_type; + mod_expr = Some meb; + mod_equiv = meq_o; + mod_constraints = cst } + +(* translate_mexpr : env -> module_expr -> module_expr_body * module_type_body *) +and translate_mexpr env mexpr = match mexpr with + | MEident mp -> + MEBident mp, + type_modpath env mp + | MEfunctor (arg_id, arg_e, body_expr) -> + let arg_b = translate_modtype env arg_e in + let env' = add_module (MPbound arg_id) (module_body_of_type arg_b) env in + let (body_b,body_tb) = translate_mexpr env' body_expr in + MEBfunctor (arg_id, arg_b, body_b), + MTBfunsig (arg_id, arg_b, body_tb) + | MEapply (fexpr,mexpr) -> + let feb,ftb = translate_mexpr env fexpr in + let ftb = scrape_modtype env ftb in + let farg_id, farg_b, fbody_b = destr_functor ftb in + let meb,mtb = translate_mexpr env mexpr in + let cst = + try check_subtypes env mtb farg_b + with Failure _ -> + error "" in + let mp = + try + path_of_mexpr mexpr + with + | Not_path -> error_application_to_not_path mexpr + (* place for nondep_supertype *) + in + MEBapply(feb,meb,cst), + subst_modtype (map_mbid farg_id mp) fbody_b + | MEstruct (msid,structure) -> + let structure,signature = translate_entry_list env msid true structure in + MEBstruct (msid,structure), + MTBsig (msid,signature) + + +(* is_definition is true - me.mod_entry_expr may be any expression *) +let translate_module env me = translate_module env true me + +let rec add_module_expr_constraints env = function + | MEBident _ -> env + + | MEBfunctor (_,mtb,meb) -> + add_module_expr_constraints (add_modtype_constraints env mtb) meb + + | MEBstruct (_,mod_struct_body) -> + List.fold_left + (fun env (l,item) -> add_struct_elem_constraints env item) + env + mod_struct_body + + | MEBapply (meb1,meb2,cst) -> + Environ.add_constraints cst + (add_module_expr_constraints + (add_module_expr_constraints env meb1) + meb2) + +and add_struct_elem_constraints env = function + | SEBconst cb -> Environ.add_constraints cb.const_constraints env + | SEBmind mib -> Environ.add_constraints mib.mind_constraints env + | SEBmodule mb -> add_module_constraints env mb + | SEBmodtype mtb -> add_modtype_constraints env mtb + +and add_module_constraints env mb = + (* if there is a body, the mb.mod_type is either inferred from the + body and hence uninteresting or equal to the non-empty + user_mod_type *) + let env = match mb.mod_expr with + | None -> add_modtype_constraints env mb.mod_type + | Some meb -> add_module_expr_constraints env meb + in + let env = match mb.mod_user_type with + | None -> env + | Some mtb -> add_modtype_constraints env mtb + in + Environ.add_constraints mb.mod_constraints env + +and add_modtype_constraints env = function + | MTBident _ -> env + | MTBfunsig (_,mtb1,mtb2) -> + add_modtype_constraints + (add_modtype_constraints env mtb1) + mtb2 + | MTBsig (_,mod_sig_body) -> + List.fold_left + (fun env (l,item) -> add_sig_elem_constraints env item) + env + mod_sig_body + +and add_sig_elem_constraints env = function + | SPBconst cb -> Environ.add_constraints cb.const_constraints env + | SPBmind mib -> Environ.add_constraints mib.mind_constraints env + | SPBmodule {msb_modtype=mtb; msb_constraints=cst} -> + add_modtype_constraints (Environ.add_constraints cst env) mtb + | SPBmodtype mtb -> add_modtype_constraints env mtb + + diff --git a/kernel/mod_typing.mli b/kernel/mod_typing.mli new file mode 100644 index 00000000..0ea98bf0 --- /dev/null +++ b/kernel/mod_typing.mli @@ -0,0 +1,25 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* module_type_entry -> module_type_body + +val translate_module : env -> module_entry -> module_body + +val add_modtype_constraints : env -> module_type_body -> env + +val add_module_constraints : env -> module_body -> env + diff --git a/kernel/modops.ml b/kernel/modops.ml new file mode 100644 index 00000000..84845af5 --- /dev/null +++ b/kernel/modops.ml @@ -0,0 +1,245 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* "^string_of_label l'^" !") + +let error_result_must_be_signature mtb = + error "The result module type must be a signature" + +let error_signature_expected mtb = + error "Signature expected" + +let error_no_module_to_end _ = + error "No open module to end" + +let error_no_modtype_to_end _ = + error "No open module type to end" + +let error_not_a_modtype_loc loc s = + user_err_loc (loc,"",str ("\""^s^"\" is not a module type")) + +let error_not_a_module_loc loc s = + user_err_loc (loc,"",str ("\""^s^"\" is not a module")) + +let error_not_a_module s = error_not_a_module_loc dummy_loc s + +let error_not_a_constant l = + error ("\""^(string_of_label l)^"\" is not a constant") + +let error_with_incorrect l = + error ("Incorrect constraint for label \""^(string_of_label l)^"\"") + +let error_local_context lo = + match lo with + None -> + error ("The local context is not empty.") + | (Some l) -> + error ("The local context of the component "^ + (string_of_label l)^" is not empty") + +let error_circular_with_module l = + error ("The construction \"with Module "^(string_of_id l)^":=...\" is about to create\na circular module type. Their resolution is not implemented yet.\nIf you really need that feature, please report.") + +let rec scrape_modtype env = function + | MTBident kn -> scrape_modtype env (lookup_modtype kn env) + | mtb -> mtb + +(* the constraints are not important here *) +let module_body_of_spec msb = + { mod_type = msb.msb_modtype; + mod_equiv = msb.msb_equiv; + mod_expr = None; + mod_user_type = None; + mod_constraints = Constraint.empty} + +let module_body_of_type mtb = + { mod_type = mtb; + mod_equiv = None; + mod_expr = None; + mod_user_type = None; + mod_constraints = Constraint.empty} + + +(* the constraints are not important here *) +let module_spec_of_body mb = + { msb_modtype = mb.mod_type; + msb_equiv = mb.mod_equiv; + msb_constraints = Constraint.empty} + + + +let destr_functor = function + | MTBfunsig (arg_id,arg_t,body_t) -> (arg_id,arg_t,body_t) + | mtb -> error_not_a_functor mtb + + +let rec check_modpath_equiv env mp1 mp2 = + if mp1=mp2 then () else + let mb1 = lookup_module mp1 env in + match mb1.mod_equiv with + | None -> + let mb2 = lookup_module mp2 env in + (match mb2.mod_equiv with + | None -> error_not_equal mp1 mp2 + | Some mp2' -> check_modpath_equiv env mp2' mp1) + | Some mp1' -> check_modpath_equiv env mp2 mp1' + + +let rec subst_modtype sub = function + | MTBident ln -> MTBident (subst_kn sub ln) + | MTBfunsig (arg_id, arg_b, body_b) -> + if occur_mbid arg_id sub then failwith "capture"; + MTBfunsig (arg_id, + subst_modtype sub arg_b, + subst_modtype sub body_b) + | MTBsig (sid1, msb) -> + if occur_msid sid1 sub then failwith "capture"; + MTBsig (sid1, subst_signature sub msb) + +and subst_signature sub sign = + let subst_body = function + SPBconst cb -> + SPBconst (subst_const_body sub cb) + | SPBmind mib -> + SPBmind (subst_mind sub mib) + | SPBmodule mb -> + SPBmodule (subst_module sub mb) + | SPBmodtype mtb -> + SPBmodtype (subst_modtype sub mtb) + in + List.map (fun (l,b) -> (l,subst_body b)) sign + +and subst_module sub mb = + let mtb' = subst_modtype sub mb.msb_modtype in + let mpo' = option_smartmap (subst_mp sub) mb.msb_equiv in + if mtb'==mb.msb_modtype && mpo'==mb.msb_equiv then mb else + { msb_modtype=mtb'; + msb_equiv=mpo'; + msb_constraints=mb.msb_constraints} + + +let subst_signature_msid msid mp = + subst_signature (map_msid msid mp) + +(* we assume that the substitution of "mp" into "msid" is already done +(or unnecessary) *) +let rec add_signature mp sign env = + let add_one env (l,elem) = + let kn = make_kn mp empty_dirpath l in + match elem with + | SPBconst cb -> Environ.add_constant kn cb env + | SPBmind mib -> Environ.add_mind kn mib env + | SPBmodule mb -> + add_module (MPdot (mp,l)) (module_body_of_spec mb) env + (* adds components as well *) + | SPBmodtype mtb -> Environ.add_modtype kn mtb env + in + List.fold_left add_one env sign + + +and add_module mp mb env = + let env = Environ.shallow_add_module mp mb env in + match scrape_modtype env mb.mod_type with + | MTBident _ -> anomaly "scrape_modtype does not work!" + | MTBsig (msid,sign) -> + add_signature mp (subst_signature_msid msid mp sign) env + + | MTBfunsig _ -> 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_kn mp empty_dirpath l) in + let const_subs = Some (Declarations.from_val const) in + {cb with + const_body = const_subs; + const_opaque = 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 strengthen_mtb env mp mtb = match scrape_modtype env mtb with + | MTBident _ -> anomaly "scrape_modtype does not work!" + | MTBfunsig _ -> mtb + | MTBsig (msid,sign) -> MTBsig (msid,strengthen_sig env msid sign mp) + +and strengthen_mod env mp msb = + { msb_modtype = strengthen_mtb env mp msb.msb_modtype; + msb_equiv = begin match msb.msb_equiv with + | Some _ -> msb.msb_equiv + | None -> Some mp + end ; + msb_constraints = msb.msb_constraints; } + +and strengthen_sig env msid sign mp = match sign with + | [] -> [] + | (l,SPBconst cb) :: rest -> + let item' = l,SPBconst (strengthen_const env mp l cb) in + let rest' = strengthen_sig env msid rest mp in + item'::rest' + | (l,SPBmind mib) :: rest -> + let item' = l,SPBmind (strengthen_mind env mp l mib) in + let rest' = strengthen_sig env msid rest mp in + item'::rest' + | (l,SPBmodule mb) :: rest -> + let mp' = MPdot (mp,l) in + let item' = l,SPBmodule (strengthen_mod env mp' mb) in + let env' = add_module + (MPdot (MPself msid,l)) + (module_body_of_spec mb) + env + in + let rest' = strengthen_sig env' msid rest mp in + item'::rest' + | (l,SPBmodtype mty as item) :: rest -> + let env' = add_modtype + (make_kn (MPself msid) empty_dirpath l) + mty + env + in + let rest' = strengthen_sig env' msid rest mp in + item::rest' + +let strengthen env mtb mp = strengthen_mtb env mp mtb diff --git a/kernel/modops.mli b/kernel/modops.mli new file mode 100644 index 00000000..5433fa3e --- /dev/null +++ b/kernel/modops.mli @@ -0,0 +1,96 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* module_type_body -> module_type_body + +(* make the environment entry out of type *) +val module_body_of_type : module_type_body -> module_body + +val module_body_of_spec : module_specification_body -> module_body + +val module_spec_of_body : module_body -> module_specification_body + + +val destr_functor : + module_type_body -> mod_bound_id * module_type_body * module_type_body + + +val subst_modtype : substitution -> module_type_body -> module_type_body + +val subst_signature_msid : + mod_self_id -> module_path -> + module_signature_body -> module_signature_body + +(* [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 -> module_signature_body -> env -> env + +(* adds a module and its components, but not the constraints *) +val add_module : + module_path -> module_body -> env -> env + +val check_modpath_equiv : env -> module_path -> module_path -> unit + +val strengthen : env -> module_type_body -> module_path -> module_type_body + +val error_existing_label : label -> 'a + +val error_declaration_not_path : module_expr -> 'a + +val error_application_to_not_path : module_expr -> 'a + +val error_not_a_functor : module_expr -> 'a + +val error_incompatible_modtypes : + module_type_body -> module_type_body -> 'a + +val error_not_equal : module_path -> module_path -> 'a + +val error_not_match : label -> specification_body -> 'a + +val error_incompatible_labels : label -> label -> 'a + +val error_no_such_label : label -> 'a + +val error_result_must_be_signature : module_type_body -> 'a + +val error_signature_expected : module_type_body -> 'a + +val error_no_module_to_end : unit -> 'a + +val error_no_modtype_to_end : unit -> 'a + +val error_not_a_modtype_loc : loc -> string -> 'a + +val error_not_a_module_loc : loc -> string -> 'a + +val error_not_a_module : string -> 'a + +val error_not_a_constant : label -> 'a + +val error_with_incorrect : label -> 'a + +val error_local_context : label option -> 'a + +val error_circular_with_module : identifier -> 'a diff --git a/kernel/names.ml b/kernel/names.ml new file mode 100644 index 00000000..df3a012f --- /dev/null +++ b/kernel/names.ml @@ -0,0 +1,355 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* "Fix" + | _ -> id + else id +let string_of_id id = String.copy (map_ident id) + +(* Hash-consing of identifier *) +module Hident = Hashcons.Make( + struct + type t = string + type u = string -> string + let hash_sub hstr id = hstr id + let equal id1 id2 = id1 == id2 + let hash = Hashtbl.hash + end) + +module IdOrdered = + struct + type t = identifier + let compare = id_ord + end + +module Idset = Set.Make(IdOrdered) +module Idmap = Map.Make(IdOrdered) +module Idpred = Predicate.Make(IdOrdered) + +(* Names *) + +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) + +let make_dirpath x = x +let repr_dirpath x = x + +let empty_dirpath = [] + +let string_of_dirpath = function + | [] -> "" + | sl -> + String.concat "." (List.map string_of_id (List.rev sl)) + + +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 string_of_uid (i,s,p) = + "<"(*^string_of_dirpath p ^"#"^*) ^ s ^"#"^ string_of_int i^">" + +module Umap = Map.Make(struct + type t = uniq_ident + let compare = Pervasives.compare + end) + + +type mod_self_id = uniq_ident +let make_msid = make_uid +let debug_string_of_msid = string_of_uid +let id_of_msid (_,s,_) = s + +type mod_bound_id = uniq_ident +let make_mbid = make_uid +let debug_string_of_mbid = string_of_uid +let id_of_mbid (_,s,_) = s + +type label = string +let mk_label l = l +let string_of_label l = l + +let id_of_label l = l +let label_of_id id = id + +module Labset = Idset +module Labmap = Idmap + +type module_path = + | MPfile of dir_path + | MPbound of mod_bound_id + | MPself of mod_self_id + | MPdot of module_path * label + +let rec string_of_mp = function + | MPfile sl -> string_of_dirpath sl + | MPbound uid -> string_of_uid uid + | MPself uid -> string_of_uid uid + | 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) -> + let c = Pervasives.compare l1 l2 in + if c<>0 then + c + else + mp_ord mp1 mp2 + | _,_ -> Pervasives.compare mp1 mp2 + +module MPord = struct + type t = module_path + let compare = mp_ord +end + +module MPset = Set.Make(MPord) +module MPmap = Map.Make(MPord) + + +(* this is correct under the condition that bound and struct + identifiers can never be identical (i.e. get the same stamp)! *) + +type substitution = module_path Umap.t + +let empty_subst = Umap.empty + +let add_msid = Umap.add +let add_mbid = Umap.add + +let map_msid msid mp = add_msid msid mp empty_subst +let map_mbid mbid mp = add_msid mbid mp empty_subst + +let list_contents sub = + let one_pair uid mp l = + (string_of_uid uid, string_of_mp mp)::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 + "{" ^ String.concat "; " l ^ "}" + +let debug_pr_subst sub = + let l = list_contents sub in + let f (s1,s2) = hov 2 (str s1 ++ spc () ++ str "|-> " ++ str s2) + in + str "{" ++ hov 2 (prlist_with_sep pr_coma f l) ++ str "}" + +let rec subst_mp sub mp = (* 's like subst *) + match mp with + | MPself sid -> + (try Umap.find sid sub with Not_found -> mp) + | MPbound bid -> + (try Umap.find bid sub with Not_found -> mp) + | MPdot (mp1,l) -> + let mp1' = subst_mp sub mp1 in + if mp1==mp1' then + mp + else + MPdot (mp1',l) + | _ -> mp + +let join subst1 subst2 = + let subst = Umap.map (subst_mp subst2) subst1 in + Umap.fold Umap.add subst2 subst + +let rec occur_in_path uid = function + | MPself sid -> sid = uid + | MPbound bid -> bid = uid + | MPdot (mp1,_) -> occur_in_path uid mp1 + | _ -> false + +let occur_uid uid sub = + let check_one uid' mp = + if uid = uid' || occur_in_path uid mp then raise Exit + in + try + Umap.iter check_one sub; + false + with Exit -> true + +let occur_msid = occur_uid +let occur_mbid = occur_uid + + + +(* Kernel names *) + +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 mp,_,_ = repr_kn kn in mp + +let label kn = + let _,_,l = repr_kn kn in l + +let string_of_kn (mp,dir,l) = + string_of_mp mp ^ "#" ^ string_of_dirpath dir ^ "#" ^ string_of_label l + +let pr_kn kn = str (string_of_kn kn) + + +let subst_kn sub (mp,dir,l as kn) = + let mp' = subst_mp sub mp in + if mp==mp' then kn else (mp',dir,l) + + +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 + let c = Pervasives.compare dir1 dir2 in + if c<>0 then + c + else + MPord.compare mp1 mp2 + + +module KNord = struct + type t = kernel_name + let compare =kn_ord +end + +module KNmap = Map.Make(KNord) +module KNpred = Predicate.Make(KNord) +module KNset = Set.Make(KNord) + + +let default_module_name = id_of_string "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 + +type variable = identifier +type constant = kernel_name +type mutual_inductive = kernel_name +type inductive = mutual_inductive * int +type constructor = inductive * int + +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 + +(* Better to have it here that in closure, since used in grammar.cma *) +type evaluable_global_reference = + | EvalVarRef of identifier + | EvalConstRef of constant + +(* Hash-consing of name objects *) +module Hname = Hashcons.Make( + struct + type t = name + type u = identifier -> identifier + let hash_sub hident = function + | Name id -> Name (hident id) + | n -> n + let equal n1 n2 = + match (n1,n2) with + | (Name id1, Name id2) -> id1 == id2 + | (Anonymous,Anonymous) -> true + | _ -> false + let hash = Hashtbl.hash + end) + +module Hdir = Hashcons.Make( + struct + type t = dir_path + type u = identifier -> identifier + let hash_sub hident d = List.map hident d + let rec equal d1 d2 = match (d1,d2) with + | [],[] -> true + | id1::d1,id2::d2 -> id1 == id2 & equal d1 d2 + | _ -> false + let hash = Hashtbl.hash + end) + +module Huniqid = Hashcons.Make( + struct + type t = uniq_ident + type u = (string -> string) * (dir_path -> dir_path) + let hash_sub (hstr,hdir) (n,s,dir) = (n,hstr s,hdir dir) + let equal (n1,s1,dir1) (n2,s2,dir2) = n1 = n2 & s1 = s2 & dir1 == dir2 + let hash = Hashtbl.hash + end) + +module Hmod = Hashcons.Make( + 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( + struct + type t = kernel_name + type u = (module_path -> module_path) + * (dir_path -> dir_path) * (string -> string) + let hash_sub (hmod,hdir,hstr) (md,dir,l) = (hmod md, hdir dir, hstr l) + let equal (mod1,dir1,l1) (mod2,dir2,l2) = + mod1 == mod2 && dir1 == dir2 && l1 == l2 + let hash = Hashtbl.hash + end) + +let hcons_names () = + let hstring = Hashcons.simple_hcons Hashcons.Hstring.f () in + let hident = Hashcons.simple_hcons Hident.f hstring in + let hname = Hashcons.simple_hcons Hname.f hident in + let hdir = Hashcons.simple_hcons Hdir.f hident in + let huniqid = Hashcons.simple_hcons Huniqid.f (hstring,hdir) in + let hmod = Hashcons.simple_hcons Hmod.f (hdir,huniqid,hstring) in + let hkn = Hashcons.simple_hcons Hkn.f (hmod,hdir,hstring) in + (hkn,hdir,hname,hident,hstring) diff --git a/kernel/names.mli b/kernel/names.mli new file mode 100644 index 00000000..07c19841 --- /dev/null +++ b/kernel/names.mli @@ -0,0 +1,176 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* string +val id_of_string : string -> identifier + +val id_ord : identifier -> identifier -> int + +(* Identifiers sets and maps *) +module Idset : Set.S with type elt = identifier +module Idpred : Predicate.S with type elt = identifier +module Idmap : Map.S with type key = identifier + +(*s Directory paths = section names paths *) +type module_ident = identifier +module ModIdmap : Map.S with type key = module_ident + +type dir_path + +(* Inner modules idents on top of list (to improve sharing). + For instance: A.B.C is ["C";"B";"A"] *) +val make_dirpath : module_ident list -> dir_path +val repr_dirpath : dir_path -> module_ident list + +val empty_dirpath : dir_path + +(* Printing of directory paths as ["coq_root.module.submodule"] *) +val string_of_dirpath : dir_path -> string + + +(*s Unique identifier to be used as "self" in structures and + signatures - invisible for users *) + +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 id_of_msid : mod_self_id -> identifier +val debug_string_of_msid : mod_self_id -> string + +(*s Unique names for bound modules *) +type mod_bound_id + +val make_mbid : dir_path -> string -> mod_bound_id +val id_of_mbid : mod_bound_id -> identifier +val debug_string_of_mbid : mod_bound_id -> string + +(*s Names of structure elements *) +type label +val mk_label : string -> label +val string_of_label : label -> string + +val label_of_id : identifier -> label +val id_of_label : label -> identifier + +module Labset : Set.S with type elt = label +module Labmap : Map.S with type key = label + +(*s The module part of the kernel name *) +type module_path = + | MPfile of dir_path + | MPbound of mod_bound_id + | MPself of mod_self_id + | MPdot of module_path * label +(*i | MPapply of module_path * module_path in the future (maybe) i*) + + +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 + + +(*s Substitutions *) + +type substitution + +val empty_subst : substitution + +val add_msid : + mod_self_id -> module_path -> substitution -> substitution +val add_mbid : + mod_bound_id -> module_path -> substitution -> substitution + +val map_msid : mod_self_id -> module_path -> substitution +val map_mbid : mod_bound_id -> module_path -> substitution + +(* sequential composition: + [substitute (join sub1 sub2) t = substitute sub2 (substitute sub1 t)] +*) +val join : substitution -> substitution -> substitution + +(*i debugging *) +val debug_string_of_subst : substitution -> string +val debug_pr_subst : substitution -> 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 [==] *) + +val subst_mp : + substitution -> module_path -> module_path + +(* [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 + + +(* 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 + +(*s The absolute names of objects seen by kernel *) + +type kernel_name + +(* Constructor and destructor *) +val make_kn : module_path -> dir_path -> label -> kernel_name +val repr_kn : kernel_name -> module_path * dir_path * label + +val modpath : kernel_name -> module_path +val label : kernel_name -> label + +val string_of_kn : kernel_name -> string +val pr_kn : kernel_name -> Pp.std_ppcmds +val subst_kn : substitution -> kernel_name -> kernel_name + + +module KNset : Set.S with type elt = kernel_name +module KNpred : Predicate.S with type elt = kernel_name +module KNmap : Map.S with type key = kernel_name + + +(*s Specific paths for declarations *) + +type variable = identifier +type constant = kernel_name +type mutual_inductive = kernel_name +(* Beware: first inductive has index 0 *) +type inductive = mutual_inductive * int +(* Beware: first constructor has index 1 *) +type constructor = inductive * int + +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 + +(* Better to have it here that in Closure, since required in grammar.cma *) +type evaluable_global_reference = + | EvalVarRef of identifier + | EvalConstRef of constant + +(* Hash-consing *) +val hcons_names : unit -> + (kernel_name -> kernel_name) * (dir_path -> dir_path) * + (name -> name) * (identifier -> identifier) * (string -> string) diff --git a/kernel/reduction.ml b/kernel/reduction.ml new file mode 100644 index 00000000..5428a40d --- /dev/null +++ b/kernel/reduction.ml @@ -0,0 +1,412 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* true + | Zupdate _::s -> is_empty_stack s + | Zshift _::s -> is_empty_stack s + | _ -> false + +(* Compute the lift to be performed on a term placed in a given stack *) +let el_stack el stk = + let n = + List.fold_left + (fun i z -> + match z with + Zshift n -> i+n + | _ -> i) + 0 + stk in + el_shft n el + +let compare_stack_shape stk1 stk2 = + let rec compare_rec bal stk1 stk2 = + match (stk1,stk2) with + ([],[]) -> bal=0 + | ((Zupdate _|Zshift _)::s1, _) -> compare_rec bal s1 stk2 + | (_, (Zupdate _|Zshift _)::s2) -> compare_rec bal stk1 s2 + | (Zapp l1::s1, _) -> compare_rec (bal+List.length l1) s1 stk2 + | (_, Zapp l2::s2) -> compare_rec (bal-List.length l2) stk1 s2 + | (Zcase(c1,_,_)::s1, Zcase(c2,_,_)::s2) -> + bal=0 (* && c1.ci_ind = c2.ci_ind *) && compare_rec 0 s1 s2 + | (Zfix(_,a1)::s1, Zfix(_,a2)::s2) -> + bal=0 && compare_rec 0 a1 a2 && compare_rec 0 s1 s2 + | (_,_) -> false in + compare_rec 0 stk1 stk2 + +let pure_stack lfts stk = + let rec pure_rec lfts stk = + match stk with + [] -> (lfts,[]) + | zi::s -> + (match (zi,pure_rec lfts s) with + (Zupdate _,lpstk) -> lpstk + | (Zshift n,(l,pstk)) -> (el_shft n l, pstk) + | (Zapp a1,(l,Zapp a2::pstk)) -> + (l,Zapp (List.map (fun t -> (l,t)) a1 @ a2)::pstk) + | (Zapp a, (l,pstk)) -> + (l,Zapp (List.map (fun t -> (l,t)) a)::pstk) + | (Zfix(fx,a),(l,pstk)) -> + let (lfx,pa) = pure_rec l a in + (l, Zfix((lfx,fx),pa)::pstk) + | (Zcase(ci,p,br),(l,pstk)) -> + (l,Zcase(ci,(l,p),Array.map (fun t -> (l,t)) br)::pstk)) in + snd (pure_rec lfts stk) + +(****************************************************************************) +(* Reduction Functions *) +(****************************************************************************) + +let nf_betaiota t = + norm_val (create_clos_infos betaiota empty_env) (inject t) + +let whd_betaiotazeta env x = + match kind_of_term x with + | (Sort _|Var _|Meta _|Evar _|Const _|Ind _|Construct _| + Prod _|Lambda _|Fix _|CoFix _) -> x + | _ -> whd_val (create_clos_infos betaiotazeta env) (inject x) + +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 = + match kind_of_term t with + | (Sort _|Meta _|Evar _|Ind _|Construct _| + Prod _|Lambda _|Fix _|CoFix _|LetIn _) -> t + | _ -> whd_val (create_clos_infos betadeltaiotanolet env) (inject t) + +(* Beta *) + +let beta_appvect c v = + let rec stacklam env t stack = + match (decomp_stack stack,kind_of_term t) with + | Some (h,stacktl), Lambda (_,_,c) -> stacklam (h::env) c stacktl + | _ -> app_stack (substl env t, stack) in + stacklam [] c (append_stack v empty_stack) + +(********************************************************************) +(* Conversion *) +(********************************************************************) + +(* Conversion utility functions *) +type 'a conversion_function = env -> 'a -> 'a -> Univ.constraints + +exception NotConvertible +exception NotConvertibleVect of int + +let compare_stacks f fmind lft1 stk1 lft2 stk2 cuniv = + let rec cmp_rec pstk1 pstk2 cuniv = + match (pstk1,pstk2) with + | (z1::s1, z2::s2) -> + let c1 = cmp_rec s1 s2 cuniv in + (match (z1,z2) with + | (Zapp a1,Zapp a2) -> List.fold_right2 f a1 a2 c1 + | (Zfix(fx1,a1),Zfix(fx2,a2)) -> + let c2 = f fx1 fx2 c1 in + cmp_rec a1 a2 c2 + | (Zcase(ci1,p1,br1),Zcase(ci2,p2,br2)) -> + if not (fmind ci1.ci_ind ci2.ci_ind) then + raise NotConvertible; + let c2 = f p1 p2 c1 in + array_fold_right2 f br1 br2 c2 + | _ -> assert false) + | _ -> cuniv in + if compare_stack_shape stk1 stk2 then + cmp_rec (pure_stack lft1 stk1) (pure_stack lft2 stk2) cuniv + else raise NotConvertible + +(* Convertibility of sorts *) + +type conv_pb = + | CONV + | CUMUL + +let sort_cmp pb s0 s1 cuniv = + match (s0,s1) with + | (Prop c1, Prop c2) -> if c1 = c2 then cuniv else raise NotConvertible + | (Prop c1, Type u) -> + (match pb with + CUMUL -> cuniv + | _ -> raise NotConvertible) + | (Type u1, Type u2) -> + (match pb with + | CONV -> enforce_eq u1 u2 cuniv + | CUMUL -> enforce_geq u2 u1 cuniv) + | (_, _) -> raise NotConvertible + + +let conv_sort env s0 s1 = sort_cmp CONV s0 s1 Constraint.empty + +let conv_sort_leq env s0 s1 = sort_cmp CUMUL s0 s1 Constraint.empty + + +(* Conversion between [lft1]term1 and [lft2]term2 *) +let rec ccnv cv_pb infos lft1 lft2 term1 term2 cuniv = + Util.check_for_interrupt (); + eqappr cv_pb infos + (lft1, whd_stack infos term1 []) + (lft2, whd_stack infos term2 []) + cuniv + +(* Conversion between [lft1](hd1 v1) and [lft2](hd2 v2) *) +and eqappr cv_pb infos appr1 appr2 cuniv = + let (lft1,(hd1,v1)) = appr1 in + let (lft2,(hd2,v2)) = appr2 in + let el1 = el_stack lft1 v1 in + let el2 = el_stack lft2 v2 in + match (fterm_of hd1, fterm_of hd2) with + (* case of leaves *) + | (FAtom a1, FAtom a2) -> + (match kind_of_term a1, kind_of_term a2 with + | (Sort s1, Sort s2) -> + assert (is_empty_stack v1 && is_empty_stack v2); + sort_cmp cv_pb s1 s2 cuniv + | (Meta n, Meta m) -> + if n=m + then convert_stacks infos lft1 lft2 v1 v2 cuniv + else raise NotConvertible + | _ -> raise NotConvertible) + | (FEvar (ev1,args1), FEvar (ev2,args2)) -> + if ev1=ev2 then + let u1 = convert_stacks infos lft1 lft2 v1 v2 cuniv in + convert_vect infos el1 el2 args1 args2 u1 + else raise NotConvertible + + (* 2 index known to be bound to no constant *) + | (FRel n, FRel m) -> + if reloc_rel n el1 = reloc_rel m el2 + then convert_stacks infos lft1 lft2 v1 v2 cuniv + else raise NotConvertible + + (* 2 constants, 2 local defined vars or 2 defined rels *) + | (FFlex fl1, FFlex fl2) -> + (try (* try first intensional equality *) + if fl1 = fl2 + then convert_stacks infos lft1 lft2 v1 v2 cuniv + else raise NotConvertible + with NotConvertible -> + (* else the oracle tells which constant is to be expanded *) + let (app1,app2) = + if Conv_oracle.oracle_order fl1 fl2 then + match unfold_reference infos fl1 with + | Some def1 -> ((lft1, whd_stack infos def1 v1), appr2) + | None -> + (match unfold_reference infos fl2 with + | Some def2 -> (appr1, (lft2, whd_stack infos def2 v2)) + | None -> raise NotConvertible) + else + match unfold_reference infos fl2 with + | Some def2 -> (appr1, (lft2, whd_stack infos def2 v2)) + | None -> + (match unfold_reference infos fl1 with + | Some def1 -> ((lft1, whd_stack infos def1 v1), appr2) + | None -> raise NotConvertible) in + eqappr cv_pb infos app1 app2 cuniv) + + (* only one constant, defined var or defined rel *) + | (FFlex fl1, _) -> + (match unfold_reference infos fl1 with + | Some def1 -> + eqappr cv_pb infos (lft1, whd_stack infos def1 v1) appr2 cuniv + | None -> raise NotConvertible) + | (_, FFlex fl2) -> + (match unfold_reference infos fl2 with + | Some def2 -> + eqappr cv_pb infos appr1 (lft2, whd_stack infos def2 v2) cuniv + | None -> raise NotConvertible) + + (* other constructors *) + | (FLambda _, FLambda _) -> + let (_,ty1,bd1) = destFLambda mk_clos hd1 in + let (_,ty2,bd2) = destFLambda mk_clos hd2 in + let u1 = ccnv CONV infos el1 el2 ty1 ty2 cuniv in + ccnv CONV infos (el_lift el1) (el_lift el2) bd1 bd2 u1 + + | (FProd (_,c1,c2), FProd (_,c'1,c'2)) -> + assert (is_empty_stack v1 && is_empty_stack v2); + (* Luo's system *) + let u1 = ccnv CONV infos el1 el2 c1 c'1 cuniv in + ccnv cv_pb infos (el_lift el1) (el_lift el2) c2 c'2 u1 + + (* Inductive types: MutInd MutConstruct Fix Cofix *) + + | (FInd (kn1,i1), FInd (kn2,i2)) -> + if i1 = i2 && mind_equiv infos kn1 kn2 + then + convert_stacks infos lft1 lft2 v1 v2 cuniv + else raise NotConvertible + + | (FConstruct ((kn1,i1),j1), FConstruct ((kn2,i2),j2)) -> + if i1 = i2 && j1 = j2 && mind_equiv infos kn1 kn2 + then + convert_stacks infos lft1 lft2 v1 v2 cuniv + else raise NotConvertible + + | (FFix ((op1,(_,tys1,cl1)),e1), FFix((op2,(_,tys2,cl2)),e2)) -> + if op1 = op2 + then + let n = Array.length cl1 in + let fty1 = Array.map (mk_clos e1) tys1 in + let fty2 = Array.map (mk_clos e2) tys2 in + let fcl1 = Array.map (mk_clos (subs_liftn n e1)) cl1 in + let fcl2 = Array.map (mk_clos (subs_liftn n e2)) cl2 in + let u1 = convert_vect infos el1 el2 fty1 fty2 cuniv in + let u2 = + convert_vect infos + (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 u1 in + convert_stacks infos lft1 lft2 v1 v2 u2 + else raise NotConvertible + + | (FCoFix ((op1,(_,tys1,cl1)),e1), FCoFix((op2,(_,tys2,cl2)),e2)) -> + if op1 = op2 + then + let n = Array.length cl1 in + let fty1 = Array.map (mk_clos e1) tys1 in + let fty2 = Array.map (mk_clos e2) tys2 in + let fcl1 = Array.map (mk_clos (subs_liftn n e1)) cl1 in + let fcl2 = Array.map (mk_clos (subs_liftn n e2)) cl2 in + let u1 = convert_vect infos el1 el2 fty1 fty2 cuniv in + let u2 = + convert_vect infos + (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 u1 in + convert_stacks infos lft1 lft2 v1 v2 u2 + else raise NotConvertible + + | ( (FLetIn _, _) | (_, FLetIn _) | (FCases _,_) | (_,FCases _) + | (FApp _,_) | (_,FApp _) | (FCLOS _, _) | (_,FCLOS _) + | (FLIFT _, _) | (_,FLIFT _) | (FLOCKED,_) | (_,FLOCKED)) -> + anomaly "Unexpected term returned by fhnf" + + | _ -> 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) + (fun (mind1,i1) (mind2,i2) -> i1=i2 && mind_equiv infos mind1 mind2) + 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 = + if n >= lv1 then univ + else + let u1 = ccnv CONV infos lft1 lft2 v1.(n) v2.(n) univ in + fold (n+1) u1 in + fold 0 cuniv + else raise NotConvertible + + + +let fconv cv_pb env t1 t2 = + if eq_constr t1 t2 then + Constraint.empty + else + let infos = create_clos_infos betaiotazeta env in + ccnv cv_pb infos ELID ELID (inject t1) (inject t2) + Constraint.empty + +let conv = fconv CONV +let conv_leq = fconv CUMUL + +let conv_leq_vecti env v1 v2 = + array_fold_left2_i + (fun i c t1 t2 -> + let c' = + try conv_leq env t1 t2 + with NotConvertible -> raise (NotConvertibleVect i) in + Constraint.union c c') + Constraint.empty + v1 + v2 + +(* +let convleqkey = Profile.declare_profile "Kernel_reduction.conv_leq";; +let conv_leq env t1 t2 = + Profile.profile4 convleqkey conv_leq env t1 t2;; + +let convkey = Profile.declare_profile "Kernel_reduction.conv";; +let conv env t1 t2 = + Profile.profile4 convleqkey conv env t1 t2;; +*) + +(********************************************************************) +(* Special-Purpose Reduction *) +(********************************************************************) + +(* pseudo-reduction rule: + * [hnf_prod_app env s (Prod(_,B)) N --> B[N] + * with an HNF on the first argument to produce a product. + * if this does not work, then we use the string S as part of our + * error message. *) + +let hnf_prod_app env t n = + match kind_of_term (whd_betadeltaiota env t) with + | Prod (_,_,b) -> subst1 n b + | _ -> anomaly "hnf_prod_app: Need a product" + +let hnf_prod_applist env t nl = + List.fold_left (hnf_prod_app env) t nl + +(* Dealing with arities *) + +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 + | _ -> m,t + in + decrec env Sign.empty_rel_context + +(* The same but preserving lets *) +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 + | 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 + | Cast (c,_) -> prodec_rec env l c + | _ -> l,rty + in + prodec_rec env Sign.empty_rel_context + +let dest_arity env c = + let l, c = dest_prod env c in + match kind_of_term c with + | Sort s -> l,s + | _ -> error "not an arity" + +let is_arity env c = + try + let _ = dest_arity env c in + true + with UserError _ -> false + diff --git a/kernel/reduction.mli b/kernel/reduction.mli new file mode 100644 index 00000000..c516ea70 --- /dev/null +++ b/kernel/reduction.mli @@ -0,0 +1,55 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* constr -> constr +val whd_betadeltaiota : env -> constr -> constr +val whd_betadeltaiota_nolet : env -> constr -> constr + +val nf_betaiota : constr -> constr + +(************************************************************************) +(*s conversion functions *) + +exception NotConvertible +exception NotConvertibleVect of int +type 'a conversion_function = env -> 'a -> 'a -> Univ.constraints + +val conv_sort : sorts conversion_function +val conv_sort_leq : sorts conversion_function + +val conv : types conversion_function +val conv_leq : types conversion_function +val conv_leq_vecti : types array conversion_function + +(************************************************************************) + +(* Builds an application node, reducing beta redexes it may produce. *) +val beta_appvect : constr -> constr array -> constr + +(* Pseudo-reduction rule Prod(x,A,B) a --> B[x\a] *) +val hnf_prod_applist : env -> types -> constr list -> types + + +(************************************************************************) +(*s Recognizing products and arities modulo reduction *) + +val dest_prod : env -> types -> Sign.rel_context * types +val dest_prod_assum : env -> types -> Sign.rel_context * types + +val dest_arity : env -> types -> Sign.arity +val is_arity : env -> types -> bool diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml new file mode 100644 index 00000000..4f180599 --- /dev/null +++ b/kernel/safe_typing.ml @@ -0,0 +1,572 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* () in + Environ.push_named d env + +let push_named_def (id,b,topt) senv = + let (c,typ,cst) = translate_local_def senv.env (b,topt) in + let env' = add_constraints cst senv.env in + let env'' = safe_push_named (id,Some c,typ) env' in + (cst, {senv with env=env''}) + +let push_named_assum (id,t) senv = + let (t,cst) = translate_local_assum senv.env t in + let env' = add_constraints cst senv.env in + let env'' = safe_push_named (id,None,t) env' in + (cst, {senv with env=env''}) + + +(* Insertion of constants and parameters in environment. *) + +type global_declaration = + | ConstantEntry of constant_entry + | GlobalRecipe of Cooking.recipe + +let hcons_constant_body cb = + let body = match cb.const_body with + None -> None + | Some l_constr -> let constr = Declarations.force l_constr in + Some (Declarations.from_val (hcons1_constr constr)) + in + { cb with + const_body = body; + const_type = hcons1_constr cb.const_type } + +let add_constant dir l decl senv = + check_label l senv.labset; + let cb = match decl with + ConstantEntry ce -> translate_constant senv.env ce + | GlobalRecipe r -> + let cb = translate_recipe senv.env r in + if dir = empty_dirpath then hcons_constant_body cb else cb + in +(* let cb = if dir = empty_dirpath then hcons_constant_body cb else cb in*) + let env' = Environ.add_constraints cb.const_constraints senv.env in + let kn = make_kn senv.modinfo.modpath dir l in + let env'' = Environ.add_constant kn cb env' in + kn, { old = senv.old; + env = env''; + modinfo = senv.modinfo; + labset = Labset.add l senv.labset; + revsign = (l,SPBconst cb)::senv.revsign; + revstruct = (l,SEBconst cb)::senv.revstruct; + imports = senv.imports; + loads = senv.loads } + + +(* Insertion of inductive types. *) + +let add_mind dir l mie senv = + 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 + all labels *) + let mib = translate_mind senv.env mie in + let env' = Environ.add_constraints mib.mind_constraints senv.env in + let kn = make_kn senv.modinfo.modpath dir l in + let env'' = Environ.add_mind kn mib env' in + kn, { old = senv.old; + env = env''; + modinfo = senv.modinfo; + labset = Labset.add l senv.labset; (* TODO: the same as above *) + revsign = (l,SPBmind mib)::senv.revsign; + revstruct = (l,SEBmind mib)::senv.revstruct; + imports = senv.imports; + loads = senv.loads } + + +(* Insertion of module types *) + +let add_modtype l mte senv = + check_label l senv.labset; + let mtb = translate_modtype senv.env mte in + let env' = add_modtype_constraints senv.env mtb in + let kn = make_kn senv.modinfo.modpath empty_dirpath l in + let env'' = Environ.add_modtype kn mtb env' in + kn, { old = senv.old; + env = env''; + modinfo = senv.modinfo; + labset = Labset.add l senv.labset; + revsign = (l,SPBmodtype mtb)::senv.revsign; + revstruct = (l,SEBmodtype mtb)::senv.revstruct; + imports = senv.imports; + loads = senv.loads } + + + +(* full_add_module adds module with universes and constraints *) +let full_add_module mp mb env = + let env = add_module_constraints env mb in + let env = Modops.add_module mp mb env in + env + +(* Insertion of modules *) + +let add_module l me senv = + check_label l senv.labset; + let mb = translate_module senv.env me in + let mspec = module_spec_of_body mb in + let mp = MPdot(senv.modinfo.modpath, l) in + let env' = full_add_module mp mb senv.env in + mp, { old = senv.old; + env = env'; + modinfo = senv.modinfo; + labset = Labset.add l senv.labset; + revsign = (l,SPBmodule mspec)::senv.revsign; + revstruct = (l,SEBmodule mb)::senv.revstruct; + imports = senv.imports; + loads = senv.loads } + + +(* Interactive modules *) + +let start_module l params result senv = + check_label l senv.labset; + let rec trans_params env = function + | [] -> env,[] + | (mbid,mte)::rest -> + let mtb = translate_modtype env mte in + let env = + full_add_module (MPbound mbid) (module_body_of_type mtb) env + in + let env,transrest = trans_params env rest in + env, (mbid,mtb)::transrest + in + let env,params_body = trans_params senv.env params in + let check_sig mtb = match scrape_modtype env mtb with + | MTBsig _ -> () + | MTBfunsig _ -> error_result_must_be_signature mtb + | _ -> anomaly "start_module: modtype not scraped" + in + let result_body = option_app (translate_modtype env) result in + ignore (option_app check_sig result_body); + 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(params_body,result_body) } + in + mp, { old = senv; + env = env; + modinfo = modinfo; + labset = Labset.empty; + revsign = []; + revstruct = []; + imports = senv.imports; + loads = [] } + + + +let end_module l senv = + let oldsenv = senv.old in + let modinfo = senv.modinfo in + let params, restype = + match modinfo.variant with + | NONE | LIBRARY _ | SIG _ -> error_no_module_to_end () + | STRUCT(params,restype) -> (params,restype) + 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_type = + List.fold_right + (fun (arg_id,arg_b) mtb -> MTBfunsig (arg_id,arg_b,mtb)) + params + in + let auto_tb = MTBsig (modinfo.msid, List.rev senv.revsign) in + let mtb, mod_user_type, cst = + match restype with + | None -> functorize_type auto_tb, None, Constraint.empty + | Some res_tb -> + let cst = check_subtypes senv.env auto_tb res_tb in + let mtb = functorize_type res_tb in + mtb, Some mtb, cst + in + let mexpr = + List.fold_right + (fun (arg_id,arg_b) mtb -> MEBfunctor (arg_id,arg_b,mtb)) + params + (MEBstruct (modinfo.msid, List.rev senv.revstruct)) + in + let mb = + { mod_expr = Some mexpr; + mod_user_type = mod_user_type; + mod_type = mtb; + mod_equiv = None; + mod_constraints = cst } + in + let mspec = + { msb_modtype = mtb; + msb_equiv = None; + msb_constraints = Constraint.empty } + in + let mp = MPdot (oldsenv.modinfo.modpath, l) in + let newenv = oldsenv.env in + let newenv = + List.fold_left + (fun env (mp,mb) -> full_add_module mp mb env) + newenv + senv.loads + in + let newenv = + full_add_module mp mb newenv + in + mp, { old = oldsenv.old; + env = newenv; + modinfo = oldsenv.modinfo; + labset = Labset.add l oldsenv.labset; + revsign = (l,SPBmodule mspec)::oldsenv.revsign; + revstruct = (l,SEBmodule mb)::oldsenv.revstruct; + imports = senv.imports; + loads = senv.loads@oldsenv.loads } + + +(* Interactive module types *) + +let start_modtype l params senv = + check_label l senv.labset; + let rec trans_params env = function + | [] -> env,[] + | (mbid,mte)::rest -> + let mtb = translate_modtype env mte in + let env = + full_add_module (MPbound mbid) (module_body_of_type mtb) env + in + let env,transrest = trans_params env rest in + env, (mbid,mtb)::transrest + in + let env,params_body = trans_params senv.env params in + 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 params_body } + in + mp, { old = senv; + env = env; + modinfo = modinfo; + labset = Labset.empty; + revsign = []; + revstruct = []; + imports = senv.imports; + loads = [] } + +let end_modtype l senv = + let oldsenv = senv.old in + let modinfo = senv.modinfo in + 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 res_tb = MTBsig (modinfo.msid, List.rev senv.revsign) in + let mtb = + List.fold_right + (fun (arg_id,arg_b) mtb -> MTBfunsig (arg_id,arg_b,mtb)) + params + res_tb + in + let kn = make_kn oldsenv.modinfo.modpath empty_dirpath l in + let newenv = oldsenv.env in + let newenv = + List.fold_left + (fun env (mp,mb) -> full_add_module mp mb env) + newenv + senv.loads + in + let newenv = + add_modtype_constraints newenv mtb + in + let newenv = + Environ.add_modtype kn mtb newenv + in + kn, { old = oldsenv.old; + env = newenv; + modinfo = oldsenv.modinfo; + labset = Labset.add l oldsenv.labset; + revsign = (l,SPBmodtype mtb)::oldsenv.revsign; + revstruct = (l,SEBmodtype mtb)::oldsenv.revstruct; + imports = senv.imports; + loads = senv.loads@oldsenv.loads } + + +let current_modpath senv = senv.modinfo.modpath +let current_msid senv = senv.modinfo.msid + + +let add_constraints cst senv = + {senv with env = Environ.add_constraints cst senv.env} + +(* Check that the engagement expected by a library matches the initial one *) +let check_engagement env c = + match Environ.engagement env, c with + | Some ImpredicativeSet, Some ImpredicativeSet -> () + | _, None -> () + | _, Some ImpredicativeSet -> + error "Needs option -impredicative-set" + +let set_engagement c senv = + {senv with env = Environ.set_engagement c senv.env} + + +(* Libraries = Compiled modules *) + +type compiled_library = + dir_path * module_body * library_info list * engagement option + + +(* We check that only initial state Require's were performed before + [start_library] was called *) + +let start_library dir senv = + if not (senv.revsign = [] && + senv.modinfo.msid = initial_msid && + senv.modinfo.variant = NONE) + then + anomaly "Safe_typing.start_library: environment should be empty"; + 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 } + in + mp, { old = senv; + env = senv.env; + modinfo = modinfo; + labset = Labset.empty; + revsign = []; + revstruct = []; + imports = senv.imports; + loads = [] } + + +let export senv dir = + let modinfo = senv.modinfo in + begin + match modinfo.variant with + | LIBRARY dp -> + if dir <> dp then + anomaly "We are not exporting the right library!" + | _ -> + anomaly "We are not exporting the library" + end; + (*if senv.modinfo.params <> [] || senv.modinfo.restype <> None then + (* error_export_simple *) (); *) + let mb = + { mod_expr = Some (MEBstruct (modinfo.msid, List.rev senv.revstruct)); + mod_type = MTBsig (modinfo.msid, List.rev senv.revsign); + mod_user_type = None; + mod_equiv = None; + mod_constraints = Constraint.empty } + in + modinfo.msid, (dir,mb,senv.imports,engagement senv.env) + + +let check_imports senv needed = + let imports = senv.imports in + let check (id,stamp) = + try + let actual_stamp = List.assoc id imports in + if stamp <> actual_stamp then + error ("Inconsistent assumptions over module " ^(string_of_dirpath id)) + with Not_found -> + error ("Reference to unknown module " ^ (string_of_dirpath id)) + in + List.iter check needed + +(* we have an inefficiency: Since loaded files are added to the +environment every time a module is closed, their components are +calculated many times. Thic could be avoided in several ways: + +1 - for each file create a dummy environment containing only this +file's components, merge this environment with the global +environment, and store for the future (instead of just its type) + +2 - create "persistent modules" environment table in Environ add put +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 = + check_imports senv depends; + check_engagement senv.env engmt; + let mp = MPfile dp in + let env = senv.env in + mp, { senv with + env = full_add_module mp mb env; + imports = (dp,digest)::senv.imports; + loads = (mp,mb)::senv.loads } + + +(** Remove the body of opaque constants in modules *) + +let rec lighten_module mb = + { mb with + mod_expr = option_app lighten_modexpr mb.mod_expr; + mod_type = lighten_modtype mb.mod_type; + mod_user_type = option_app lighten_modtype mb.mod_user_type } + +and lighten_modtype = function + | MTBident kn as x -> x + | MTBfunsig (mbid,mtb1,mtb2) -> + MTBfunsig (mbid, lighten_modtype mtb1, lighten_modtype mtb2) + | MTBsig (msid,sign) -> MTBsig (msid, lighten_sig sign) + +and lighten_modspec ms = + { ms with msb_modtype = lighten_modtype ms.msb_modtype } + +and lighten_sig sign = + let lighten_spec (l,spec) = (l,match spec with + | SPBconst ({const_opaque=true} as x) -> SPBconst {x with const_body=None} + | (SPBconst _ | SPBmind _) as x -> x + | SPBmodule m -> SPBmodule (lighten_modspec m) + | SPBmodtype m -> SPBmodtype (lighten_modtype m)) + in + List.map lighten_spec sign + +and lighten_struct struc = + let lighten_body (l,body) = (l,match body with + | SEBconst ({const_opaque=true} as x) -> SEBconst {x with const_body=None} + | (SEBconst _ | SEBmind _) as x -> x + | SEBmodule m -> SEBmodule (lighten_module m) + | SEBmodtype m -> SEBmodtype (lighten_modtype m)) + in + List.map lighten_body struc + +and lighten_modexpr = function + | MEBfunctor (mbid,mty,mexpr) -> + MEBfunctor (mbid,lighten_modtype mty,lighten_modexpr mexpr) + | MEBident mp as x -> x + | MEBstruct (msid, struc) -> + MEBstruct (msid, lighten_struct struc) + | MEBapply (mexpr,marg,u) -> + MEBapply (lighten_modexpr mexpr,lighten_modexpr marg,u) + +let lighten_library (dp,mb,depends,s) = (dp,lighten_module mb,depends,s) + + +type judgment = unsafe_judgment + +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) diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli new file mode 100644 index 00000000..84b98984 --- /dev/null +++ b/kernel/safe_typing.mli @@ -0,0 +1,127 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Environ.env + +val empty_environment : safe_environment + +(* Adding and removing local declarations (Local or Variables) *) +val push_named_assum : + identifier * types -> safe_environment -> + Univ.constraints * safe_environment +val push_named_def : + identifier * constr * types option -> safe_environment -> + Univ.constraints * safe_environment + +(* Adding global axioms or definitions *) +type global_declaration = + | ConstantEntry of constant_entry + | GlobalRecipe of Cooking.recipe + +val add_constant : + dir_path -> label -> global_declaration -> safe_environment -> + kernel_name * safe_environment + +(* Adding an inductive type *) +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 + +(* Adding a module type *) +val add_modtype : + label -> module_type_entry -> safe_environment + -> kernel_name * safe_environment + +(* Adding universe constraints *) +val add_constraints : + Univ.constraints -> safe_environment -> safe_environment + +(* Settin the strongly constructive or classical logical engagement *) +val set_engagement : Environ.engagement -> safe_environment -> safe_environment + + +(*s Interactive module functions *) +val start_module : + label -> (mod_bound_id * module_type_entry) list + -> module_type_entry option + -> safe_environment -> module_path * safe_environment + +val end_module : + label -> safe_environment -> module_path * safe_environment + + +val start_modtype : + label -> (mod_bound_id * module_type_entry) list + -> safe_environment -> module_path * safe_environment + +val end_modtype : + label -> safe_environment -> kernel_name * safe_environment + + +val current_modpath : safe_environment -> module_path +val current_msid : safe_environment -> mod_self_id + + +(* Loading and saving compilation units *) + +(* exporting and importing modules *) +type compiled_library + +val start_library : dir_path -> safe_environment + -> module_path * safe_environment + +val export : safe_environment -> dir_path + -> mod_self_id * compiled_library + +val import : compiled_library -> Digest.t -> safe_environment + -> module_path * safe_environment + +(* Remove the body of opaque constants *) + +val lighten_library : compiled_library -> compiled_library + +(*s Typing judgments *) + +type judgment + +val j_val : judgment -> constr +val j_type : judgment -> constr + +(* Safe typing of a term returning a typing judgment and universe + constraints to be added to the environment for the judgment to + hold. It is guaranteed that the constraints are satisfiable + *) +val safe_infer : safe_environment -> constr -> judgment * Univ.constraints + +val typing : safe_environment -> constr -> judgment + + diff --git a/kernel/sign.ml b/kernel/sign.ml new file mode 100644 index 00000000..a4b2a2ea --- /dev/null +++ b/kernel/sign.ml @@ -0,0 +1,192 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* decl + | _ :: sign -> lookup_named id sign + | [] -> raise Not_found + +let named_context_length = List.length + +let vars_of_named_context = List.map (fun (id,_,_) -> id) + +let instance_from_named_context sign = + let rec inst_rec = function + | (id,None,_) :: sign -> mkVar id :: inst_rec sign + | _ :: sign -> inst_rec sign + | [] -> [] in + Array.of_list (inst_rec sign) + +let fold_named_context f l ~init = List.fold_right f l init +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 lookup_rel n sign = + let rec lookrec = function + | (1, decl :: _) -> decl + | (n, _ :: sign) -> lookrec (n-1,sign) + | (_, []) -> raise Not_found + in + lookrec (n,sign) + +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 + +let map_rel_context f l = + let map_decl (n, body_o, typ as decl) = + let body_o' = option_smartmap f body_o in + let typ' = f typ in + if body_o' == body_o && typ' == typ then decl else + (n, body_o', typ') + in + list_smartmap map_decl l + +(* Push named declarations on top of a rel context *) +(* Bizarre. Should be avoided. *) +let push_named_to_rel_context hyps ctxt = + let rec push = function + | (id,b,t) :: l -> + let s, hyps = push l in + let d = (Name id, option_app (subst_vars s) b, type_app (subst_vars s) t) in + id::s, d::hyps + | [] -> [],[] in + let s, hyps = push hyps in + let rec subst = function + | d :: l -> + let n, ctxt = subst l in + (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) *) +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-1) 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 new file mode 100644 index 00000000..3f0549cc --- /dev/null +++ b/kernel/sign.mli @@ -0,0 +1,95 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* named_context -> named_context +val vars_of_named_context : named_context -> identifier list + +val lookup_named : identifier -> named_context -> named_declaration + +(* number of declarations *) +val named_context_length : named_context -> int + +(*s Recurrence on [named_context]: older declarations processed first *) +val fold_named_context : + (named_declaration -> 'a -> 'a) -> named_context -> init:'a -> 'a +(* newer declarations first *) +val fold_named_context_reverse : + ('a -> named_declaration -> 'a) -> init:'a -> named_context -> 'a + +(*s Section-related auxiliary functions *) +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 *) +val fold_rel_context : + (rel_declaration -> 'a -> 'a) -> rel_context -> init:'a -> 'a +(* newer declarations first *) +val fold_rel_context_reverse : + ('a -> rel_declaration -> 'a) -> init:'a -> rel_context -> 'a + +(*s Map function of [rel_context] *) +val map_rel_context : (constr -> constr) -> rel_context -> rel_context + +(*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 new file mode 100644 index 00000000..825ae8fa --- /dev/null +++ b/kernel/subtyping.ml @@ -0,0 +1,246 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* Idmap.add id (IndConstr ((ip,i), mib)) map) + oib.mind_consnames + map + in + Idmap.add oib.mind_typename (IndType (ip, mib)) map + in + array_fold_right_i add_nameobjects_of_one mib.mind_packets map + +(* creates namedobject map for the whole signature *) + +let make_label_map msid list = + let add_one (l,e) map = + let obj = + match e with + | SPBconst cb -> Constant cb + | SPBmind mib -> Mind mib + | SPBmodule mb -> Module mb + | SPBmodtype mtb -> Modtype mtb + in +(* let map = match obj with + | Mind mib -> + add_nameobjects_of_mib (make_ln (MPself msid) l) mib map + | _ -> map + in *) + Labmap.add l obj map + in + List.fold_right add_one list Labmap.empty + +let check_conv_error error cst f env a1 a2 = + try + Constraint.union cst (f env a1 a2) + with + 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 error () = error_not_match l spec2 in + let check_conv cst f = check_conv_error error cst f in + let mib1 = + match info1 with + | Mind mib -> mib + (* | IndType (_,mib) -> mib we will enable this later*) + | _ -> error () + in + let check_packet cst p1 p2 = + let check f = if f p1 <> f p2 then error () in + check (fun p -> p.mind_consnames); + check (fun p -> p.mind_typename); + (* nf_lc later *) + (* nf_arity later *) + (* user_lc ignored *) + (* user_arity ignored *) + let cst = check_conv cst conv_sort env p1.mind_sort p2.mind_sort in + check (fun p -> p.mind_nrealargs); + (* kelim ignored *) + (* listrec ignored *) + (* finite done *) + (* nparams done *) + (* params_ctxt done *) + let cst = check_conv cst conv env p1.mind_nf_arity p2.mind_nf_arity in + cst + in + let check_cons_types i cst p1 p2 = + array_fold_left2 + (fun cst t1 t2 -> check_conv cst conv env t1 t2) + cst + (arities_of_specif kn (mib1,p1)) + (arities_of_specif kn (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 + && Array.length mib2.mind_packets >= 1); + + (* TODO: we should allow renaming of parameters at least ! *) + check (fun mib -> mib.mind_packets.(0).mind_nparams); + check (fun mib -> mib.mind_packets.(0).mind_params_ctxt); + + 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 () + end; + (* we first check simple things *) + let cst = + array_fold_left2 check_packet cst mib1.mind_packets mib2.mind_packets + in + (* and constructor types in the end *) + 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 error () = error_not_match l spec2 in + let check_conv cst f = check_conv_error error cst f in + let cb1 = + match info1 with + | Constant cb -> cb + | _ -> error () + in + assert (cb1.const_hyps=[] && cb2.const_hyps=[]) ; + (*Start by checking types*) + let cst = check_conv cst conv_leq env cb1.const_type cb2.const_type in + match cb2.const_body with + | None -> cst + | Some lc2 -> + let c2 = Declarations.force lc2 in + let c1 = match cb1.const_body with + | Some lc1 -> Declarations.force lc1 + | None -> mkConst (make_kn (MPself msid1) empty_dirpath l) + in + check_conv cst conv env c1 c2 + +let rec check_modules cst env msid1 l msb1 msb2 = + let mp = (MPdot(MPself msid1,l)) in + let mty1 = strengthen env msb1.msb_modtype mp in + let cst = check_modtypes cst env mty1 msb2.msb_modtype false in + begin + match msb1.msb_equiv, msb2.msb_equiv with + | _, None -> () + | None, Some mp2 -> + check_modpath_equiv env mp mp2 + | Some mp1, Some mp2 -> + check_modpath_equiv env mp1 mp2 + end; + cst + + +and check_signatures cst env' (msid1,sig1) (msid2,sig2') = + let mp1 = MPself msid1 in + let env = add_signature mp1 sig1 env' in + let sig2 = subst_signature_msid msid2 mp1 sig2' in + let map1 = make_label_map msid1 sig1 in + let check_one_body cst (l,spec2) = + let info1 = + try + Labmap.find l map1 + with + Not_found -> error_no_such_label l + in + match spec2 with + | SPBconst cb2 -> + check_constant cst env msid1 l info1 cb2 spec2 + | SPBmind mib2 -> + check_inductive cst env msid1 l info1 mib2 spec2 + | SPBmodule msb2 -> + let msb1 = + match info1 with + | Module msb -> msb + | _ -> error_not_match l spec2 + in + check_modules cst env msid1 l msb1 msb2 + | SPBmodtype mtb2 -> + let mtb1 = + match info1 with + | Modtype mtb -> mtb + | _ -> error_not_match l spec2 + in + check_modtypes cst env mtb1 mtb2 true + in + List.fold_left check_one_body cst sig2 + +and check_modtypes cst env mtb1 mtb2 equiv = + if mtb1==mtb2 then (); (* just in case :) *) + let mtb1' = scrape_modtype env mtb1 in + let mtb2' = scrape_modtype env mtb2 in + if mtb1'==mtb2' then (); + match mtb1', mtb2' with + | MTBsig (msid1,list1), + MTBsig (msid2,list2) -> + let cst = check_signatures cst env (msid1,list1) (msid2,list2) in + if equiv then + check_signatures cst env (msid2,list2) (msid1,list1) + else + cst + | MTBfunsig (arg_id1,arg_t1,body_t1), + MTBfunsig (arg_id2,arg_t2,body_t2) -> + let cst = check_modtypes cst env arg_t2 arg_t1 equiv in + (* contravariant *) + let env' = + add_module (MPbound arg_id2) (module_body_of_type arg_t2) env + in + let body_t1' = + subst_modtype + (map_mbid arg_id1 (MPbound arg_id2)) + body_t1 + in + check_modtypes cst env' body_t1' body_t2 equiv + | MTBident _ , _ -> anomaly "Subtyping: scrape failed" + | _ , MTBident _ -> anomaly "Subtyping: scrape failed" + | _ , _ -> error_incompatible_modtypes mtb1 mtb2 + +let check_subtypes env sup super = + check_modtypes Constraint.empty env sup super false diff --git a/kernel/subtyping.mli b/kernel/subtyping.mli new file mode 100644 index 00000000..af09dafc --- /dev/null +++ b/kernel/subtyping.mli @@ -0,0 +1,19 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* module_type_body -> module_type_body -> constraints + + diff --git a/kernel/term.ml b/kernel/term.ml new file mode 100644 index 00000000..30e73e4f --- /dev/null +++ b/kernel/term.ml @@ -0,0 +1,1186 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* InProp + | Prop Pos -> InSet + | Type _ -> InType + +(********************************************************************) +(* Constructions as implemented *) +(********************************************************************) + +(* [constr array] is an instance matching definitional [named_context] in + the same order (i.e. last argument first) *) +type 'constr pexistential = existential_key * 'constr array +type ('constr, 'types) prec_declaration = + name array * 'types array * 'constr array +type ('constr, 'types) pfixpoint = + (int array * int) * ('constr, 'types) prec_declaration +type ('constr, 'types) pcofixpoint = + int * ('constr, 'types) prec_declaration + +(* [Var] is used for named variables and [Rel] for variables as + de Bruijn indices. *) +type ('constr, 'types) kind_of_term = + | Rel of int + | Var of identifier + | Meta of metavariable + | Evar of 'constr pexistential + | Sort of sorts + | Cast of 'constr * 'types + | Prod of name * 'types * 'types + | Lambda of name * 'types * 'constr + | LetIn of name * 'constr * 'types * 'constr + | App of 'constr * 'constr array + | Const of constant + | Ind of inductive + | Construct of constructor + | Case of case_info * 'constr * 'constr * 'constr array + | Fix of ('constr, 'types) pfixpoint + | CoFix of ('constr, 'types) pcofixpoint + +(* Experimental *) +type ('constr, 'types) kind_of_type = + | SortType of sorts + | CastType of 'types * 'types + | ProdType of name * 'types * 'types + | LetInType of name * 'constr * 'types * 'types + | AtomicType of 'constr * 'constr array + +let kind_of_type = function + | Sort s -> SortType s + | Cast (c,t) -> CastType (c, t) + | Prod (na,t,c) -> ProdType (na, t, c) + | LetIn (na,b,t,c) -> LetInType (na, b, t, c) + | App (c,l) -> AtomicType (c, l) + | (Rel _ | Meta _ | Var _ | Evar _ | Const _ | Case _ | Fix _ | CoFix _ | Ind _ as c) + -> AtomicType (c,[||]) + | (Lambda _ | Construct _) -> failwith "Not a type" + +(* constr is the fixpoint of the previous type. Requires option + -rectypes of the Caml compiler to be set *) +type constr = (constr,constr) kind_of_term + +type existential = existential_key * constr array +type rec_declaration = name array * constr array * constr array +type fixpoint = (int array * int) * rec_declaration +type cofixpoint = int * rec_declaration + +(***************************) +(* hash-consing functions *) +(***************************) + +let comp_term t1 t2 = + match t1, t2 with + | Rel n1, Rel n2 -> n1 = n2 + | Meta m1, Meta m2 -> m1 == m2 + | Var id1, Var id2 -> id1 == id2 + | Sort s1, Sort s2 -> s1 == s2 + | Cast (c1,t1), Cast (c2,t2) -> c1 == c2 & t1 == t2 + | Prod (n1,t1,c1), Prod (n2,t2,c2) -> n1 == n2 & t1 == t2 & c1 == c2 + | Lambda (n1,t1,c1), Lambda (n2,t2,c2) -> n1 == n2 & t1 == t2 & c1 == c2 + | LetIn (n1,b1,t1,c1), LetIn (n2,b2,t2,c2) -> + n1 == n2 & b1 == b2 & t1 == t2 & c1 == c2 + | App (c1,l1), App (c2,l2) -> c1 == c2 & array_for_all2 (==) l1 l2 + | Evar (e1,l1), Evar (e2,l2) -> e1 = e2 & array_for_all2 (==) l1 l2 + | Const c1, Const c2 -> c1 == c2 + | Ind (sp1,i1), Ind (sp2,i2) -> sp1 == sp2 & i1 = i2 + | Construct ((sp1,i1),j1), Construct ((sp2,i2),j2) -> + sp1 == sp2 & i1 = i2 & j1 = j2 + | Case (ci1,p1,c1,bl1), Case (ci2,p2,c2,bl2) -> + ci1 == ci2 & p1 == p2 & c1 == c2 & array_for_all2 (==) bl1 bl2 + | Fix (ln1,(lna1,tl1,bl1)), Fix (ln2,(lna2,tl2,bl2)) -> + ln1 = ln2 + & array_for_all2 (==) lna1 lna2 + & array_for_all2 (==) tl1 tl2 + & array_for_all2 (==) bl1 bl2 + | CoFix(ln1,(lna1,tl1,bl1)), CoFix(ln2,(lna2,tl2,bl2)) -> + ln1 = ln2 + & array_for_all2 (==) lna1 lna2 + & array_for_all2 (==) tl1 tl2 + & array_for_all2 (==) bl1 bl2 + | _ -> false + +let hash_term (sh_rec,(sh_sort,sh_kn,sh_na,sh_id)) t = + match t with + | Rel _ -> t + | Meta x -> Meta x + | Var x -> Var (sh_id x) + | Sort s -> Sort (sh_sort s) + | Cast (c,t) -> Cast (sh_rec c, sh_rec t) + | Prod (na,t,c) -> Prod (sh_na na, sh_rec t, sh_rec c) + | Lambda (na,t,c) -> Lambda (sh_na na, sh_rec t, sh_rec c) + | LetIn (na,b,t,c) -> LetIn (sh_na na, sh_rec b, sh_rec t, sh_rec c) + | App (c,l) -> App (sh_rec c, Array.map sh_rec l) + | Evar (e,l) -> Evar (e, Array.map sh_rec l) + | Const c -> Const (sh_kn c) + | Ind (kn,i) -> Ind (sh_kn kn,i) + | Construct ((kn,i),j) -> Construct ((sh_kn kn,i),j) + | Case (ci,p,c,bl) -> (* TO DO: extract ind_kn *) + Case (ci, sh_rec p, sh_rec c, Array.map sh_rec bl) + | Fix (ln,(lna,tl,bl)) -> + Fix (ln,(Array.map sh_na lna, + Array.map sh_rec tl, + Array.map sh_rec bl)) + | CoFix(ln,(lna,tl,bl)) -> + CoFix (ln,(Array.map sh_na lna, + Array.map sh_rec tl, + Array.map sh_rec bl)) + +module Hconstr = + Hashcons.Make( + struct + type t = constr + type u = (constr -> constr) * + ((sorts -> sorts) * (kernel_name -> kernel_name) + * (name -> name) * (identifier -> identifier)) + let hash_sub = hash_term + let equal = comp_term + let hash = Hashtbl.hash + end) + +let hcons_term (hsorts,hkn,hname,hident) = + Hashcons.recursive_hcons Hconstr.f (hsorts,hkn,hname,hident) + +(* Constructs a DeBrujin index with number n *) +let rels = + [|Rel 1;Rel 2;Rel 3;Rel 4;Rel 5;Rel 6;Rel 7; Rel 8; + Rel 9;Rel 10;Rel 11;Rel 12;Rel 13;Rel 14;Rel 15; Rel 16|] + +let mkRel n = if 0 Cast (t,t2) + | _ -> Cast (t1,t2) + +(* Constructs the product (x:t1)t2 *) +let mkProd (x,t1,t2) = Prod (x,t1,t2) + +(* Constructs the abstraction [x:t1]t2 *) +let mkLambda (x,t1,t2) = Lambda (x,t1,t2) + +(* Constructs [x=c_1:t]c_2 *) +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) = + if a=[||] then f else + match f with + | App (g, cl) -> App (g, Array.append cl a) + | _ -> App (f, a) + + +(* Constructs a constant *) +(* The array of terms correspond to the variables introduced in the section *) +let mkConst c = Const c + +(* Constructs an existential variable *) +let mkEvar e = Evar e + +(* Constructs the ith (co)inductive type of the block named kn *) +(* The array of terms correspond to the variables introduced in the section *) +let mkInd m = Ind m + +(* Constructs the jth constructor of the ith (co)inductive type of the + block named kn. The array of terms correspond to the variables + introduced in the section *) +let mkConstruct c = Construct c + +(* Constructs the term

Case c of c1 | c2 .. | cn end *) +let mkCase (ci, p, c, ac) = Case (ci, p, c, ac) + +let mkFix fix = Fix fix + +let mkCoFix cofix = CoFix cofix + +let kind_of_term c = c + +(************************************************************************) +(* kind_of_term = constructions as seen by the user *) +(************************************************************************) + +(* User view of [constr]. For [App], it is ensured there is at + least one argument and the function is not itself an applicative + term *) + +let kind_of_term = kind_of_term + + +(* En vue d'un kind_of_type : constr -> hnftype ??? *) +type hnftype = + | HnfSort of sorts + | HnfProd of name * constr * constr + | HnfAtom of constr + | HnfInd of inductive * constr array + +(**********************************************************************) +(* Non primitive term destructors *) +(**********************************************************************) + +(* Destructor operations : partial functions + Raise invalid_arg "dest*" if the const has not the expected form *) + +(* Destructs a DeBrujin index *) +let destRel c = match kind_of_term c with + | Rel n -> n + | _ -> invalid_arg "destRel" + +(* Destructs an existential variable *) +let destMeta c = match kind_of_term c with + | Meta n -> n + | _ -> invalid_arg "destMeta" + +let isMeta c = match kind_of_term c with Meta _ -> true | _ -> false + +(* Destructs a variable *) +let destVar c = match kind_of_term c with + | Var id -> id + | _ -> invalid_arg "destVar" + +(* Destructs a type *) +let isSort c = match kind_of_term c with + | Sort s -> true + | _ -> false + +let destSort c = match kind_of_term c with + | Sort s -> s + | _ -> invalid_arg "destSort" + +let rec isprop c = match kind_of_term c with + | Sort (Prop _) -> true + | Cast (c,_) -> isprop c + | _ -> false + +let rec is_Prop c = match kind_of_term c with + | Sort (Prop Null) -> true + | Cast (c,_) -> is_Prop c + | _ -> false + +let rec is_Set c = match kind_of_term c with + | Sort (Prop Pos) -> true + | Cast (c,_) -> is_Set c + | _ -> false + +let rec is_Type c = match kind_of_term c with + | Sort (Type _) -> true + | Cast (c,_) -> is_Type c + | _ -> false + +let isType = function + | Type _ -> true + | _ -> false + +let is_small = function + | Prop _ -> true + | _ -> false + +let iskind c = isprop c or is_Type c + +let same_kind c1 c2 = (isprop c1 & isprop c2) or (is_Type c1 & is_Type c2) + +(* Tests if an evar *) +let isEvar c = match kind_of_term c with Evar _ -> true | _ -> false + +(* Destructs a casted term *) +let destCast c = match kind_of_term c with + | Cast (t1, t2) -> (t1,t2) + | _ -> invalid_arg "destCast" + +let isCast c = match kind_of_term c with Cast (_,_) -> true | _ -> false + +(* Tests if a de Bruijn index *) +let isRel c = match kind_of_term c with Rel _ -> true | _ -> false + +(* Tests if a variable *) +let isVar c = match kind_of_term c with Var _ -> true | _ -> false + +(* Tests if an inductive *) +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) + | _ -> invalid_arg "destProd" + +(* Destructs the abstraction [x:t1]t2 *) +let destLambda c = match kind_of_term c with + | Lambda (x,t1,t2) -> (x,t1,t2) + | _ -> invalid_arg "destLambda" + +(* Destructs the let [x:=b:t1]t2 *) +let destLetIn c = match kind_of_term c with + | LetIn (x,b,t1,t2) -> (x,b,t1,t2) + | _ -> invalid_arg "destProd" + +(* Destructs an application *) +let destApplication c = match kind_of_term c with + | App (f,a) -> (f, a) + | _ -> invalid_arg "destApplication" + +let isApp c = match kind_of_term c with App _ -> true | _ -> false + +(* Destructs a constant *) +let destConst c = match kind_of_term c with + | Const kn -> kn + | _ -> invalid_arg "destConst" + +let isConst c = match kind_of_term c with Const _ -> true | _ -> false + +(* Destructs an existential variable *) +let destEvar c = match kind_of_term c with + | Evar (kn, a as r) -> r + | _ -> invalid_arg "destEvar" + +let num_of_evar c = match kind_of_term c with + | Evar (n, _) -> n + | _ -> anomaly "num_of_evar called with bad args" + +(* Destructs a (co)inductive type named kn *) +let destInd c = match kind_of_term c with + | Ind (kn, a as r) -> r + | _ -> invalid_arg "destInd" + +(* Destructs a constructor *) +let destConstruct c = match kind_of_term c with + | Construct (kn, a as r) -> r + | _ -> invalid_arg "dest" + +let isConstruct c = match kind_of_term c with + Construct _ -> true | _ -> false + +(* Destructs a term

Case c of lc1 | lc2 .. | lcn end *) +let destCase c = match kind_of_term c with + | Case (ci,p,c,v) -> (ci,p,c,v) + | _ -> anomaly "destCase" + +let destFix c = match kind_of_term c with + | Fix fix -> fix + | _ -> invalid_arg "destFix" + +let destCoFix c = match kind_of_term c with + | CoFix cofix -> cofix + | _ -> invalid_arg "destCoFix" + +(******************************************************************) +(* Flattening and unflattening of embedded applications and casts *) +(******************************************************************) + +(* flattens application lists *) +let rec collapse_appl c = match kind_of_term c with + | App (f,cl) -> + let rec collapse_rec f cl2 = match kind_of_term f with + | App (g,cl1) -> collapse_rec g (Array.append cl1 cl2) + | Cast (c,_) when isApp c -> collapse_rec c cl2 + | _ -> if cl2 = [||] then f else mkApp (f,cl2) + in + collapse_rec f cl + | _ -> c + +let rec decompose_app c = + match kind_of_term (collapse_appl c) with + | App (f,cl) -> (f, Array.to_list cl) + | Cast (c,t) -> decompose_app c + | _ -> (c,[]) + +(* strips head casts and flattens head applications *) +let rec strip_head_cast c = match kind_of_term c with + | App (f,cl) -> + let rec collapse_rec f cl2 = match kind_of_term f with + | App (g,cl1) -> collapse_rec g (Array.append cl1 cl2) + | Cast (c,_) -> collapse_rec c cl2 + | _ -> if cl2 = [||] then f else mkApp (f,cl2) + in + collapse_rec f cl + | Cast (c,t) -> strip_head_cast c + | _ -> c + +(****************************************************************************) +(* Functions to recur through subterms *) +(****************************************************************************) + +(* [fold_constr f acc c] folds [f] on the immediate subterms of [c] + starting from [acc] and proceeding from left to right according to + the usual representation of the constructions; it is not recursive *) + +let fold_constr f acc c = match kind_of_term c with + | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ + | Construct _) -> acc + | Cast (c,t) -> f (f acc c) t + | Prod (_,t,c) -> f (f acc t) c + | Lambda (_,t,c) -> f (f acc t) c + | LetIn (_,b,t,c) -> f (f (f acc b) t) c + | App (c,l) -> Array.fold_left f (f acc c) l + | Evar (_,l) -> Array.fold_left f acc l + | Case (_,p,c,bl) -> Array.fold_left f (f (f acc p) c) bl + | Fix (_,(lna,tl,bl)) -> + let fd = array_map3 (fun na t b -> (na,t,b)) lna tl bl in + Array.fold_left (fun acc (na,t,b) -> f (f acc t) b) acc fd + | CoFix (_,(lna,tl,bl)) -> + let fd = array_map3 (fun na t b -> (na,t,b)) lna tl bl in + Array.fold_left (fun acc (na,t,b) -> f (f acc t) b) acc fd + +(* [iter_constr f c] iters [f] on the immediate subterms of [c]; it is + not recursive and the order with which subterms are processed is + not specified *) + +let iter_constr f c = match kind_of_term c with + | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ + | Construct _) -> () + | Cast (c,t) -> f c; f t + | Prod (_,t,c) -> f t; f c + | Lambda (_,t,c) -> f t; f c + | LetIn (_,b,t,c) -> f b; f t; f c + | App (c,l) -> f c; Array.iter f l + | Evar (_,l) -> Array.iter f l + | Case (_,p,c,bl) -> f p; f c; Array.iter f bl + | Fix (_,(_,tl,bl)) -> Array.iter f tl; Array.iter f bl + | CoFix (_,(_,tl,bl)) -> Array.iter f tl; Array.iter f bl + +(* [iter_constr_with_binders g f n c] iters [f n] on the immediate + subterms of [c]; it carries an extra data [n] (typically a lift + index) which is processed by [g] (which typically add 1 to [n]) at + each binder traversal; it is not recursive and the order with which + subterms are processed is not specified *) + +let iter_constr_with_binders g f n c = match kind_of_term c with + | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ + | Construct _) -> () + | Cast (c,t) -> f n c; f n t + | Prod (_,t,c) -> f n t; f (g n) c + | Lambda (_,t,c) -> f n t; f (g n) c + | LetIn (_,b,t,c) -> f n b; f n t; f (g n) c + | 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)) -> + Array.iter (f n) tl; + Array.iter (f (iterate g (Array.length tl) n)) bl + | CoFix (_,(_,tl,bl)) -> + Array.iter (f n) tl; + Array.iter (f (iterate g (Array.length tl) n)) bl + +(* [map_constr f c] maps [f] on the immediate subterms of [c]; it is + not recursive and the order with which subterms are processed is + not specified *) + +let map_constr f c = match kind_of_term c with + | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ + | Construct _) -> c + | Cast (c,t) -> mkCast (f c, f t) + | Prod (na,t,c) -> mkProd (na, f t, f c) + | Lambda (na,t,c) -> mkLambda (na, f t, f c) + | LetIn (na,b,t,c) -> mkLetIn (na, f b, f t, f c) + | App (c,l) -> mkApp (f c, Array.map f l) + | Evar (e,l) -> mkEvar (e, Array.map f l) + | Case (ci,p,c,bl) -> mkCase (ci, f p, f c, Array.map f bl) + | Fix (ln,(lna,tl,bl)) -> + mkFix (ln,(lna,Array.map f tl,Array.map f bl)) + | CoFix(ln,(lna,tl,bl)) -> + mkCoFix (ln,(lna,Array.map f tl,Array.map f bl)) + +(* [map_constr_with_binders g f n c] maps [f n] on the immediate + subterms of [c]; it carries an extra data [n] (typically a lift + index) which is processed by [g] (which typically add 1 to [n]) at + each binder traversal; it is not recursive and the order with which + subterms are processed is not specified *) + +let map_constr_with_binders g f l c = match kind_of_term c with + | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ + | Construct _) -> c + | Cast (c,t) -> mkCast (f l c, f l t) + | Prod (na,t,c) -> mkProd (na, f l t, f (g l) c) + | Lambda (na,t,c) -> mkLambda (na, f l t, f (g l) c) + | LetIn (na,b,t,c) -> mkLetIn (na, f l b, f l t, f (g l) c) + | App (c,al) -> mkApp (f l c, Array.map (f l) al) + | Evar (e,al) -> mkEvar (e, Array.map (f l) al) + | Case (ci,p,c,bl) -> mkCase (ci, f l p, f l c, Array.map (f l) bl) + | Fix (ln,(lna,tl,bl)) -> + let l' = iterate g (Array.length tl) l in + mkFix (ln,(lna,Array.map (f l) tl,Array.map (f l') bl)) + | CoFix(ln,(lna,tl,bl)) -> + let l' = iterate g (Array.length tl) l in + mkCoFix (ln,(lna,Array.map (f l) tl,Array.map (f l') bl)) + +(* [compare_constr f c1 c2] compare [c1] and [c2] using [f] to compare + the immediate subterms of [c1] of [c2] if needed; Cast's, + 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 + | Meta m1, Meta m2 -> m1 = m2 + | Var id1, Var id2 -> id1 = id2 + | Sort s1, Sort s2 -> s1 = s2 + | Cast (c1,_), _ -> f c1 t2 + | _, Cast (c2,_) -> f t1 c2 + | Prod (_,t1,c1), Prod (_,t2,c2) -> f t1 t2 & f c1 c2 + | Lambda (_,t1,c1), Lambda (_,t2,c2) -> f t1 t2 & f c1 c2 + | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> f b1 b2 & f t1 t2 & f c1 c2 + | App (c1,l1), App (c2,l2) -> + if Array.length l1 = Array.length l2 then + f c1 c2 & array_for_all2 f l1 l2 + else + let (h1,l1) = decompose_app t1 in + let (h2,l2) = decompose_app t2 in + if List.length l1 = List.length l2 then + f h1 h2 & List.for_all2 f l1 l2 + else false + | 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 + | 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)) -> + ln1 = ln2 & array_for_all2 f tl1 tl2 & array_for_all2 f bl1 bl2 + | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) -> + ln1 = ln2 & array_for_all2 f tl1 tl2 & array_for_all2 f bl1 bl2 + | _ -> false + +(***************************************************************************) +(* Type of assumptions *) +(***************************************************************************) + +type types = constr + +let type_app f tt = f tt + +let body_of_type ty = ty + +type named_declaration = identifier * constr option * types +type rel_declaration = name * constr option * types + +let map_named_declaration f (id, v, ty) = (id, option_app f v, f ty) +let map_rel_declaration = map_named_declaration + +(****************************************************************************) +(* Functions for dealing with constr terms *) +(****************************************************************************) + +(*********************) +(* Occurring *) +(*********************) + +exception LocalOccur + +(* (closedn n M) raises FreeVar if a variable of height greater than n + occurs in M, returns () otherwise *) + +let closedn = + 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 + closed_rec + +(* [closed0 M] is true iff [M] is a (deBruijn) closed term *) + +let closed0 term = + try closedn 0 term; true with LocalOccur -> false + +(* (noccurn n M) returns true iff (Rel n) does NOT occur in term M *) + +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 + 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 + for n <= p < n+m *) + +let noccur_between n m term = + let rec occur_rec n c = match kind_of_term c with + | Rel(p) -> if n<=p && p iter_constr_with_binders succ occur_rec n c + in + try occur_rec n term; true with LocalOccur -> false + +(* Checking function for terms containing existential variables. + The function [noccur_with_meta] considers the fact that + each existential variable (as well as each isevar) + in the term appears applied to its local context, + which may contain the CoFix variables. These occurrences of CoFix variables + are not considered *) + +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 + (match kind_of_term f with + | Cast (c,_) when isMeta c -> () + | Meta _ -> () + | _ -> iter_constr_with_binders succ occur_rec n c) + | Evar (_, _) -> () + | _ -> iter_constr_with_binders succ occur_rec n c + in + try (occur_rec n term; true) with LocalOccur -> false + + +(*********************) +(* Lifting *) +(*********************) + +(* The generic lifting function *) +let rec exliftn el c = match kind_of_term c with + | Rel i -> mkRel(reloc_rel i el) + | _ -> map_constr_with_binders el_lift exliftn el c + +(* Lifting the binding depth across k bindings *) + +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 + we generalise it to (substl [M1,...,Mn] c) which substitutes in parallel + M1,...,Mn for respectively Rel(1),...,Rel(n) in c *) + +(* 1st : general case *) + +type info = Closed | Open | Unknown +type 'a substituend = { mutable sinfo: info; sit: 'a } + +let rec lift_substituend depth s = + match s.sinfo with + | Closed -> s.sit + | Open -> lift depth s.sit + | Unknown -> + s.sinfo <- if closed0 s.sit then Closed else Open; + lift_substituend depth s + +let make_substituend c = { sinfo=Unknown; sit=c } + +let substn_many lamv n = + let lv = Array.length lamv in + 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 + substrec n + +(* +let substkey = Profile.declare_profile "substn_many";; +let substn_many lamv n c = Profile.profile3 substkey substn_many lamv n c;; +*) + +let substnl laml k = + substn_many (Array.map make_substituend (Array.of_list laml)) k +let substl laml = + substn_many (Array.map make_substituend (Array.of_list laml)) 0 +let subst1 lam = substl [lam] + +let substl_decl laml (id,bodyopt,typ as d) = + match bodyopt with + | None -> (id,None,substl laml typ) + | Some body -> (id, Some (substl laml body), type_app (substl laml) typ) +let subst1_decl lam = substl_decl [lam] + +(* (thin_val sigma) removes identity substitutions from sigma *) + +let rec thin_val = function + | [] -> [] + | (((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 var_alist = + List.map (fun (str,c) -> (str,make_substituend c)) 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 + if var_alist = [] then (function x -> x) else substrec 0 + +(* +let repvarkey = Profile.declare_profile "replace_vars";; +let replace_vars vl c = Profile.profile2 repvarkey replace_vars vl c ;; +*) + +(* (subst_var str t) substitute (VAR str) by (Rel 1) in t *) +let subst_var str = replace_vars [(str, mkRel 1)] + +(* (subst_vars [id1;...;idn] t) substitute (VAR idj) by (Rel j) in t *) +let substn_vars p vars = + let _,subst = + List.fold_left (fun (n,l) var -> ((n+1),(var,mkRel n)::l)) (p,[]) vars + in replace_vars (List.rev subst) + +let subst_vars = substn_vars 1 + +(* +map_kn : (kernel_name -> kernel_name) -> constr -> constr + +This should be rewritten to prevent duplication of constr's when not +necessary. +For now, it uses map_constr and is rather ineffective +*) + +let rec map_kn f c = + let func = map_kn f in + match kind_of_term c with + | Const kn -> + mkConst (f kn) + | Ind (kn,i) -> + mkInd (f kn,i) + | Construct ((kn,i),j) -> + mkConstruct ((f kn,i),j) + | Case (ci,p,c,l) -> + let ci' = { ci with ci_ind = let (kn,i) = ci.ci_ind in f kn, i } in + mkCase (ci', func p, func c, array_smartmap func l) + | _ -> map_constr func c + +let subst_mps sub = + map_kn (subst_kn sub) + + +(*********************) +(* Term constructors *) +(*********************) + +(* Constructs a DeBrujin index with number n *) +let mkRel = mkRel + +(* Constructs an existential variable named "?n" *) +let mkMeta = mkMeta + +(* Constructs a Variable named id *) +let mkVar = mkVar + +(* Construct a type *) +let mkProp = mkSort mk_Prop +let mkSet = mkSort mk_Set +let mkType u = mkSort (Type u) +let mkSort = function + | Prop Null -> mkProp (* Easy sharing *) + | Prop Pos -> mkSet + | s -> mkSort s + +let prop = mk_Prop +and spec = mk_Set +and type_0 = Type prop_univ + +(* Constructs the term t1::t2, i.e. the term t1 casted with the type t2 *) +(* (that means t2 is declared as the type of t1) *) +let mkCast = mkCast + +(* Constructs the product (x:t1)t2 *) +let mkProd = mkProd +let mkNamedProd id typ c = mkProd (Name id, typ, subst_var id c) +let mkProd_string s t c = mkProd (Name (id_of_string s), t, c) + +(* Constructs the abstraction [x:t1]t2 *) +let mkLambda = mkLambda +let mkNamedLambda id typ c = mkLambda (Name id, typ, subst_var id c) +let mkLambda_string s t c = mkLambda (Name (id_of_string s), t, c) + +(* Constructs [x=c_1:t]c_2 *) +let mkLetIn = mkLetIn +let mkNamedLetIn id c1 t c2 = mkLetIn (Name id, c1, t, subst_var id c2) + +(* Constructs either [(x:t)c] or [[x=b:t]c] *) +let mkProd_or_LetIn (na,body,t) c = + match body with + | None -> mkProd (na, t, c) + | Some b -> mkLetIn (na, b, t, c) + +let mkNamedProd_or_LetIn (id,body,t) c = + match body with + | None -> mkNamedProd id t c + | Some b -> mkNamedLetIn id b t c + +(* Constructs either [[x:t]c] or [[x=b:t]c] *) +let mkLambda_or_LetIn (na,body,t) c = + match body with + | None -> mkLambda (na, t, c) + | Some b -> mkLetIn (na, b, t, c) + +let mkNamedLambda_or_LetIn (id,body,t) c = + match body with + | None -> mkNamedLambda id t c + | Some b -> mkNamedLetIn id b t c + +(* Constructs either [(x:t)c] or [c] where [x] is replaced by [b] *) +let mkProd_wo_LetIn (na,body,t) c = + match body with + | None -> mkProd (na, t, c) + | Some b -> subst1 b c + +let mkNamedProd_wo_LetIn (id,body,t) c = + match body with + | None -> mkNamedProd id t c + | Some b -> subst1 b (subst_var id c) + +(* non-dependent product t1 -> t2 *) +let mkArrow t1 t2 = mkProd (Anonymous, t1, t2) + +(* If lt = [t1; ...; tn], constructs the application (t1 ... tn) *) +(* We ensure applicative terms have at most one arguments and the + function is not itself an applicative term *) +let mkApp = mkApp + +let mkAppA v = + let l = Array.length v in + if l=0 then anomaly "mkAppA received an empty array" + else mkApp (v.(0), Array.sub v 1 (Array.length v -1)) + +(* Constructs a constant *) +(* The array of terms correspond to the variables introduced in the section *) +let mkConst = mkConst + +(* Constructs an existential variable *) +let mkEvar = mkEvar + +(* Constructs the ith (co)inductive type of the block named kn *) +(* The array of terms correspond to the variables introduced in the section *) +let mkInd = mkInd + +(* Constructs the jth constructor of the ith (co)inductive type of the + block named kn. The array of terms correspond to the variables + introduced in the section *) +let mkConstruct = mkConstruct + +(* Constructs the term

Case c of c1 | c2 .. | cn end *) +let mkCase = mkCase +let mkCaseL (ci, p, c, ac) = mkCase (ci, p, c, Array.of_list ac) + +(* If recindxs = [|i1,...in|] + funnames = [|f1,...fn|] + typarray = [|t1,...tn|] + bodies = [|b1,...bn|] + then + + mkFix ((recindxs,i),(funnames,typarray,bodies)) + + constructs the ith function of the block + + Fixpoint f1 [ctx1] : t1 := b1 + with f2 [ctx2] : t2 := b2 + ... + with fn [ctxn] : tn := bn. + + where the lenght of the jth context is ij. +*) + +let mkFix = mkFix + +(* If funnames = [|f1,...fn|] + typarray = [|t1,...tn|] + bodies = [|b1,...bn|] + then + + mkCoFix (i,(funnames,typsarray,bodies)) + + constructs the ith function of the block + + CoFixpoint f1 : t1 := b1 + with f2 : t2 := b2 + ... + with fn : tn := bn. +*) +let mkCoFix = mkCoFix + +(* Construct an implicit *) +let implicit_sort = Type (make_univ(make_dirpath[id_of_string"implicit"],0)) +let mkImplicit = mkSort implicit_sort + +let rec strip_outer_cast c = match kind_of_term c with + | Cast (c,_) -> strip_outer_cast c + | _ -> c + +(* Fonction spéciale qui laisse les cast clés sous les Fix ou les Case *) + +let under_outer_cast f c = match kind_of_term c with + | Cast (b,t) -> mkCast (f b,f t) + | _ -> f c + +let rec under_casts f c = match kind_of_term c with + | Cast (c,t) -> mkCast (under_casts f c, t) + | _ -> f c + +(***************************) +(* Other term constructors *) +(***************************) + +let abs_implicit c = mkLambda (Anonymous, mkImplicit, c) +let lambda_implicit a = mkLambda (Name(id_of_string"y"), mkImplicit, a) +let lambda_implicit_lift n a = iterate lambda_implicit n (lift n a) + +(* prodn n [xn:Tn;..;x1:T1;Gamma] b = (x1:T1)..(xn:Tn)b *) +let prodn n env b = + let rec prodrec = function + | (0, env, b) -> b + | (n, ((v,t)::l), b) -> prodrec (n-1, l, mkProd (v,t,b)) + | _ -> assert false + in + prodrec (n,env,b) + +(* compose_prod [xn:Tn;..;x1:T1] b = (x1:T1)..(xn:Tn)b *) +let compose_prod l b = prodn (List.length l) l b + +(* lamn n [xn:Tn;..;x1:T1;Gamma] b = [x1:T1]..[xn:Tn]b *) +let lamn n env b = + let rec lamrec = function + | (0, env, b) -> b + | (n, ((v,t)::l), b) -> lamrec (n-1, l, mkLambda (v,t,b)) + | _ -> assert false + in + lamrec (n,env,b) + +(* compose_lam [xn:Tn;..;x1:T1] b = [x1:T1]..[xn:Tn]b *) +let compose_lam l b = lamn (List.length l) l b + +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 + | Prod (na,ty,bd) -> mkLambda (na,ty,to_lambda (n-1) bd) + | Cast (c,_) -> to_lambda n c + | _ -> errorlabstrm "to_lambda" (mt ()) + +let rec to_prod n lam = + if n=0 then + lam + 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 ()) + +(* pseudo-reduction rule: + * [prod_app s (Prod(_,B)) N --> B[N] + * with an strip_outer_cast on the first argument to produce a product *) + +let prod_app t n = + match kind_of_term (strip_outer_cast t) with + | Prod (_,_,b) -> subst1 n b + | _ -> + errorlabstrm "prod_app" + (str"Needed a product, but didn't find one" ++ fnl ()) + + +(* prod_appvect T [| a1 ; ... ; an |] -> (T a1 ... an) *) +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 + +(*********************************) +(* 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 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 + 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 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 + lamdec_rec [] + +(* 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 + | 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 + +(* 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 + | 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 + +(* (nb_lam [na1:T1]...[nan:Tan]c) where c is not an abstraction + * gives n (casts are ignored) *) +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 + nbrec 0 + +(* similar to nb_lam, but gives the number of products instead *) +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 + nbrec 0 + +(* Rem: end of import from old module Generic *) + +(*******************************) +(* alpha conversion functions *) +(*******************************) + +(* alpha conversion : ignore print names and casts *) + +let rec eq_constr m n = + (m==n) or + compare_constr eq_constr m n +let eq_constr m n = eq_constr m n (* to avoid tracing a recursive fun *) + +(*******************) +(* hash-consing *) +(*******************) + +module Htype = + Hashcons.Make( + struct + type t = types + type u = (constr -> constr) * (sorts -> sorts) +(* + let hash_sub (hc,hs) j = {body=hc j.body; typ=hs j.typ} + let equal j1 j2 = j1.body==j2.body & j1.typ==j2.typ +*) +(**) + let hash_sub (hc,hs) j = hc j + let equal j1 j2 = j1==j2 +(**) + let hash = Hashtbl.hash + end) + +module Hsorts = + Hashcons.Make( + struct + type t = sorts + type u = universe -> universe + let hash_sub huniv = function + Prop c -> Prop c + | Type u -> Type (huniv u) + let equal s1 s2 = + match (s1,s2) with + (Prop c1, Prop c2) -> c1=c2 + | (Type u1, Type u2) -> u1 == u2 + |_ -> false + let hash = Hashtbl.hash + end) + +let hsort = Hsorts.f + +let hcons_constr (hkn,hdir,hname,hident,hstr) = + let hsortscci = Hashcons.simple_hcons hsort hcons1_univ in + let hcci = hcons_term (hsortscci,hkn,hname,hident) in + let htcci = Hashcons.simple_hcons Htype.f (hcci,hsortscci) in + (hcci,htcci) + +let (hcons1_constr, hcons1_types) = hcons_constr (hcons_names()) diff --git a/kernel/term.mli b/kernel/term.mli new file mode 100644 index 00000000..a5e5c081 --- /dev/null +++ b/kernel/term.mli @@ -0,0 +1,525 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* sorts_family + +(*s Useful types *) + +(*s Existential variables *) +type existential_key = int + +(*s Existential variables *) +type metavariable = int + +(*s Case annotation *) +type pattern_source = DefaultPat of int | RegularPat +type case_style = LetStyle | IfStyle | MatchStyle | RegularStyle +type case_printing = + { ind_nargs : int; (* number of real args of the inductive type *) + style : case_style; + source : pattern_source array } +(* the integer is the number of real args, needed for reduction *) +type case_info = + { ci_ind : inductive; + ci_npar : int; + ci_pp_info : case_printing (* not interpreted by the kernel *) + } + +(*s*******************************************************************) +(* The type of constructions *) + +type constr + +(* [eq_constr a b] is true if [a] equals [b] modulo alpha, casts, + and application grouping *) +val eq_constr : constr -> constr -> bool + +(* [types] is the same as [constr] but is intended to be used where a + {\em type} in CCI sense is expected (Rem:plurial form since [type] is a + reserved ML keyword) *) + +type types = constr + +(*s Functions about [types] *) + +val type_app : (constr -> constr) -> types -> types + +val body_of_type : types -> constr + +(*s Functions for dealing with constr terms. + The following functions are intended to simplify and to uniform the + manipulation of terms. Some of these functions may be overlapped with + previous ones. *) + +(*s Term constructors. *) + +(* Constructs a DeBrujin index (DB indices begin at 1) *) +val mkRel : int -> constr + +(* Constructs a Variable *) +val mkVar : identifier -> constr + +(* Constructs an patvar named "?n" *) +val mkMeta : metavariable -> constr + +(* Constructs an existential variable *) +type existential = existential_key * constr array +val mkEvar : existential -> constr + +(* Construct a sort *) +val mkSort : sorts -> types +val mkProp : types +val mkSet : types +val mkType : Univ.universe -> types + +(* 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 * types -> constr + +(* Constructs the product [(x:t1)t2] *) +val mkProd : name * types * types -> types +val mkNamedProd : identifier -> types -> types -> types +(* non-dependant product $t_1 \rightarrow t_2$, an alias for + [(_:t1)t2]. Beware $t_2$ is NOT lifted. + Eg: A |- A->A is built by [(mkArrow (mkRel 0) (mkRel 1))] *) +val mkArrow : types -> types -> constr + +(* Constructs the abstraction $[x:t_1]t_2$ *) +val mkLambda : name * types * constr -> constr +val mkNamedLambda : identifier -> types -> constr -> constr + +(* Constructs the product [let x = t1 : t2 in t3] *) +val mkLetIn : name * constr * types * constr -> constr +val mkNamedLetIn : identifier -> constr -> types -> constr -> constr + +(* [mkApp (f,[| t_1; ...; t_n |]] constructs the application + $(f~t_1~\dots~t_n)$. *) +val mkApp : constr * constr array -> constr + +(* Constructs a constant *) +(* The array of terms correspond to the variables introduced in the section *) +val mkConst : constant -> constr + +(* Inductive types *) + +(* Constructs the ith (co)inductive type of the block named kn *) +(* The array of terms correspond to the variables introduced in the section *) +val mkInd : inductive -> constr + +(* Constructs the jth constructor of the ith (co)inductive type of the + block named kn. The array of terms correspond to the variables + introduced in the section *) +val mkConstruct : constructor -> constr + +(* Constructs the term

Case c of c1 | c2 .. | cn end *) +val mkCase : case_info * constr * constr * constr array -> constr + +(* If [recindxs = [|i1,...in|]] + [funnames = [|f1,.....fn|]] + [typarray = [|t1,...tn|]] + [bodies = [|b1,.....bn|]] + then [ mkFix ((recindxs,i), funnames, typarray, bodies) ] + constructs the $i$th function of the block (counting from 0) + + [Fixpoint f1 [ctx1] = b1 + with f2 [ctx2] = b2 + ... + with fn [ctxn] = bn.] + + \noindent where the length of the $j$th context is $ij$. +*) +type rec_declaration = name array * types array * constr array +type fixpoint = (int array * int) * rec_declaration +val mkFix : fixpoint -> constr + +(* If [funnames = [|f1,.....fn|]] + [typarray = [|t1,...tn|]] + [bodies = [b1,.....bn]] \par\noindent + then [mkCoFix (i, (typsarray, funnames, bodies))] + constructs the ith function of the block + + [CoFixpoint f1 = b1 + with f2 = b2 + ... + with fn = bn.] + *) +type cofixpoint = int * rec_declaration +val mkCoFix : cofixpoint -> constr + + +(*s Concrete type for making pattern-matching. *) + +(* [constr array] is an instance matching definitional [named_context] in + the same order (i.e. last argument first) *) +type 'constr pexistential = existential_key * 'constr array +type ('constr, 'types) prec_declaration = + name array * 'types array * 'constr array +type ('constr, 'types) pfixpoint = + (int array * int) * ('constr, 'types) prec_declaration +type ('constr, 'types) pcofixpoint = + int * ('constr, 'types) prec_declaration + +type ('constr, 'types) kind_of_term = + | Rel of int + | Var of identifier + | Meta of metavariable + | Evar of 'constr pexistential + | Sort of sorts + | Cast of 'constr * 'types + | Prod of name * 'types * 'types + | Lambda of name * 'types * 'constr + | LetIn of name * 'constr * 'types * 'constr + | App of 'constr * 'constr array + | Const of constant + | Ind of inductive + | Construct of constructor + | Case of case_info * 'constr * 'constr * 'constr array + | Fix of ('constr, 'types) pfixpoint + | CoFix of ('constr, 'types) pcofixpoint + +(* User view of [constr]. For [App], it is ensured there is at + least one argument and the function is not itself an applicative + term *) + +val kind_of_term : constr -> (constr, types) kind_of_term + +(* Experimental *) +type ('constr, 'types) kind_of_type = + | SortType of sorts + | CastType of 'types * 'types + | ProdType of name * 'types * 'types + | LetInType of name * 'constr * 'types * 'types + | AtomicType of 'constr * 'constr array + +val kind_of_type : types -> (constr, types) kind_of_type + +(*s Simple term case analysis. *) + +val isRel : constr -> bool +val isVar : constr -> bool +val isInd : constr -> bool +val isEvar : constr -> bool +val isMeta : constr -> bool +val isSort : constr -> bool +val isCast : constr -> bool +val isApp : constr -> bool +val isConst : constr -> bool +val isConstruct : constr -> bool + +val is_Prop : constr -> bool +val is_Set : constr -> bool +val isprop : constr -> bool +val is_Type : constr -> bool +val iskind : constr -> bool +val is_small : sorts -> bool + +(*s Term destructors. + Destructor operations are partial functions and + raise [invalid_arg "dest*"] if the term has not the expected form. *) + +(* Destructs a DeBrujin index *) +val destRel : constr -> int + +(* Destructs an existential variable *) +val destMeta : constr -> metavariable + +(* Destructs a variable *) +val destVar : constr -> identifier + +(* Destructs a sort. [is_Prop] recognizes the sort \textsf{Prop}, whether + [isprop] recognizes both \textsf{Prop} and \textsf{Set}. *) +val destSort : constr -> sorts + +(* Destructs a casted term *) +val destCast : constr -> constr * types + +(* Destructs the product $(x:t_1)t_2$ *) +val destProd : types -> name * types * types + +(* Destructs the abstraction $[x:t_1]t_2$ *) +val destLambda : constr -> name * types * constr + +(* Destructs the let $[x:=b:t_1]t_2$ *) +val destLetIn : constr -> name * constr * types * constr + +(* Destructs an application *) +val destApplication : constr -> constr * constr array +(* ... removing casts *) +val decompose_app : constr -> constr * constr list + +(* Destructs a constant *) +val destConst : constr -> constant + +(* Destructs an existential variable *) +val destEvar : constr -> existential + +(* Destructs a (co)inductive type *) +val destInd : constr -> inductive + +(* Destructs a constructor *) +val destConstruct : constr -> constructor + +(* Destructs a term

Case c of lc1 | lc2 .. | lcn end *) +val destCase : constr -> case_info * constr * constr * constr array + +(* Destructs the $i$th function of the block + $\mathit{Fixpoint} ~ f_1 ~ [ctx_1] = b_1 + \mathit{with} ~ f_2 ~ [ctx_2] = b_2 + \dots + \mathit{with} ~ f_n ~ [ctx_n] = b_n$, + where the lenght of the $j$th context is $ij$. +*) +val destFix : constr -> fixpoint + +val destCoFix : constr -> cofixpoint + + +(*s A {\em declaration} has the form (name,body,type). It is either an + {\em assumption} if [body=None] or a {\em definition} if + [body=Some actualbody]. It is referred by {\em name} if [na] is an + identifier or by {\em relative index} if [na] is not an identifier + (in the latter case, [na] is of type [name] but just for printing + purpose *) + +type named_declaration = identifier * constr option * types +type rel_declaration = name * constr option * types + +val map_named_declaration : + (constr -> constr) -> named_declaration -> named_declaration +val map_rel_declaration : + (constr -> constr) -> rel_declaration -> rel_declaration + +(* 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 +val mkNamedProd_wo_LetIn : named_declaration -> types -> types + +(* Constructs either [[x:t]c] or [[x=b:t]c] *) +val mkLambda_or_LetIn : rel_declaration -> constr -> constr +val mkNamedLambda_or_LetIn : named_declaration -> constr -> constr + +(*s Other term constructors. *) + +val abs_implicit : constr -> constr +val lambda_implicit : constr -> constr +val lambda_implicit_lift : int -> constr -> constr + +(* [applist (f,args)] and co work as [mkApp] *) + +val applist : constr * constr list -> constr +val applistc : constr -> constr list -> constr +val appvect : constr * constr array -> constr +val appvectc : constr -> constr array -> constr + +(* [prodn n l b] = $(x_1:T_1)..(x_n:T_n)b$ + where $l = [(x_n,T_n);\dots;(x_1,T_1);Gamma]$ *) +val prodn : int -> (name * constr) list -> constr -> constr + +(* [compose_prod l b] = $(x_1:T_1)..(x_n:T_n)b$ + where $l = [(x_n,T_n);\dots;(x_1,T_1)]$. + Inverse of [decompose_prod]. *) +val compose_prod : (name * constr) list -> constr -> constr + +(* [lamn n l b] = $[x_1:T_1]..[x_n:T_n]b$ + where $l = [(x_n,T_n);\dots;(x_1,T_1);Gamma]$ *) +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] *) +val compose_lam : (name * constr) list -> constr -> constr + +(* [to_lambda n l] + = $[x_1:T_1]...[x_n:T_n]T$ + where $l = (x_1:T_1)...(x_n:T_n)T$ *) +val to_lambda : int -> constr -> constr + +(* [to_prod n l] + = $(x_1:T_1)...(x_n:T_n)T$ + where $l = [x_1:T_1]...[x_n:T_n]T$ *) +val to_prod : int -> constr -> constr + +(* pseudo-reduction rule *) + +(* [prod_appvect] $(x1:B1;...;xn:Bn)B a1...an \rightarrow B[a1...an]$ *) +val prod_appvect : constr -> constr array -> constr +val prod_applist : constr -> constr list -> constr + +(*s Other term destructors. *) + +(* Transforms a product term $(x_1:T_1)..(x_n:T_n)T$ into the pair + $([(x_n,T_n);...;(x_1,T_1)],T)$, where $T$ is not a product. + It includes also local definitions *) +val decompose_prod : constr -> (name*constr) list * constr + +(* Transforms a lambda term $[x_1:T_1]..[x_n:T_n]T$ into the pair + $([(x_n,T_n);...;(x_1,T_1)],T)$, where $T$ is not a lambda. *) +val decompose_lam : constr -> (name*constr) list * constr + +(* Given a positive integer n, transforms a product term + $(x_1:T_1)..(x_n:T_n)T$ + into the pair $([(xn,Tn);...;(x1,T1)],T)$. *) +val decompose_prod_n : int -> constr -> (name * constr) list * constr + +(* Given a positive integer $n$, transforms a lambda term + $[x_1:T_1]..[x_n:T_n]T$ into the pair $([(x_n,T_n);...;(x_1,T_1)],T)$ *) +val decompose_lam_n : int -> constr -> (name * constr) list * 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 *) +val nb_prod : constr -> int + +(* flattens application lists *) +val collapse_appl : constr -> constr + + +(* Removes recursively the casts around a term i.e. + [strip_outer_cast] (Cast (Cast ... (Cast c, t) ... ))] is [c]. *) +val strip_outer_cast : constr -> constr + +(* Apply a function letting Casted types in place *) +val under_casts : (constr -> constr) -> constr -> constr + +(*s Occur checks *) + +(* [closed0 M] is true iff [M] is a (deBruijn) closed term *) +val closed0 : constr -> bool + +(* [noccurn n M] returns true iff [Rel n] does NOT occur in term [M] *) +val noccurn : int -> constr -> bool + +(* [noccur_between n m M] returns true iff [Rel p] does NOT occur in term [M] + for n <= p < n+m *) +val noccur_between : int -> int -> constr -> bool + +(* Checking function for terms containing existential- or + meta-variables. The function [noccur_with_meta] considers only + meta-variable applied to some terms (intented to be its local + context) (for existential variables, it is necessarily the case) *) +val noccur_with_meta : int -> int -> constr -> bool + +(*s Relocation and substitution *) + +(* [exliftn el c] lifts [c] with lifting [el] *) +val exliftn : Esubst.lift -> constr -> constr + +(* [liftn n k c] lifts by [n] indexes above [k] in [c] *) +val liftn : int -> int -> constr -> constr + +(* [lift n c] lifts by [n] the positive indexes in [c] *) +val lift : int -> constr -> constr + +(* [substnl [a1;...;an] k c] substitutes in parallel [a1],...,[an] + for respectively [Rel(k+1)],...,[Rel(k+n)] in [c]; it relocates + accordingly indexes in [a1],...,[an] *) +val substnl : constr list -> int -> constr -> constr +val substl : constr list -> constr -> constr +val subst1 : constr -> constr -> constr + +val substl_decl : constr list -> named_declaration -> named_declaration +val subst1_decl : constr -> named_declaration -> named_declaration + +val replace_vars : (identifier * constr) list -> constr -> constr +val subst_var : identifier -> constr -> constr + +(* [subst_vars [id1;...;idn] t] substitute [VAR idj] by [Rel j] in [t] + if two names are identical, the one of least indice is keeped *) +val subst_vars : identifier list -> constr -> constr +(* [substn_vars n [id1;...;idn] t] substitute [VAR idj] by [Rel j+n-1] in [t] + if two names are identical, the one of least indice is keeped *) +val substn_vars : int -> identifier list -> constr -> constr + + +(* [subst_mps sub c] performs the substitution [sub] on all kernel + names appearing in [c] *) +val subst_mps : substitution -> constr -> constr + + +(*s Functionals working on the immediate subterm of a construction *) + +(* [fold_constr f acc c] folds [f] on the immediate subterms of [c] + starting from [acc] and proceeding from left to right according to + the usual representation of the constructions; it is not recursive *) + +val fold_constr : ('a -> constr -> 'a) -> 'a -> constr -> 'a + +(* [map_constr f c] maps [f] on the immediate subterms of [c]; it is + not recursive and the order with which subterms are processed is + not specified *) + +val map_constr : (constr -> constr) -> constr -> constr + +(* [map_constr_with_binders g f n c] maps [f n] on the immediate + subterms of [c]; it carries an extra data [n] (typically a lift + index) which is processed by [g] (which typically add 1 to [n]) at + each binder traversal; it is not recursive and the order with which + subterms are processed is not specified *) + +val map_constr_with_binders : + ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr + +(* [iter_constr f c] iters [f] on the immediate subterms of [c]; it is + not recursive and the order with which subterms are processed is + not specified *) + +val iter_constr : (constr -> unit) -> constr -> unit + +(* [iter_constr_with_binders g f n c] iters [f n] on the immediate + subterms of [c]; it carries an extra data [n] (typically a lift + index) which is processed by [g] (which typically add 1 to [n]) at + each binder traversal; it is not recursive and the order with which + subterms are processed is not specified *) + +val iter_constr_with_binders : + ('a -> 'a) -> ('a -> constr -> unit) -> 'a -> constr -> unit + +(* [compare_constr f c1 c2] compare [c1] and [c2] using [f] to compare + the immediate subterms of [c1] of [c2] if needed; Cast's, binders + name and Cases annotations are not taken into account *) + +val compare_constr : (constr -> constr -> bool) -> constr -> constr -> bool + +(*********************************************************************) + +val hcons_constr: + (kernel_name -> kernel_name) * + (dir_path -> dir_path) * + (name -> name) * + (identifier -> identifier) * + (string -> string) + -> + (constr -> constr) * + (types -> types) + +val hcons1_constr : constr -> constr +val hcons1_types : types -> types diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml new file mode 100644 index 00000000..5347583f --- /dev/null +++ b/kernel/term_typing.ml @@ -0,0 +1,118 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* j.uj_type, cst1 + | Some t -> + let (tj,cst2) = infer_type env t in + let cst3 = + try conv_leq env j.uj_type tj.utj_val + with NotConvertible -> error_actual_type env j tj.utj_val in + let typ = + if t = tj.utj_val then t else + (error "Kernel built a type different from its input\n"; + flush stdout; tj.utj_val) in + typ, Constraint.union (Constraint.union cst1 cst2) cst3 + + +let translate_local_def env (b,topt) = + let (j,cst) = infer env b in + let (typ,cst) = constrain_type env j cst topt in + (j.uj_val,typ,cst) + +let translate_local_assum env t = + let (j,cst) = infer env t in + let t = Typeops.assumption_of_judgment env j in + (t,cst) + +(* + +(* Same as push_named, but check that the variable is not already + there. Should *not* be done in Environ because tactics add temporary + hypothesis many many times, and the check performed here would + cost too much. *) +let safe_push_named (id,_,_ as d) env = + let _ = + try + let _ = lookup_named id env in + error ("identifier "^string_of_id id^" already defined") + with Not_found -> () in + push_named d env + +let push_named_def = push_rel_or_named_def safe_push_named +let push_rel_def = push_rel_or_named_def push_rel + +let push_rel_or_named_assum push (id,t) env = + let (j,cst) = safe_infer env t in + let t = Typeops.assumption_of_judgment env j in + let env' = add_constraints cst env in + let env'' = push (id,None,t) env' in + (cst,env'') + +let push_named_assum = push_rel_or_named_assum push_named +let push_rel_assum d env = snd (push_rel_or_named_assum push_rel d env) + +let push_rels_with_univ vars env = + List.fold_left (fun env nvar -> push_rel_assum nvar env) env vars +*) + + +(* Insertion of constants and parameters in environment. *) + +let infer_declaration env dcl = + match dcl with + | DefinitionEntry c -> + let (j,cst) = infer env c.const_entry_body in + let (typ,cst) = constrain_type env j cst c.const_entry_type in + Some (Declarations.from_val j.uj_val), typ, cst, c.const_entry_opaque + | ParameterEntry t -> + let (j,cst) = infer env t in + None, Typeops.assumption_of_judgment env j, cst, false + +let build_constant_declaration env (body,typ,cst,op) = + let ids = match body with + | None -> global_vars_set env typ + | Some b -> + Idset.union + (global_vars_set env (Declarations.force b)) + (global_vars_set env typ) + in + let hyps = keep_hyps env ids in + { const_body = body; + const_type = typ; + const_hyps = hyps; + const_constraints = cst; + const_opaque = op } + +(*s Global and local constant declaration. *) + +let translate_constant env ce = + build_constant_declaration env (infer_declaration env ce) + +let translate_recipe env r = + build_constant_declaration env (Cooking.cook_constant env r) + +(* Insertion of inductive types. *) + +let translate_mind env mie = check_inductive env mie diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli new file mode 100644 index 00000000..67d479ba --- /dev/null +++ b/kernel/term_typing.mli @@ -0,0 +1,34 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* constr * types option -> + constr * types * Univ.constraints + +val translate_local_assum : env -> types -> + types * Univ.constraints + +val translate_constant : env -> constant_entry -> constant_body + +val translate_mind : + env -> mutual_inductive_entry -> mutual_inductive_body + +val translate_recipe : + env -> Cooking.recipe -> constant_body diff --git a/kernel/type_errors.ml b/kernel/type_errors.ml new file mode 100644 index 00000000..c3d4726f --- /dev/null +++ b/kernel/type_errors.ml @@ -0,0 +1,114 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* int -> 'a + +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 -> types list -> constr + -> unsafe_judgment -> (constr * constr * arity_error) option -> 'a + +val error_case_not_inductive : env -> unsafe_judgment -> 'a + +val error_number_branches : env -> unsafe_judgment -> int -> 'a + +val error_ill_formed_branch : env -> constr -> int -> constr -> constr -> 'a + +val error_generalization : env -> name * types -> unsafe_judgment -> 'a + +val error_actual_type : env -> unsafe_judgment -> types -> 'a + +val error_cant_apply_not_functional : + env -> unsafe_judgment -> unsafe_judgment array -> 'a + +val error_cant_apply_bad_type : + env -> int * constr * constr -> + unsafe_judgment -> unsafe_judgment array -> 'a + +val error_ill_formed_rec_body : + env -> guard_error -> name array -> int -> 'a + +val error_ill_typed_rec_body : + env -> int -> name array -> unsafe_judgment array -> types array -> 'a + diff --git a/kernel/typeops.ml b/kernel/typeops.ml new file mode 100644 index 00000000..66b2e24d --- /dev/null +++ b/kernel/typeops.ml @@ -0,0 +1,489 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* {utj_val = j.uj_val; utj_type = s } + | _ -> error_not_type env j + +(* This should be a type intended to be assumed. The error message is *) +(* not as useful as for [type_judgment]. *) +let assumption_of_judgment env j = + try (type_judgment env j).utj_val + with TypeError _ -> + error_assumption env j + +(* +let aojkey = Profile.declare_profile "assumption_of_judgment";; +let assumption_of_judgment env j + = Profile.profile2 aojkey assumption_of_judgment env j;; +*) + +(************************************************) +(* Incremental typing rules: builds a typing judgement given the *) +(* judgements for the subterms. *) + +(*s Type of sorts *) + +(* Prop and Set *) + +let judge_of_prop = + { uj_val = body_of_type mkProp; + uj_type = mkSort type_0 } + +let judge_of_set = + { uj_val = body_of_type mkSet; + uj_type = mkSort type_0 } + +let judge_of_prop_contents = function + | Null -> judge_of_prop + | Pos -> judge_of_set + +(* Type of Type(i). *) + +let judge_of_type u = + let uu = super u in + { uj_val = body_of_type (mkType u); + uj_type = mkType uu } + +(*s Type of a de Bruijn index. *) + +let judge_of_relative env n = + try + let (_,_,typ) = lookup_rel n env in + { uj_val = mkRel n; + uj_type = type_app (lift n) typ } + with Not_found -> + error_unbound_rel env n + +(* +let relativekey = Profile.declare_profile "judge_of_relative";; +let judge_of_relative env n = + Profile.profile2 relativekey judge_of_relative env n;; +*) + +(* Type of variables *) +let judge_of_variable env id = + try + let (_,_,ty) = lookup_named id env in + make_judge (mkVar id) ty + with Not_found -> + error_unbound_var env id + +(* Management of context of variables. *) + +(* Checks if a context of variable can be instanciated by the + variables of the current env *) +(* TODO: check order? *) +let rec check_hyps_inclusion env sign = + let env_sign = named_context env in + Sign.fold_named_context + (fun (id,_,ty1) () -> + let (_,_,ty2) = Sign.lookup_named id env_sign in + if not (eq_constr ty2 ty1) then + error "types do not match") + sign + ~init:() + + +let check_args env c hyps = + let hyps' = named_context env in + try check_hyps_inclusion env hyps + with UserError _ | Not_found -> + error_reference_variables env c + + +(* Checks if the given context of variables [hyps] is included in the + current context of [env]. *) +(* +let check_hyps id env hyps = + let hyps' = named_context env in + if not (hyps_inclusion env hyps hyps') then + error_reference_variables env id +*) +(* Instantiation of terms on real arguments. *) + +(* Type of constants *) +let judge_of_constant env cst = + let constr = mkConst cst in + let _ = + let ce = lookup_constant cst env in + check_args env constr ce.const_hyps in + make_judge constr (constant_type env cst) + +(* +let tockey = Profile.declare_profile "type_of_constant";; +let type_of_constant env c + = Profile.profile3 tockey type_of_constant env c;; +*) + +(* Type of a lambda-abstraction. *) + +(* [judge_of_abstraction env name var j] implements the rule + + env, name:typ |- j.uj_val:j.uj_type env, |- (name:typ)j.uj_type : s + ----------------------------------------------------------------------- + env |- [name:typ]j.uj_val : (name:typ)j.uj_type + + Since all products are defined in the Calculus of Inductive Constructions + and no upper constraint exists on the sort $s$, we don't need to compute $s$ +*) + +let judge_of_abstraction env name var j = + { uj_val = mkLambda (name, var.utj_val, j.uj_val); + uj_type = mkProd (name, var.utj_val, j.uj_type) } + +(* Type of let-in. *) + +let judge_of_letin env name defj typj j = + { uj_val = mkLetIn (name, defj.uj_val, typj.utj_val, j.uj_val) ; + uj_type = type_app (subst1 defj.uj_val) j.uj_type } + +(* Type of an application. *) + +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 + 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 -> + error_cant_apply_bad_type env + (n,c1, hj.uj_type) + funj argjv) + + | _ -> + error_cant_apply_not_functional env funj argjv) + in + apply_rec 1 + funj.uj_type + Constraint.empty + (Array.to_list argjv) + +(* Type of product *) + +let sort_of_product env domsort rangsort = + match (domsort, rangsort) with + (* Product rule (s,Prop,Prop) *) + | (_, Prop Null) -> rangsort + (* Product rule (Prop/Set,Set,Set) *) + | (Prop _, Prop Pos) -> rangsort + (* Product rule (Type,Set,?) *) + | (Type u1, Prop Pos) -> + if engagement env = Some ImpredicativeSet then + (* Rule is (Type,Set,Set) in the Set-impredicative calculus *) + rangsort + else + (* Rule is (Type_i,Set,Type_i) in the Set-predicative calculus *) + domsort + (* Product rule (Prop,Type_i,Type_i) *) + | (Prop _, Type _) -> rangsort + (* 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 + + env |- typ1:s1 env, name:typ1 |- typ2 : s2 + ------------------------------------------------------------------------- + s' >= (s1,s2), env |- (name:typ)j.uj_val : s' + + where j.uj_type is convertible to a sort s2 +*) +let judge_of_product env name t1 t2 = + let s = sort_of_product env t1.utj_type t2.utj_type in + { uj_val = mkProd (name, t1.utj_val, t2.utj_val); + uj_type = mkSort s } + +(* Type of a type cast *) + +(* [judge_of_cast env (c,typ1) (typ2,s)] implements the rule + + env |- c:typ1 env |- typ2:s env |- typ1 <= typ2 + --------------------------------------------------------------------- + env |- c:typ2 +*) + +let judge_of_cast env cj tj = + let expected_type = tj.utj_val in + try + let cst = conv_leq env cj.uj_type expected_type in + { uj_val = mkCast (j_val cj, expected_type); + uj_type = expected_type }, + cst + with NotConvertible -> + error_actual_type env cj expected_type + +(* Inductive types. *) + +let judge_of_inductive env i = + let constr = mkInd i in + let _ = + let (kn,_) = i in + let mib = lookup_mind kn env in + check_args env constr mib.mind_hyps in + make_judge constr (type_of_inductive env i) + +(* +let toikey = Profile.declare_profile "judge_of_inductive";; +let judge_of_inductive env i + = Profile.profile2 toikey judge_of_inductive env i;; +*) + +(* Constructors. *) + +let judge_of_constructor env c = + let constr = mkConstruct c in + let _ = + let ((kn,_),_) = c in + let mib = lookup_mind kn env in + check_args env constr mib.mind_hyps in + make_judge constr (type_of_constructor env c) + +(* +let tockey = Profile.declare_profile "judge_of_constructor";; +let judge_of_constructor env cstr + = Profile.profile2 tockey judge_of_constructor env cstr;; +*) + +(* Case. *) + +let check_branch_types env cj (lft,explft) = + try conv_leq_vecti env lft explft + with + NotConvertibleVect i -> + error_ill_formed_branch env cj.uj_val i lft.(i) explft.(i) + | Invalid_argument _ -> + error_number_branches env cj (Array.length explft) + +let judge_of_case env ci pj cj lfj = + let indspec = + try find_rectype env cj.uj_type + with Not_found -> error_case_not_inductive env cj in + let _ = check_case_info env (fst indspec) ci in + let (bty,rslty,univ) = + type_case_branches env indspec pj cj.uj_val in + let (_,kind) = dest_arity env pj.uj_type in + let lft = Array.map j_type lfj in + let univ' = check_branch_types env cj (lft,bty) in + ({ uj_val = mkCase (ci, (*nf_betaiota*) pj.uj_val, cj.uj_val, + Array.map j_val lfj); + uj_type = rslty }, + Constraint.union univ univ') + +(* +let tocasekey = Profile.declare_profile "judge_of_case";; +let judge_of_case env ci pj cj lfj + = Profile.profile6 tocasekey judge_of_case env ci pj cj lfj;; +*) + +(* Fixpoints. *) + +(* Checks the type of a general (co)fixpoint, i.e. without checking *) +(* the specific guard condition. *) + +let type_fixpoint env lna lar vdefj = + let lt = Array.length vdefj in + assert (Array.length lar = lt); + try + conv_leq_vecti env + (Array.map (fun j -> body_of_type j.uj_type) vdefj) + (Array.map (fun ty -> lift lt ty) lar) + with NotConvertibleVect i -> + error_ill_typed_rec_body env i lna vdefj lar + +(************************************************************************) +(************************************************************************) + +(* This combinator adds the universe constraints both in the local + graph and in the universes of the environment. This is to ensure + that the infered local graph is satisfiable. *) +let univ_combinator (cst,univ) (j,c') = + (j,(Constraint.union cst c', merge_constraints c' univ)) + +(* The typing machine. *) + (* ATTENTION : faudra faire le typage du contexte des Const, + Ind et Constructsi un jour cela devient des constructions + arbitraires et non plus des variables *) +let rec execute env cstr cu = + match kind_of_term cstr with + (* Atomic terms *) + | Sort (Prop c) -> + (judge_of_prop_contents c, cu) + + | Sort (Type u) -> + (judge_of_type u, cu) + + | Rel n -> + (judge_of_relative env n, cu) + + | Var id -> + (judge_of_variable env id, cu) + + | Const c -> + (judge_of_constant env c, cu) + + (* Lambda calculus operators *) + | App (f,args) -> + let (j,cu1) = execute env f cu in + let (jl,cu2) = execute_array env args cu1 in + univ_combinator cu2 + (judge_of_apply env j jl) + + | 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 + (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 + let (varj',cu2) = execute_type env1 c2 cu1 in + (judge_of_product env name varj varj', cu2) + + | LetIn (name,c1,c2,c3) -> + let (j1,cu1) = execute env c1 cu in + let (j2,cu2) = execute_type env c2 cu1 in + let (_,cu3) = univ_combinator cu2 (judge_of_cast env j1 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,t) -> + let (cj,cu1) = execute env c cu in + let (tj,cu2) = execute_type env t cu1 in + univ_combinator cu2 + (judge_of_cast env cj tj) + + (* Inductive types *) + | Ind ind -> + (judge_of_inductive env ind, cu) + + | Construct c -> + (judge_of_constructor env c, cu) + + | Case (ci,p,c,lf) -> + let (cj,cu1) = execute env c cu in + let (pj,cu2) = execute env p cu1 in + 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 + check_cofix env cofix; + (make_judge (mkCoFix cofix) fix_ty, cu1) + + (* Partial proofs: unsupported by the kernel *) + | Meta _ -> + anomaly "the kernel does not support metavariables" + + | Evar _ -> + anomaly "the kernel does not support existential variables" + +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 + let env1 = push_rec_types (names,lara,vdef) env in + let (vdefj,cu2) = execute_array env1 vdef cu1 in + let vdefv = Array.map j_val vdefj in + let cst = type_fixpoint env1 names lara vdefj in + univ_combinator cu2 + ((lara.(i),(names,lara,vdefv)),cst) + +and execute_array env v cu = + let (jl,cu1) = execute_list env (Array.to_list v) cu in + (Array.of_list jl, cu1) + +and execute_list env l cu = + match l with + | [] -> + ([], cu) + | c::r -> + let (j,cu1) = execute env c cu in + let (jr,cu2) = execute_list env r cu1 in + (j::jr, cu2) + +(* Derived functions *) +let infer env constr = + let (j,(cst,_)) = + execute env constr (Constraint.empty, universes env) in + let j = if j.uj_val = constr then { j with uj_val = constr } else + (error "Kernel built a body different from its input\n"; + flush stdout; j) in + (j, cst) + +let infer_type env constr = + let (j,(cst,_)) = + execute_type env constr (Constraint.empty, universes env) in + (j, cst) + +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 -> + let (j,cst) = infer env c in + (Name id, Some j.uj_val, j.uj_type), cst + | LocalAssum c -> + let (j,cst) = infer env c in + (Name id, None, assumption_of_judgment env j), cst + +let infer_local_decls env decls = + let rec inferec env = function + | (id, d) :: l -> + let env, l, cst1 = inferec env l in + let d, cst2 = infer_local_decl env id d in + push_rel d env, add_rel_decl d l, Constraint.union cst1 cst2 + | [] -> env, empty_rel_context, Constraint.empty in + inferec env decls + +(* Exported typing functions *) + +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 new file mode 100644 index 00000000..ffe9d861 --- /dev/null +++ b/kernel/typeops.mli @@ -0,0 +1,92 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* constr -> unsafe_judgment * constraints +val infer_v : env -> constr array -> unsafe_judgment array * constraints +val infer_type : env -> types -> unsafe_type_judgment * constraints + +val infer_local_decls : + env -> (identifier * local_entry) list + -> env * Sign.rel_context * constraints + +(*s Basic operations of the typing machine. *) + +(* If [j] is the judgement $c:t$, then [assumption_of_judgement env j] + returns the type $c$, checking that $t$ is a sort. *) + +val assumption_of_judgment : env -> unsafe_judgment -> types +val type_judgment : env -> unsafe_judgment -> unsafe_type_judgment + +(*s Type of sorts. *) +val judge_of_prop_contents : contents -> unsafe_judgment +val judge_of_type : universe -> unsafe_judgment + +(*s Type of a bound variable. *) +val judge_of_relative : env -> int -> unsafe_judgment + +(*s Type of variables *) +val judge_of_variable : env -> variable -> unsafe_judgment + +(*s type of a constant *) +val judge_of_constant : env -> constant -> unsafe_judgment + +(*s Type of application. *) +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 + -> unsafe_judgment + +(*s Type of a product. *) +val judge_of_product : + 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 + -> unsafe_judgment + +(*s Type of a cast. *) +val judge_of_cast : + env -> unsafe_judgment -> unsafe_type_judgment + -> unsafe_judgment * constraints + +(*s Inductive types. *) + +val judge_of_inductive : env -> inductive -> unsafe_judgment + +val judge_of_constructor : env -> constructor -> unsafe_judgment + +(*s Type of Cases. *) +val judge_of_case : env -> case_info + -> unsafe_judgment -> unsafe_judgment -> unsafe_judgment array + -> unsafe_judgment * constraints + +(* Typecheck general fixpoint (not checking guard conditions) *) +val type_fixpoint : env -> name array -> types array + -> unsafe_judgment array -> constraints + +(* Kernel safe typing but applicable to partial proofs *) +val typing : env -> constr -> unsafe_judgment + diff --git a/kernel/univ.ml b/kernel/univ.ml new file mode 100644 index 00000000..d46609c8 --- /dev/null +++ b/kernel/univ.ml @@ -0,0 +1,469 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* $ between equivalence classes, and we maintain that $>$ is acyclic, + and contained in $\ge$ in the sense that $[U]>[V]$ implies $U\ge V$. + + At every moment, we have a finite number of universes, and we + maintain the ordering in the presence of assertions $U>V$ and $U\ge V$. + + The equivalence $\~{}$ is represented by a tree structure, as in the + union-find algorithm. The assertions $>$ and $\ge$ are represented by + adjacency lists *) + +open Pp +open Util + +type universe_level = + { u_mod : Names.dir_path; + u_num : int } + +type universe = + | Variable of universe_level + | Max of universe_level list * universe_level list + +module UniverseOrdered = struct + type t = universe_level + let compare = Pervasives.compare +end + +let string_of_univ_level u = + Names.string_of_dirpath u.u_mod^"."^string_of_int u.u_num + +let make_univ (m,n) = Variable { u_mod=m; u_num=n } + +let string_of_univ = function + | Variable u -> string_of_univ_level u + | Max (gel,gtl) -> + "max("^ + (String.concat "," + ((List.map string_of_univ_level gel)@ + (List.map (fun u -> "("^(string_of_univ_level u)^")+1") gtl)))^")" + +let pr_uni_level u = str (string_of_univ_level u) + +let pr_uni = function + | Variable u -> + pr_uni_level u + | Max (gel,gtl) -> + str "max(" ++ + prlist_with_sep pr_coma pr_uni_level gel ++ + if gel <> [] & gtl <> [] then pr_coma () else mt () ++ + prlist_with_sep pr_coma + (fun x -> str "(" ++ pr_uni_level x ++ str ")+1") gtl ++ + str ")" + +(* Returns a fresh universe, juste above u. Does not create new universes + for Type_0 (the sort of Prop and Set). + Used to type the sort u. *) +let super = function + | Variable u -> + Max ([],[u]) + | Max _ -> + anomaly ("Cannot take the successor of a non variable universes:\n"^ + "you are probably typing a type already known to be the type\n"^ + "of a user-provided term; if you really need this, please report") + +(* returns the least upper bound of universes u and v. If they are not + constrained, then a new universe is created. + Used to type the products. *) +let sup u v = + match u,v with + | Variable u, Variable v -> Max ((if u = v then [u] else [u;v]),[]) + | Variable u, Max (gel,gtl) -> Max (list_add_set u gel,gtl) + | Max (gel,gtl), Variable v -> Max (list_add_set v gel,gtl) + | Max (gel,gtl), Max (gel',gtl') -> + Max (list_union gel gel',list_union gtl gtl') + +(* Comparison on this type is pointer equality *) +type canonical_arc = + { univ: universe_level; gt: universe_level list; ge: universe_level list } + +let terminal u = {univ=u; gt=[]; ge=[]} + +(* A universe is either an alias for another one, or a canonical one, + for which we know the universes that are smaller *) +type univ_entry = + Canonical of canonical_arc + | Equiv of universe_level * universe_level + +module UniverseMap = Map.Make(UniverseOrdered) + +type universes = univ_entry UniverseMap.t + +let enter_equiv_arc u v g = + UniverseMap.add u (Equiv(u,v)) g + +let enter_arc ca g = + UniverseMap.add ca.univ (Canonical ca) g + +let declare_univ u g = + if not (UniverseMap.mem u g) then + enter_arc (terminal u) g + else + g + +(* When typing Prop and Set, there is no constraint on the level, + hence the definition of prop_univ *) + +let initial_universes = UniverseMap.empty +let prop_univ = Max ([],[]) + +(* Every universe has a unique canonical arc representative *) + +(* repr : universes -> universe -> canonical_arc *) +(* canonical representative : we follow the Equiv links *) +let repr g u = + let rec repr_rec u = + let a = + try UniverseMap.find u g + with Not_found -> anomalylabstrm "Univ.repr" + (str"Universe " ++ pr_uni_level u ++ str" undefined") + in + match a with + | Equiv(_,v) -> repr_rec v + | Canonical arc -> arc + in + repr_rec u + +let can g = List.map (repr g) + +(* transitive closure : we follow the Greater links *) + +(* collect : canonical_arc -> canonical_arc list * canonical_arc list *) +(* collect u = (V,W) iff V={v canonical | u>v} W={w canonical | u>=w}-V *) +(* i.e. collect does the transitive closure of what is known about u *) +let collect g arcu = + let rec coll_rec gt ge = function + | [],[] -> (gt, list_subtractq ge gt) + | arcv::gt', ge' -> + if List.memq arcv gt then + coll_rec gt ge (gt',ge') + else + coll_rec (arcv::gt) ge ((can g (arcv.gt@arcv.ge))@gt',ge') + | [], arcw::ge' -> + if (List.memq arcw gt) or (List.memq arcw ge) then + coll_rec gt ge ([],ge') + else + coll_rec gt (arcw::ge) (can g arcw.gt, (can g arcw.ge)@ge') + in + coll_rec [] [] ([],[arcu]) + +(* reprgeq : canonical_arc -> canonical_arc list *) +(* All canonical arcv such that arcu>=arcc with arcv#arcu *) +let reprgeq g arcu = + let rec searchrec w = function + | [] -> w + | v :: vl -> + let arcv = repr g v in + if List.memq arcv w || arcu==arcv then + searchrec w vl + else + searchrec (arcv :: w) vl + in + searchrec [] arcu.ge + + +(* between : universe -> canonical_arc -> canonical_arc list *) +(* between u v = {w|u>=w>=v, w canonical} *) +(* between is the most costly operation *) + +let between g u arcv = + (* good are all w | u >= w >= v *) + (* bad are all w | u >= w ~>= v *) + (* find good and bad nodes in {w | u >= w} *) + (* explore b u = (b or "u is good") *) + let rec explore ((good, bad, b) as input) arcu = + if List.memq arcu good then + (good, bad, true) (* b or true *) + else if List.memq arcu bad then + input (* (good, bad, b or false) *) + else + let childs = reprgeq g arcu in + (* are any children of u good ? *) + let good, bad, b_childs = + List.fold_left explore (good, bad, false) childs + in + if b_childs then + arcu::good, bad, true (* b or true *) + else + good, arcu::bad, b (* b or false *) + in + let good,_,_ = explore ([arcv],[],false) (repr g u) in + good + +(* We assume compare(u,v) = GE with v canonical (see compare below). + In this case List.hd(between g u v) = repr u + Otherwise, between g u v = [] + *) + + +type order = EQ | GT | GE | NGE + +(* compare : universe -> universe -> order *) +let compare g u v = + let arcu = repr g u + and arcv = repr g v in + if arcu==arcv then + EQ + else + let (gt,geq) = collect g arcu in + if List.memq arcv gt then + GT + else if List.memq arcv geq then + GE + else + NGE + +(* Invariants : compare(u,v) = EQ <=> compare(v,u) = EQ + compare(u,v) = GT or GE => compare(v,u) = NGE + compare(u,v) = NGE => compare(v,u) = NGE or GE or GT + + Adding u>=v is consistent iff compare(v,u) # GT + and then it is redundant iff compare(u,v) # NGE + Adding u>v is consistent iff compare(v,u) = NGE + and then it is redundant iff compare(u,v) = GT *) + + +(* setgt : universe -> universe -> unit *) +(* forces u > v *) +let setgt g u v = + let arcu = repr g u in + enter_arc {arcu with gt=v::arcu.gt} g + +(* checks that non-redondant *) +let setgt_if g u v = match compare g u v with + | GT -> g + | _ -> setgt g u v + +(* setgeq : universe -> universe -> unit *) +(* forces u >= v *) +let setgeq g u v = + let arcu = repr g u in + enter_arc {arcu with ge=v::arcu.ge} g + + +(* checks that non-redondant *) +let setgeq_if g u v = match compare g u v with + | NGE -> setgeq g u v + | _ -> g + +(* merge : universe -> universe -> unit *) +(* we assume compare(u,v) = GE *) +(* merge u v forces u ~ v with repr u as canonical repr *) +let merge g u v = + match between g u (repr g v) with + | arcu::v -> (* arcu is chosen as canonical and all others (v) are *) + (* redirected to it *) + let redirect (g,w,w') arcv = + let g' = enter_equiv_arc arcv.univ arcu.univ g in + (g',list_unionq arcv.gt w,arcv.ge@w') + in + let (g',w,w') = List.fold_left redirect (g,[],[]) v in + let g'' = List.fold_left (fun g -> setgt_if g arcu.univ) g' w in + let g''' = List.fold_left (fun g -> setgeq_if g arcu.univ) g'' w' in + g''' + | [] -> anomaly "Univ.between" + +(* merge_disc : universe -> universe -> unit *) +(* we assume compare(u,v) = compare(v,u) = NGE *) +(* merge_disc u v forces u ~ v with repr u as canonical repr *) +let merge_disc g u v = + let arcu = repr g u in + let arcv = repr g v in + let g' = enter_equiv_arc arcv.univ arcu.univ g in + let g'' = List.fold_left (fun g -> setgt_if g arcu.univ) g' arcv.gt in + let g''' = List.fold_left (fun g -> setgeq_if g arcu.univ) g'' arcv.ge in + g''' + +(* Universe inconsistency: error raised when trying to enforce a relation + that would create a cycle in the graph of universes. *) + +exception UniverseInconsistency + +let error_inconsistency () = raise UniverseInconsistency + +(* enforcegeq : universe -> universe -> unit *) +(* enforcegeq u v will force u>=v if possible, will fail otherwise *) +let enforce_univ_geq u v g = + let g = declare_univ u g in + let g = declare_univ v g in + match compare g u v with + | NGE -> + (match compare g v u with + | GT -> error_inconsistency() + | GE -> merge g v u + | NGE -> setgeq g u v + | EQ -> anomaly "Univ.compare") + | _ -> g + +(* enforceq : universe -> universe -> unit *) +(* enforceq u v will force u=v if possible, will fail otherwise *) +let enforce_univ_eq u v g = + let g = declare_univ u g in + let g = declare_univ v g in + match compare g u v with + | EQ -> g + | GT -> error_inconsistency() + | GE -> merge g u v + | NGE -> + (match compare g v u with + | GT -> error_inconsistency() + | GE -> merge g v u + | NGE -> merge_disc g u v + | EQ -> anomaly "Univ.compare") + +(* enforcegt u v will force u>v if possible, will fail otherwise *) +let enforce_univ_gt u v g = + let g = declare_univ u g in + let g = declare_univ v g in + match compare g u v with + | GT -> g + | GE -> setgt g u v + | EQ -> error_inconsistency() + | NGE -> + (match compare g v u with + | NGE -> setgt g u v + | _ -> error_inconsistency()) + +(* +let enforce_univ_relation g = function + | Equiv (u,v) -> enforce_univ_eq u v g + | Canonical {univ=u; gt=gt; ge=ge} -> + let g' = List.fold_right (enforce_univ_gt u) gt g in + List.fold_right (enforce_univ_geq u) ge g' +*) + +(* Merging 2 universe graphs *) +(* +let merge_universes sp u1 u2 = + UniverseMap.fold (fun _ a g -> enforce_univ_relation g a) u1 u2 +*) + + +(* Constraints and sets of consrtaints. *) + +type constraint_type = Gt | Geq | Eq + +type univ_constraint = universe_level * constraint_type * universe_level + +let enforce_constraint cst g = + match cst with + | (u,Gt,v) -> enforce_univ_gt u v g + | (u,Geq,v) -> enforce_univ_geq u v g + | (u,Eq,v) -> enforce_univ_eq u v g + + +module Constraint = Set.Make( + struct + type t = univ_constraint + let compare = Pervasives.compare + end) + +type constraints = Constraint.t + +type constraint_function = + universe -> universe -> constraints -> constraints + +let enforce_gt u v c = Constraint.add (u,Gt,v) c + +let enforce_geq u v c = + match u with + | Variable u -> (match v with + | Variable v -> Constraint.add (u,Geq,v) c + | Max (l1, l2) -> + let d = List.fold_right (fun v -> Constraint.add (u,Geq,v)) l1 c in + List.fold_right (fun v -> Constraint.add (u,Gt,v)) l2 d) + | Max _ -> anomaly "A universe bound can only be a variable" + +let enforce_eq u v c = + match (u,v) with + | Variable u, Variable v -> Constraint.add (u,Eq,v) c + | _ -> anomaly "A universe comparison can only happen between variables" + +let merge_constraints c g = + Constraint.fold enforce_constraint c g + +(* Pretty-printing *) + +let num_universes g = + UniverseMap.fold (fun _ _ -> succ) g 0 + +let num_edges g = + let reln_len = function + | Equiv _ -> 1 + | Canonical {gt=gt;ge=ge} -> List.length gt + List.length ge + in + UniverseMap.fold (fun _ a n -> n + (reln_len a)) g 0 + +let pr_arc = function + | Canonical {univ=u; gt=[]; ge=[]} -> + mt () + | Canonical {univ=u; gt=gt; ge=ge} -> + pr_uni_level u ++ str " " ++ + v 0 + (prlist_with_sep pr_spc (fun v -> str "> " ++ pr_uni_level v) gt ++ + prlist_with_sep pr_spc (fun v -> str ">= " ++ pr_uni_level v) ge) ++ + fnl () + | 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 + prlist (function (_,a) -> pr_arc a) graph + + +(* Dumping constrains to a file *) + +let dump_universes output g = + let dump_arc _ = function + | Canonical {univ=u; gt=gt; ge=ge} -> + let u_str = string_of_univ_level u in + List.iter + (fun v -> + Printf.fprintf output "%s > %s ;\n" u_str + (string_of_univ_level v)) + gt; + List.iter + (fun v -> + Printf.fprintf output "%s >= %s ;\n" u_str + (string_of_univ_level v)) + ge + | 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 + +module Huniv = + Hashcons.Make( + struct + type t = universe + type u = Names.dir_path -> Names.dir_path + let hash_aux hdir u = { u with u_mod=hdir u.u_mod } + let hash_sub hdir = function + | Variable u -> Variable (hash_aux hdir u) + | Max (gel,gtl) -> + Max (List.map (hash_aux hdir) gel, List.map (hash_aux hdir) gtl) + let equal u v = + match u, v with + | Variable u, Variable v -> u == v + | Max (gel,gtl), Max (gel',gtl') -> + (List.for_all2 (==) gel gel') && (List.for_all2 (==) gtl gtl') + | _ -> false + let hash = Hashtbl.hash + end) + +let hcons1_univ u = + let _,hdir,_,_,_ = Names.hcons_names() in + Hashcons.simple_hcons Huniv.f hdir u + diff --git a/kernel/univ.mli b/kernel/univ.mli new file mode 100644 index 00000000..e15971eb --- /dev/null +++ b/kernel/univ.mli @@ -0,0 +1,61 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* universe + +(* The type of a universe *) +val super : universe -> universe +(* The max of 2 universes *) +val sup : universe -> universe -> universe + +(*s Graphs of universes. *) + +type universes + +(* The empty graph of universes *) +val initial_universes : universes + +(*s Constraints. *) + +module Constraint : Set.S + +type constraints = Constraint.t + +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. + 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. *) + +exception UniverseInconsistency + +val merge_constraints : constraints -> universes -> universes + +(*s Pretty-printing of universes. *) + +val pr_uni : universe -> Pp.std_ppcmds +val pr_universes : universes -> Pp.std_ppcmds + +val string_of_univ : universe -> string + +(*s Dumping to a file *) + +val dump_universes : out_channel -> universes -> unit + +val hcons1_univ : universe -> universe -- cgit v1.2.3