summaryrefslogtreecommitdiff
path: root/pretyping
diff options
context:
space:
mode:
Diffstat (limited to 'pretyping')
-rw-r--r--pretyping/cases.ml490
-rw-r--r--pretyping/cases.mli36
-rw-r--r--pretyping/cbv.ml12
-rw-r--r--pretyping/cbv.mli2
-rw-r--r--[-rwxr-xr-x]pretyping/classops.ml188
-rw-r--r--pretyping/classops.mli22
-rw-r--r--pretyping/clenv.ml435
-rw-r--r--pretyping/clenv.mli117
-rw-r--r--pretyping/coercion.ml425
-rw-r--r--pretyping/coercion.mli58
-rw-r--r--pretyping/detyping.ml429
-rw-r--r--pretyping/detyping.mli25
-rw-r--r--pretyping/evarconv.ml415
-rw-r--r--pretyping/evarconv.mli19
-rw-r--r--pretyping/evarutil.ml721
-rw-r--r--pretyping/evarutil.mli143
-rw-r--r--pretyping/evd.ml522
-rw-r--r--pretyping/evd.mli123
-rw-r--r--pretyping/indrec.ml249
-rw-r--r--pretyping/indrec.mli27
-rw-r--r--pretyping/inductiveops.ml145
-rw-r--r--pretyping/inductiveops.mli23
-rw-r--r--pretyping/instantiate.ml68
-rw-r--r--pretyping/instantiate.mli25
-rw-r--r--pretyping/matching.ml35
-rw-r--r--pretyping/matching.mli11
-rw-r--r--pretyping/pattern.ml160
-rw-r--r--pretyping/pattern.mli21
-rw-r--r--pretyping/pretype_errors.ml27
-rw-r--r--pretyping/pretype_errors.mli24
-rw-r--r--pretyping/pretyping.ml1617
-rw-r--r--pretyping/pretyping.mli142
-rw-r--r--pretyping/rawterm.ml197
-rw-r--r--pretyping/rawterm.mli43
-rw-r--r--[-rwxr-xr-x]pretyping/recordops.ml230
-rwxr-xr-xpretyping/recordops.mli38
-rw-r--r--pretyping/reductionops.ml214
-rw-r--r--pretyping/reductionops.mli17
-rw-r--r--pretyping/retyping.ml66
-rw-r--r--pretyping/retyping.mli12
-rw-r--r--pretyping/tacred.ml263
-rw-r--r--pretyping/tacred.mli24
-rw-r--r--pretyping/termops.ml178
-rw-r--r--pretyping/termops.mli29
-rw-r--r--pretyping/typing.ml186
-rw-r--r--pretyping/typing.mli25
-rw-r--r--pretyping/unification.ml471
-rw-r--r--pretyping/unification.mli33
48 files changed, 5441 insertions, 3341 deletions
diff --git a/pretyping/cases.ml b/pretyping/cases.ml
index 4aff508f..a32aaf45 100644
--- a/pretyping/cases.ml
+++ b/pretyping/cases.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: cases.ml,v 1.111.2.5 2005/04/29 16:31:03 herbelin Exp $ *)
+(* $Id: cases.ml 8693 2006-04-10 12:05:05Z msozeau $ *)
open Util
open Names
@@ -33,6 +33,7 @@ type pattern_matching_error =
| BadPattern of constructor * constr
| BadConstructor of constructor * inductive
| WrongNumargConstructor of constructor * int
+ | WrongNumargInductive of inductive * int
| WrongPredicateArity of constr * constr * constr
| NeedsInversion of constr * constr
| UnusedClause of cases_pattern list
@@ -50,8 +51,11 @@ let error_bad_pattern_loc loc cstr ind =
let error_bad_constructor_loc loc cstr ind =
raise_pattern_matching_error (loc, Global.env(), BadConstructor (cstr,ind))
-let error_wrong_numarg_constructor_loc loc c n =
- raise_pattern_matching_error (loc, Global.env(), WrongNumargConstructor (c,n))
+let error_wrong_numarg_constructor_loc loc env c n =
+ raise_pattern_matching_error (loc, env, WrongNumargConstructor(c,n))
+
+let error_wrong_numarg_inductive_loc loc env c n =
+ raise_pattern_matching_error (loc, env, WrongNumargInductive(c,n))
let error_wrong_predicate_arity_loc loc env c n1 n2 =
raise_pattern_matching_error (loc, env, WrongPredicateArity (c,n1,n2))
@@ -59,107 +63,18 @@ let error_wrong_predicate_arity_loc loc env c n1 n2 =
let error_needs_inversion env x t =
raise (PatternMatchingError (env, NeedsInversion (x,t)))
-(*********************************************************************)
-(* A) Typing old cases *)
-(* This was previously in Indrec but creates existential holes *)
-
-let mkExistential isevars env loc = new_isevar isevars env loc (new_Type ())
-
-let norec_branch_scheme env isevars cstr =
- let rec crec env = function
- | d::rea -> mkProd_or_LetIn d (crec (push_rel d env) rea)
- | [] -> mkExistential isevars env (dummy_loc, InternalHole) in
- crec env (List.rev cstr.cs_args)
-
-let rec_branch_scheme env isevars (sp,j) recargs cstr =
- let rec crec env (args,recargs) =
- match args, recargs with
- | (name,None,c as d)::rea,(ra::reca) ->
- let d =
- match dest_recarg ra with
- | Mrec k when k=j ->
- let t = mkExistential isevars env (dummy_loc, InternalHole)
- in
- mkArrow t
- (crec (push_rel (Anonymous,None,t) env)
- (List.rev (lift_rel_context 1 (List.rev rea)),reca))
- | _ -> crec (push_rel d env) (rea,reca) in
- mkProd (name, c, d)
-
- | (name,Some b,c as d)::rea, reca ->
- mkLetIn (name,b, c,crec (push_rel d env) (rea,reca))
- | [],[] -> mkExistential isevars env (dummy_loc, InternalHole)
- | _ -> anomaly "rec_branch_scheme"
- in
- crec env (List.rev cstr.cs_args,recargs)
-
-let branch_scheme env isevars isrec indf =
- let (ind,params) = dest_ind_family indf in
- let (mib,mip) = Inductive.lookup_mind_specif env ind in
- let cstrs = get_constructors env indf in
- if isrec then
- array_map2
- (rec_branch_scheme env isevars ind)
- (dest_subterms mip.mind_recargs) cstrs
- else
- Array.map (norec_branch_scheme env isevars) cstrs
-
-(******************************************************)
-(* B) Building ML like case expressions without types *)
-
-let concl_n env sigma =
- let rec decrec m c = if m = 0 then (nf_evar sigma c) else
- match kind_of_term (whd_betadeltaiota env sigma c) with
- | Prod (n,_,c_0) -> decrec (m-1) c_0
- | _ -> failwith "Typing.concl_n"
- in
- decrec
-
-let count_rec_arg j =
- let rec crec i = function
- | [] -> i
- | ra::l ->
- (match dest_recarg ra with
- Mrec k -> crec (if k=j then (i+1) else i) l
- | _ -> crec i l)
- in
- crec 0
-
-(* if arity of mispec is (p_bar:P_bar)(a_bar:A_bar)s where p_bar are the
- * K parameters. Then then build_notdep builds the predicate
- * [a_bar:A'_bar](lift k pred)
- * where A'_bar = A_bar[p_bar <- globargs] *)
-
-let build_dep_pred env sigma indf pred =
- let arsign,_ = get_arity env indf in
- let psign = (Anonymous,None,build_dependent_inductive env indf)::arsign in
- let nar = List.length psign in
- it_mkLambda_or_LetIn_name env (lift nar pred) psign
-
-type ml_case_error =
- | MlCaseAbsurd
- | MlCaseDependent
-
-exception NotInferable of ml_case_error
-
-
-let pred_case_ml env sigma isrec (IndType (indf,realargs)) (i,ft) =
- let pred =
- let (ind,params) = dest_ind_family indf in
- let (mib,mip) = Inductive.lookup_mind_specif env ind in
- let recargs = dest_subterms mip.mind_recargs in
- if Array.length recargs = 0 then raise (NotInferable MlCaseAbsurd);
- let recargi = recargs.(i) in
- let j = snd ind in (* index of inductive *)
- let nbrec = if isrec then count_rec_arg j recargi else 0 in
- let nb_arg = List.length (recargs.(i)) + nbrec in
- let pred = Evarutil.refresh_universes (concl_n env sigma nb_arg ft) in
- if noccur_between 1 nb_arg pred then
- lift (-nb_arg) pred
- else
- raise (NotInferable MlCaseDependent)
- in
- build_dep_pred env sigma indf pred
+module type S = sig
+ val compile_cases :
+ loc ->
+ (type_constraint -> env -> rawconstr -> unsafe_judgment) *
+ Evd.evar_defs ref ->
+ type_constraint ->
+ env ->
+ rawconstr option *
+ (rawconstr * (name * (loc * inductive * name list) option)) list *
+ (loc * identifier list * cases_pattern list * rawconstr) list ->
+ unsafe_judgment
+end
(************************************************************************)
(* Pattern-matching compilation (Cases) *)
@@ -259,8 +174,8 @@ type tomatch_stack = tomatch_status list
(* The type [predicate_signature] types the terms to match and the rhs:
- - [PrLetIn (names,dep,pred)] types a pushed term ([Pushed]),
- if dep<>Anonymous, the term is dependent, let n=|names|, if
+ - [PrLetIn (names,dep,pred)] types a pushed term ([Pushed]),
+ if dep<>Anonymous, the term is dependent, let n=|names|, if
n<>0 then the type of the pushed term is necessarily an
inductive with n real arguments. Otherwise, it may be
non inductive, or inductive without real arguments, or inductive
@@ -376,7 +291,7 @@ let push_history_pattern n current cont =
*)
type pattern_matching_problem =
{ env : env;
- isevars : evar_defs;
+ isevars : Evd.evar_defs ref;
pred : predicate_signature option;
tomatch : tomatch_stack;
history : pattern_continuation;
@@ -388,64 +303,67 @@ type pattern_matching_problem =
* A few functions to infer the inductive type from the patterns instead of *
* checking that the patterns correspond to the ind. type of the *
* destructurated object. Allows type inference of examples like *
- * [n]Cases n of O => true | _ => false end *
+ * match n with O => true | _ => false end *
+ * match x in I with C => true | _ => false end *
*--------------------------------------------------------------------------*)
(* Computing the inductive type from the matrix of patterns *)
+(* We use the "in I" clause to coerce the terms to match and otherwise
+ use the constructor to know in which type is the matching problem
+
+ Note that insertion of coercions inside nested patterns is done
+ each time the matrix is expanded *)
+
let rec find_row_ind = function
[] -> None
| PatVar _ :: l -> find_row_ind l
| PatCstr(loc,c,_,_) :: _ -> Some (loc,c)
-exception NotCoercible
-
-let inh_coerce_to_ind isevars env tmloc ty tyi =
- let (mib,mip) = Inductive.lookup_mind_specif env tyi in
- let (ntys,_) = splay_prod env (evars_of isevars) mip.mind_nf_arity in
+let inductive_template isevars env tmloc ind =
+ let (mib,mip) = Inductive.lookup_mind_specif env ind in
+ let (ntys,_) = splay_prod env (Evd.evars_of !isevars) mip.mind_nf_arity in
let hole_source = match tmloc with
- | Some loc -> fun i -> (loc, TomatchTypeParameter (tyi,i))
- | None -> fun _ -> (dummy_loc, InternalHole) in
+ | Some loc -> fun i -> (loc, Evd.TomatchTypeParameter (ind,i))
+ | None -> fun _ -> (dummy_loc, Evd.InternalHole) in
let (evarl,_) =
List.fold_right
(fun (na,ty) (evl,n) ->
- (new_isevar isevars env (hole_source n) (substl evl ty))::evl,n+1)
+ (e_new_evar isevars env ~src:(hole_source n) (substl evl ty))::evl,n+1)
ntys ([],1) in
- let expected_typ = applist (mkInd tyi,evarl) in
+ applist (mkInd ind,List.rev evarl)
+
+let inh_coerce_to_ind isevars env ty tyi =
+ let expected_typ = inductive_template isevars env None tyi in
(* devrait être indifférent d'exiger leq ou pas puisque pour
un inductif cela doit être égal *)
- if the_conv_x_leq env isevars expected_typ ty then ty
- else raise NotCoercible
-
-(* We do the unification for all the rows that contain
- * constructor patterns. This is what we do at the higher level of patterns.
- * For nested patterns, we do this unif when we ``expand'' the matrix, and we
- * use the function above.
- *)
-
-let unify_tomatch_with_patterns isevars env tmloc typ = function
- | Some (cloc,(cstr,_ as c)) ->
- (let tyi = inductive_of_constructor c in
- try
- let indtyp = inh_coerce_to_ind isevars env tmloc typ tyi in
- IsInd (typ,find_rectype env (evars_of isevars) typ)
- with NotCoercible ->
- (* 2 cases : Not the right inductive or not an inductive at all *)
- try
- IsInd (typ,find_rectype env (evars_of isevars) typ)
- (* will try to coerce later in check_and_adjust_constructor.. *)
- with Not_found ->
- NotInd (None,typ))
- (* error will be detected in check_all_variables *)
- | None ->
- try IsInd (typ,find_rectype env (evars_of isevars) typ)
- with Not_found -> NotInd (None,typ)
-
-let coerce_row typing_fun isevars env cstropt tomatch =
- let j = typing_fun empty_tycon env tomatch in
- let typ = body_of_type j.uj_type in
- let loc = loc_of_rawconstr tomatch in
- let t = unify_tomatch_with_patterns isevars env (Some loc) typ cstropt in
+ let _ = e_cumul env isevars expected_typ ty in ()
+
+let unify_tomatch_with_patterns isevars env typ tm =
+ match find_row_ind tm with
+ | None -> NotInd (None,typ)
+ | Some (_,(ind,_)) ->
+ inh_coerce_to_ind isevars env typ ind;
+ try IsInd (typ,find_rectype env (Evd.evars_of !isevars) typ)
+ with Not_found -> NotInd (None,typ)
+
+let find_tomatch_tycon isevars env loc = function
+ (* Try first if some 'in I ...' is present and can be used as a constraint *)
+ | Some (_,ind,_),_
+ (* Otherwise try to get constraints from (the 1st) constructor in clauses *)
+ | None, Some (_,(ind,_)) ->
+ mk_tycon (inductive_template isevars env loc ind)
+ | None, None ->
+ empty_tycon
+
+let coerce_row typing_fun isevars env cstropt (tomatch,(_,indopt)) =
+ let loc = Some (loc_of_rawconstr tomatch) in
+ let tycon = find_tomatch_tycon isevars env loc (indopt,cstropt) in
+ let j = typing_fun tycon env tomatch in
+ let typ = nf_evar (Evd.evars_of !isevars) j.uj_type in
+ let t =
+ try IsInd (typ,find_rectype env (Evd.evars_of !isevars) typ)
+ with Not_found -> NotInd (None,typ) in
(j.uj_val,t)
let coerce_to_indtype typing_fun isevars env matx tomatchl =
@@ -458,11 +376,53 @@ let coerce_to_indtype typing_fun isevars env matx tomatchl =
(************************************************************************)
(* Utils *)
+let mkExistential env ?(src=(dummy_loc,Evd.InternalHole)) isevars =
+ e_new_evar isevars env ~src:src (new_Type ())
+
+let evd_comb2 f isevars x y =
+ let (evd',y) = f !isevars x y in
+ isevars := evd';
+ y
+
+
+module Cases_F(Coercion : Coercion.S) : S = struct
+
+let adjust_tomatch_to_pattern pb ((current,typ),deps) =
+ (* Ideally, we could find a common inductive type to which both the
+ term to match and the patterns coerce *)
+ (* In practice, we coerce the term to match if it is not already an
+ inductive type and it is not dependent; moreover, we use only
+ the first pattern type and forget about the others *)
+ let typ = match typ with IsInd (t,_) -> t | NotInd (_,t) -> t in
+ let typ =
+ try IsInd (typ,find_rectype pb.env (Evd.evars_of !(pb.isevars)) typ)
+ with Not_found -> NotInd (None,typ) in
+ let tomatch = ((current,typ),deps) in
+ match typ with
+ | NotInd (None,typ) ->
+ let tm1 = List.map (fun eqn -> List.hd eqn.patterns) pb.mat in
+ (match find_row_ind tm1 with
+ | None -> tomatch
+ | Some (_,(ind,_)) ->
+ let indt = inductive_template pb.isevars pb.env None ind in
+ let current =
+ if deps = [] & isEvar typ then
+ (* Don't insert coercions if dependent; only solve evars *)
+ let _ = e_cumul pb.env pb.isevars indt typ in
+ current
+ else
+ (evd_comb2 (Coercion.inh_conv_coerce_to dummy_loc pb.env)
+ pb.isevars (make_judge current typ) (mk_tycon_type indt)).uj_val in
+ let sigma = Evd.evars_of !(pb.isevars) in
+ let typ = IsInd (indt,find_rectype pb.env sigma indt) in
+ ((current,typ),deps))
+ | _ -> tomatch
+
(* extract some ind from [t], possibly coercing from constructors in [tm] *)
let to_mutind env isevars tm c t =
- match c with
- | Some body -> NotInd (c,t)
- | None -> unify_tomatch_with_patterns isevars env None t (find_row_ind tm)
+(* match c with
+ | Some body -> *) NotInd (c,t)
+(* | None -> unify_tomatch_with_patterns isevars env t tm*)
let type_of_tomatch = function
| IsInd (t,_) -> t
@@ -558,7 +518,8 @@ let check_and_adjust_constructor ind cstrs = function
let args' = adjust_local_defs loc (args, List.rev ci.cs_args)
in PatCstr (loc, cstr, args', alias)
with NotAdjustable ->
- error_wrong_numarg_constructor_loc loc cstr nb_args_constr
+ error_wrong_numarg_constructor_loc loc (Global.env())
+ cstr nb_args_constr
else
(* Try to insert a coercion *)
try
@@ -715,11 +676,11 @@ let lift_tomatch_stack n = liftn_tomatch_stack n 1
(* Some heuristics to get names for variables pushed in pb environment *)
(* Typical requirement:
- [Cases y of (S (S x)) => x | x => x end] should be compiled into
- [Cases y of O => y | (S n) => Cases n of O => y | (S x) => x end end]
+ [match y with (S (S x)) => x | x => x end] should be compiled into
+ [match y with O => y | (S n) => match n with O => y | (S x) => x end end]
- and [Cases y of (S (S n)) => n | n => n end] into
- [Cases y of O => y | (S n0) => Cases n0 of O => y | (S n) => n end end]
+ and [match y with (S (S n)) => n | n => n end] into
+ [match y with O => y | (S n0) => match n0 with O => y | (S n) => n end end]
i.e. user names should be preserved and created names should not
interfere with user names *)
@@ -782,7 +743,6 @@ let build_aliases_context env sigma names allpats pats =
let newallpats =
List.map2 (fun l1 l2 -> List.hd l2::l1) newallpats oldallpats in
let oldallpats = List.map List.tl oldallpats in
- let u = Retyping.get_type_of env sigma deppat in
let decl = (na,Some deppat,t) in
let a = (deppat,nondeppat,d,t) in
insert (push_rel decl env) (decl::sign1) ((na,a)::sign2) (n+1)
@@ -869,10 +829,10 @@ the following n+1 equations:
Some hints:
-- Clearly, if xij occurs in Ti, then, a "Cases z of (Ci xi1..xipi) => ..."
+- Clearly, if xij occurs in Ti, then, a "match z with (Ci xi1..xipi) => ..."
should be inserted somewhere in Ti.
-- If T is undefined, an easy solution is to insert a "Cases z of (Ci
+- If T is undefined, an easy solution is to insert a "match z with (Ci
xi1..xipi) => ..." in front of each Ti
- Otherwise, T1..Tn and T must be step by step unified, if some of them
@@ -902,7 +862,7 @@ let shift_operator k = function OpLambda _ | OpProd _ -> k+1 | _ -> k
let reloc_operator (k,n) = function OpRel p when p > k ->
let rec unify_clauses k pv =
- let pv'= Array.map (fun (n,sign,_,p) -> n,splay_constr (whd_betaiotaevar (push_rels (List.rev sign) env) (evars_of isevars)) p) pv in
+ let pv'= Array.map (fun (n,sign,_,p) -> n,splay_constr (whd_betaiotaevar (push_rels (List.rev sign) env) (Evd.evars_of isevars)) p) pv in
let n1,op1 = let (n1,(op1,args1)) = pv'.(0) in n1,op1 in
if Array.for_all (fun (ni,(opi,_)) -> eq_operator_lift k (n1,ni) (op1,opi)) pv'
then
@@ -918,28 +878,30 @@ let abstract_conclusion typ cs =
lam_it p sign
let infer_predicate loc env isevars typs cstrs indf =
- let (mis,_) = dest_ind_family indf in
(* Il faudra substituer les isevars a un certain moment *)
if Array.length cstrs = 0 then (* "TODO4-3" *)
error "Inference of annotation for empty inductive types not implemented"
else
(* Empiric normalization: p may depend in a irrelevant way on args of the*)
- (* cstr as in [c:{_:Alpha & Beta}] Cases c of (existS a b)=>(a,b) end *)
+ (* cstr as in [c:{_:Alpha & Beta}] match c with (existS a b)=>(a,b) end *)
let typs =
- Array.map (local_strong (whd_betaevar empty_env (evars_of isevars))) typs
+ Array.map (local_strong (whd_betaevar empty_env (Evd.evars_of !isevars))) typs
in
let eqns = array_map2 prepare_unif_pb typs cstrs in
(* First strategy: no dependencies at all *)
-(* let (cclargs,_,typn) = eqns.(mis_nconstr mis -1) in*)
+(*
+ let (mis,_) = dest_ind_family indf in
+ let (cclargs,_,typn) = eqns.(mis_nconstr mis -1) in
+*)
let (sign,_) = get_arity env indf in
let mtyp =
if array_exists is_Type typs then
(* Heuristic to avoid comparison between non-variables algebric univs*)
new_Type ()
else
- mkExistential isevars env (loc, CasesType)
+ mkExistential env ~src:(loc, Evd.CasesType) isevars
in
- if array_for_all (fun (_,_,typ) -> the_conv_x_leq env isevars typ mtyp) eqns
+ if array_for_all (fun (_,_,typ) -> e_cumul env isevars typ mtyp) eqns
then
(* Non dependent case -> turn it into a (dummy) dependent one *)
let sign = (Anonymous,None,build_dependent_inductive env indf)::sign in
@@ -980,7 +942,7 @@ let rec map_predicate f k = function
let rec noccurn_predicate k = function
| PrCcl ccl -> noccurn k ccl
| PrProd pred -> noccurn_predicate (k+1) pred
- | PrLetIn ((names,dep as tm),pred) ->
+ | PrLetIn ((names,dep),pred) ->
let k' = List.length names + (if dep<>Anonymous then 1 else 0) in
noccurn_predicate (k+k') pred
@@ -1066,8 +1028,8 @@ let abstract_predicate env sigma indf cur tms = function
args or not, we lift it to make room for [sign] *)
(* Even if not intrinsically dep, we move the predicate into a dep one *)
let sign,k =
- if names = [] & n <> 1 then
- (* Real args were not considered *)
+ if names = [] & n <> 1 then
+ (* Real args were not considered *)
(if dep<>Anonymous then
((let (_,c,t) = List.hd sign in (dep,c,t)::List.tl sign),n-1)
else
@@ -1106,7 +1068,7 @@ let expand_arg n alreadydep (na,t) deps (k,pred) =
(*****************************************************************************)
(* pred = [X:=realargs;x:=c]P types the following problem: *)
(* *)
-(* Gamma |- Cases Pushed(c:I(realargs)) rest of...end: pred *)
+(* Gamma |- match Pushed(c:I(realargs)) rest with...end: pred *)
(* *)
(* where the branch with constructor Ci:(x1:T1)...(xn:Tn)->I(realargsi) *)
(* is considered. Assume each Ti is some Ii(argsi). *)
@@ -1114,7 +1076,7 @@ let expand_arg n alreadydep (na,t) deps (k,pred) =
(* *)
(* pred' = [X1:=rargs1,x1:=x1']...[Xn:=rargsn,xn:=xn'](P[X:=realargsi;x:=e]) *)
(* *)
-(* s.t Gamma,x1'..xn' |- Cases Pushed(x1')..Pushed(xn') rest of...end: pred' *)
+(* s.t Gamma,x1'..xn' |- match Pushed(x1')..Pushed(xn') rest with..end :pred'*)
(* *)
(*****************************************************************************)
let specialize_predicate tomatchs deps cs = function
@@ -1141,7 +1103,7 @@ let find_predicate loc env isevars p typs cstrs current
(IndType (indf,realargs)) tms =
let (dep,pred) =
match p with
- | Some p -> abstract_predicate env (evars_of isevars) indf current tms p
+ | Some p -> abstract_predicate env (Evd.evars_of !isevars) indf current tms p
| None -> infer_predicate loc env isevars typs cstrs indf in
let typ = whd_beta (applist (pred, realargs)) in
if dep then
@@ -1191,7 +1153,7 @@ let group_equations pb mind current cstrs mat =
let rest = {rest with tag = lower_pattern_status rest.tag} in
brs.(i-1) <- (args, rest) :: brs.(i-1)
done
- | PatCstr (loc,((_,i) as cstr),args,_) as pat ->
+ | PatCstr (loc,((_,i)),args,_) ->
(* This is a regular clause *)
only_default := false;
brs.(i-1) <- (args,rest) :: brs.(i-1)) mat () in
@@ -1240,8 +1202,6 @@ let build_branch current deps pb eqns const_info =
else
DepAlias
in
- let partialci =
- applist (mkConstruct const_info.cs_cstr, const_info.cs_params) in
let history =
push_history_pattern const_info.cs_nargs
(AliasConstructor const_info.cs_cstr)
@@ -1324,10 +1284,8 @@ let rec compile pb =
| (Abstract d)::rest -> compile_generalization pb d rest
| [] -> build_leaf pb
-and match_current pb ((current,typ as ct),deps) =
- let tm1 = List.map (fun eqn -> List.hd eqn.patterns) pb.mat in
- let (_,c,t) = mkDeclTomatch Anonymous typ in
- let typ = to_mutind pb.env pb.isevars tm1 c t in
+and match_current pb tomatch =
+ let ((current,typ as ct),deps) = adjust_tomatch_to_pattern pb tomatch in
match typ with
| NotInd (_,typ) ->
check_all_variables typ pb.mat;
@@ -1336,10 +1294,10 @@ and match_current pb ((current,typ as ct),deps) =
let mind,_ = dest_ind_family indf in
let cstrs = get_constructors pb.env indf in
let eqns,onlydflt = group_equations pb mind current cstrs pb.mat in
- if (cstrs <> [||] or not (initial_history pb.history)) & onlydflt then
+ if (Array.length cstrs <> 0 or pb.mat <> []) & onlydflt then
compile (shift_problem ct pb)
else
- let constraints = Array.map (solve_constraints indt) cstrs in
+ let _constraints = Array.map (solve_constraints indt) cstrs in
(* We generalize over terms depending on current term to match *)
let pb = generalize_problem pb current deps in
@@ -1381,7 +1339,7 @@ and compile_generalization pb d rest =
and compile_alias pb (deppat,nondeppat,d,t) rest =
let history = simplify_history pb.history in
let sign, newenv, mat =
- insert_aliases pb.env (evars_of pb.isevars) (deppat,nondeppat,d,t) pb.mat in
+ insert_aliases pb.env (Evd.evars_of !(pb.isevars)) (deppat,nondeppat,d,t) pb.mat in
let n = List.length sign in
(* We had Gamma1; x:current; Gamma2 |- tomatch(x) and we rebind x to get *)
@@ -1436,7 +1394,7 @@ let rename_env subst env =
let is_dependent_indtype = function
| NotInd _ -> false
- | IsInd (_, IndType(_,realargs)) -> List.length realargs <> 0
+ | IsInd (_, IndType(_,realargs)) -> realargs <> []
let prepare_initial_alias_eqn isdep tomatchl eqn =
let (subst, pats) =
@@ -1444,7 +1402,7 @@ let prepare_initial_alias_eqn isdep tomatchl eqn =
(fun pat (tm,tmtyp) (subst, stripped_pats) ->
match alias_of_pat pat with
| Anonymous -> (subst, pat::stripped_pats)
- | Name idpat as na ->
+ | Name idpat ->
match kind_of_term tm with
| Rel n when not (is_dependent_indtype tmtyp) & not isdep
-> (n, idpat)::subst, (unalias_pat pat::stripped_pats)
@@ -1531,7 +1489,7 @@ let extract_predicate_conclusion isdep tomatchl pred =
if n=0 then (l,p) else
match kind_of_term p with
| Lambda (na,_,c) -> decomp_lam_force (n-1) (na::l) c
- | _ -> (* eta-expansion *)
+ | _ -> (* eta-expansion *)
let na = Name (id_of_string "x") in
decomp_lam_force (n-1) (na::l) (applist (lift 1 p, [mkRel 1])) in
let rec buildrec allnames p = function
@@ -1543,7 +1501,7 @@ let extract_predicate_conclusion isdep tomatchl pred =
(* adjust to a sign containing the NotInd's *)
if isdep then lift 1 p else p in
let names = if isdep then [Anonymous] else [] in
- buildrec (names::allnames) p ltm
+ buildrec (names::allnames) p ltm
| Some n ->
let n = if isdep then n+1 else n in
let names,p = decomp_lam_force n [] p in
@@ -1590,30 +1548,32 @@ let set_arity_signature dep n arsign tomatchl pred x =
decomp_block [] pred (tomatchl,arsign)
let prepare_predicate_from_tycon loc dep env isevars tomatchs c =
- let cook (n, l, signs) = function
+ let cook (n, l, env, signs) = function
| c,IsInd (_,IndType(indf,realargs)) ->
let indf' = lift_inductive_family n indf in
- let arsign = make_arity_signature env dep indf' in
+ let sign = make_arity_signature env dep indf' in
let p = List.length realargs in
if dep then
- (n + p + 1, c::(List.rev realargs)@l, arsign::signs)
+ (n + p + 1, c::(List.rev realargs)@l, push_rels sign env,sign::signs)
else
- (n + p, (List.rev realargs)@l, arsign::signs)
+ (n + p, (List.rev realargs)@l, push_rels sign env,sign::signs)
| c,NotInd _ ->
- (n, l, []::signs) in
- let n, allargs, signs = List.fold_left cook (0, [], []) tomatchs in
- let env = List.fold_right push_rels signs env in
+ (n, l, env, []::signs) in
+ let n, allargs, env, signs = List.fold_left cook (0, [], env, []) tomatchs in
+ let names = List.rev (List.map (List.map pi1) signs) in
let allargs =
- List.map (fun c -> lift n (nf_betadeltaiota env (evars_of isevars) c)) allargs in
+ List.map (fun c -> lift n (nf_betadeltaiota env (Evd.evars_of !isevars) c)) allargs in
let rec build_skeleton env c =
(* Don't put into normal form, it has effects on the synthesis of evars *)
(* let c = whd_betadeltaiota env (evars_of isevars) c in *)
(* We turn all subterms possibly dependent into an evar with maximum ctxt*)
if isEvar c or List.exists (eq_constr c) allargs then
- mkExistential isevars env (loc, CasesType)
+ e_new_evar isevars env ~src:(loc, Evd.CasesType)
+ (Retyping.get_type_of env (Evd.evars_of !isevars) c)
else
- map_constr_with_full_binders push_rel build_skeleton env c in
- List.rev (List.map (List.map pi1) signs), build_skeleton env (lift n c)
+ map_constr_with_full_binders push_rel build_skeleton env c
+ in
+ names, build_skeleton env (lift n c)
(* Here, [pred] is assumed to be in the context built from all *)
(* realargs and terms to match *)
@@ -1629,7 +1589,7 @@ let build_initial_predicate isdep allnames pred =
if dependent (mkRel (nar-n')) pred then pred, 1, 1
else liftn (-1) (nar-n') pred, 0, 1
else pred, 0, 0 in
- let na =
+ let na =
if p=1 then
let na = List.hd names in
if na = Anonymous then
@@ -1637,11 +1597,11 @@ let build_initial_predicate isdep allnames pred =
Name (id_of_string "x") (*Hum*)
else na
else Anonymous in
- PrLetIn ((names',na), buildrec (n'+user_p) pred lnames)
+ PrLetIn ((names',na), buildrec (n'+user_p) pred lnames)
in buildrec 0 pred allnames
let extract_arity_signature env0 tomatchl tmsign =
- let get_one_sign n tm {contents = (na,t)} =
+ let get_one_sign n tm (na,t) =
match tm with
| NotInd (bo,typ) ->
(match t with
@@ -1659,9 +1619,10 @@ let extract_arity_signature env0 tomatchl tmsign =
let nparams = List.length params in
if ind <> ind' then
user_err_loc (loc,"",str "Wrong inductive type");
- if List.length nal <> nparams + nrealargs then
- user_err_loc (loc,"",
- str "Wrong number of arguments for inductive type");
+ let nindargs = nparams + nrealargs in
+ (* Normally done at interning time *)
+ if List.length nal <> nindargs then
+ error_wrong_numarg_inductive_loc loc env0 ind' nindargs;
let parnal,realnal = list_chop nparams nal in
if List.exists ((<>) Anonymous) parnal then
user_err_loc (loc,"",
@@ -1679,101 +1640,74 @@ let extract_arity_signature env0 tomatchl tmsign =
| _ -> assert false
in List.rev (buildrec 0 (tomatchl,tmsign))
+let inh_conv_coerce_to_tycon loc env isevars j tycon =
+ match tycon with
+ | Some p ->
+ let (evd',j) = Coercion.inh_conv_coerce_to loc env !isevars j p in
+ isevars := evd';
+ j
+ | None -> j
+
+
(* Builds the predicate. If the predicate is dependent, its context is
* made of 1+nrealargs assumptions for each matched term in an inductive
* type and 1 assumption for each term not _syntactically_ in an
* inductive type.
- * V7 case: determines whether the multiple case is dependent or not
- * - if its arity is made of nrealargs assumptions for each matched
- * term in an inductive type and nothing for terms not _syntactically_
- * in an inductive type, then it is non dependent
- * - if its arity is made of 1+nrealargs assumptions for each matched
- * term in an inductive type and nothing for terms not _syntactically_
- * in an inductive type, then it is dependent and needs an adjustement
- * to fulfill the criterion above that terms not in an inductive type
- * counts for 1 in the dependent case
-
- * V8 case: each matched terms are independently considered dependent
- * or not
+ * Each matched terms are independently considered dependent or not.
- * A type constraint but no annotation case: it is assumed non dependent
+ * A type constraint but no annotation case: it is assumed non dependent.
*)
let prepare_predicate loc typing_fun isevars env tomatchs sign tycon = function
- (* No type annotation at all *)
- | (None,{contents = None}) ->
+ (* No type annotation *)
+ | None ->
(match tycon with
- | None -> None
- | Some t ->
- let names,pred = prepare_predicate_from_tycon loc false env isevars tomatchs t in
- Some (build_initial_predicate false names pred))
-
- (* v8 style type annotation *)
- | (None,{contents = Some rtntyp}) ->
-
+ | Some (None, t) ->
+ let names,pred =
+ prepare_predicate_from_tycon loc false env isevars tomatchs t
+ in Some (build_initial_predicate false names pred)
+ | _ -> None)
+
+ (* Some type annotation *)
+ | Some rtntyp ->
(* We extract the signature of the arity *)
- let arsigns = extract_arity_signature env tomatchs sign in
- let env = List.fold_right push_rels arsigns env in
- let allnames = List.rev (List.map (List.map pi1) arsigns) in
- let predccl = (typing_fun (mk_tycon (new_Type ())) env rtntyp).uj_val in
- Some (build_initial_predicate true allnames predccl)
-
- (* v7 style type annotation; set the v8 annotation by side effect *)
- | (Some pred,x) ->
- let loc = loc_of_rawconstr pred in
- let dep, n, predj =
- let isevars_copy = evars_of isevars in
- (* We first assume the predicate is non dependent *)
- let ndep_arity = build_expected_arity env isevars false tomatchs in
- try
- false, nb_prod ndep_arity, typing_fun (mk_tycon ndep_arity) env pred
- with PretypeError _ | TypeError _ |
- Stdpp.Exc_located (_,(PretypeError _ | TypeError _)) ->
- evars_reset_evd isevars_copy isevars;
- (* We then assume the predicate is dependent *)
- let dep_arity = build_expected_arity env isevars true tomatchs in
- try
- true, nb_prod dep_arity, typing_fun (mk_tycon dep_arity) env pred
- with PretypeError _ | TypeError _ |
- Stdpp.Exc_located (_,(PretypeError _ | TypeError _)) ->
- evars_reset_evd isevars_copy isevars;
- (* Otherwise we attempt to type it without constraints, possibly *)
- (* failing with an error message; it may also be well-typed *)
- (* but fails to satisfy arity constraints in case_dependent *)
- let predj = typing_fun empty_tycon env pred in
- error_wrong_predicate_arity_loc
- loc env predj.uj_val ndep_arity dep_arity
+ let arsign = extract_arity_signature env tomatchs sign in
+ let env = List.fold_right push_rels arsign env in
+ let allnames = List.rev (List.map (List.map pi1) arsign) in
+ let predcclj = typing_fun (mk_tycon (new_Type ())) env rtntyp in
+ let _ =
+ option_app (fun tycon ->
+ isevars := Coercion.inh_conv_coerces_to loc env !isevars predcclj.uj_val tycon)
+ tycon
in
- let ln,predccl= extract_predicate_conclusion dep tomatchs predj.uj_val in
- set_arity_signature dep n sign tomatchs pred x;
- Some (build_initial_predicate dep ln predccl)
-
+ let predccl = (j_nf_isevar !isevars predcclj).uj_val in
+ Some (build_initial_predicate true allnames predccl)
(**************************************************************************)
(* Main entry of the matching compilation *)
-
-let compile_cases loc (typing_fun,isevars) tycon env (predopt, tomatchl, eqns)=
-
+
+let compile_cases loc (typing_fun, isevars) (tycon : Evarutil.type_constraint) env (predopt, tomatchl, eqns)=
+
(* We build the matrix of patterns and right-hand-side *)
let matx = matx_of_eqns env tomatchl eqns in
-
+
(* We build the vector of terms to match consistently with the *)
(* constructors found in patterns *)
- let rawtms, tmsign = List.split tomatchl in
- let tomatchs = coerce_to_indtype typing_fun isevars env matx rawtms in
-
+ let tomatchs = coerce_to_indtype typing_fun isevars env matx tomatchl in
+
(* We build the elimination predicate if any and check its consistency *)
(* with the type of arguments to match *)
+ let tmsign = List.map snd tomatchl in
let pred = prepare_predicate loc typing_fun isevars env tomatchs tmsign tycon predopt in
-
+
(* We deal with initial aliases *)
let matx = prepare_initial_aliases (known_dependent pred) tomatchs matx in
-
+
(* We push the initial terms to match and push their alias to rhs' envs *)
(* names of aliases will be recovered from patterns (hence Anonymous here) *)
let initial_pushed = List.map (fun tm -> Pushed (tm,[])) tomatchs in
-
+
let pb =
{ env = env;
isevars = isevars;
@@ -1783,12 +1717,10 @@ let compile_cases loc (typing_fun,isevars) tycon env (predopt, tomatchl, eqns)=
mat = matx;
caseloc = loc;
typing_function = typing_fun } in
-
+
let _, j = compile pb in
-
- (* We check for unused patterns *)
- List.iter (check_unused_pattern env) matx;
+ (* We check for unused patterns *)
+ List.iter (check_unused_pattern env) matx;
+ inh_conv_coerce_to_tycon loc env isevars j tycon
+end
- match tycon with
- | Some p -> Coercion.inh_conv_coerce_to loc env isevars j p
- | None -> j
diff --git a/pretyping/cases.mli b/pretyping/cases.mli
index 1d2f9025..5919c42a 100644
--- a/pretyping/cases.mli
+++ b/pretyping/cases.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: cases.mli,v 1.22.2.2 2004/07/16 19:30:43 herbelin Exp $ i*)
+(*i $Id: cases.mli 8654 2006-03-22 15:36:58Z msozeau $ i*)
(*i*)
open Util
@@ -23,6 +23,7 @@ type pattern_matching_error =
| BadPattern of constructor * constr
| BadConstructor of constructor * inductive
| WrongNumargConstructor of constructor * int
+ | WrongNumargInductive of inductive * int
| WrongPredicateArity of constr * constr * constr
| NeedsInversion of constr * constr
| UnusedClause of cases_pattern list
@@ -31,26 +32,23 @@ type pattern_matching_error =
exception PatternMatchingError of env * pattern_matching_error
-(*s Used for old cases in pretyping *)
+val error_wrong_numarg_constructor_loc : loc -> env -> constructor -> int -> 'a
-val branch_scheme :
- env -> evar_defs -> bool -> inductive_family -> constr array
-
-type ml_case_error =
- | MlCaseAbsurd
- | MlCaseDependent
-
-exception NotInferable of ml_case_error
-
-val pred_case_ml : (* raises [NotInferable] if not inferable *)
- env -> evar_map -> bool -> inductive_type -> int * types -> constr
+val error_wrong_numarg_inductive_loc : loc -> env -> inductive -> int -> 'a
(*s Compilation of pattern-matching. *)
-val compile_cases :
- loc -> (type_constraint -> env -> rawconstr -> unsafe_judgment)
- * evar_defs -> type_constraint -> env ->
- (rawconstr option * rawconstr option ref) *
- (rawconstr * (name * (loc * inductive * name list) option) ref) list *
- (loc * identifier list * cases_pattern list * rawconstr) list ->
+module type S = sig
+ val compile_cases :
+ loc ->
+ (type_constraint -> env -> rawconstr -> unsafe_judgment) *
+ evar_defs ref ->
+ type_constraint ->
+ env ->
+ rawconstr option *
+ (rawconstr * (name * (loc * inductive * name list) option)) list *
+ (loc * identifier list * cases_pattern list * rawconstr) list ->
unsafe_judgment
+end
+
+module Cases_F(C : Coercion.S) : S
diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml
index 88f59ded..33166ba8 100644
--- a/pretyping/cbv.ml
+++ b/pretyping/cbv.ml
@@ -6,16 +6,16 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: cbv.ml,v 1.12.2.1 2004/07/16 19:30:44 herbelin Exp $ *)
+(* $Id: cbv.ml 7639 2005-12-02 10:01:15Z gregoire $ *)
open Util
open Pp
open Term
open Names
open Environ
-open Instantiate
open Univ
open Evd
+open Conv_oracle
open Closure
open Esubst
@@ -92,7 +92,7 @@ let contract_cofixp env (i,(_,_,bds as bodies)) =
subst_bodies_from_i 0 env, bds.(i)
let make_constr_ref n = function
- | FarRelKey p -> mkRel (n+p)
+ | RelKey p -> mkRel (n+p)
| VarKey id -> mkVar id
| ConstKey cst -> mkConst cst
@@ -128,7 +128,7 @@ let stack_app appl stack =
open RedFlags
let red_set_ref flags = function
- | FarRelKey _ -> red_set flags fDELTA
+ | RelKey _ -> red_set flags fDELTA
| VarKey id -> red_set flags (fVAR id)
| ConstKey sp -> red_set flags (fCONST sp)
@@ -186,7 +186,7 @@ let rec norm_head info env t stack =
let nargs = Array.map (cbv_stack_term info TOP env) args in
norm_head info env head (stack_app (Array.to_list nargs) stack)
| Case (ci,p,c,v) -> norm_head info env c (CASE(p,v,ci,env,stack))
- | Cast (ct,_) -> norm_head info env ct stack
+ | Cast (ct,_,_) -> norm_head info env ct stack
(* constants, axioms
* the first pattern is CRUCIAL, n=0 happens very often:
@@ -196,7 +196,7 @@ let rec norm_head info env t stack =
| Inl (0,v) -> strip_appl v stack
| Inl (n,v) -> strip_appl (shift_value n v) stack
| Inr (n,None) -> (VAL(0, mkRel n), stack)
- | Inr (n,Some p) -> norm_head_ref (n-p) info env stack (FarRelKey p))
+ | Inr (n,Some p) -> norm_head_ref (n-p) info env stack (RelKey p))
| Var id -> norm_head_ref 0 info env stack (VarKey id)
diff --git a/pretyping/cbv.mli b/pretyping/cbv.mli
index bf8e03b3..dfdf12dd 100644
--- a/pretyping/cbv.mli
+++ b/pretyping/cbv.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: cbv.mli,v 1.6.14.1 2004/07/16 19:30:44 herbelin Exp $ i*)
+(*i $Id: cbv.mli 5920 2004-07-16 20:01:26Z herbelin $ i*)
(*i*)
open Names
diff --git a/pretyping/classops.ml b/pretyping/classops.ml
index 2d8fb951..b6cce031 100755..100644
--- a/pretyping/classops.ml
+++ b/pretyping/classops.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: classops.ml,v 1.48.2.1 2004/07/16 19:30:44 herbelin Exp $ *)
+(* $Id: classops.ml 8642 2006-03-17 10:09:02Z notin $ *)
open Util
open Pp
@@ -21,6 +21,7 @@ open Term
open Termops
open Rawterm
open Decl_kinds
+open Mod_subst
(* usage qque peu general: utilise aussi dans record *)
@@ -35,14 +36,14 @@ type cl_typ =
| CL_IND of inductive
type cl_info_typ = {
- cl_strength : strength;
cl_param : int
}
type coe_typ = global_reference
type coe_info_typ = {
- coe_value : unsafe_judgment;
+ coe_value : constr;
+ coe_type : types;
coe_strength : strength;
coe_is_identity : bool;
coe_param : int }
@@ -91,11 +92,7 @@ let unfreeze (fcl,fco,fig) =
(* ajout de nouveaux "objets" *)
let add_new_class cl s =
- try
- let n,s' = Bijint.revmap cl !class_tab in
- if s.cl_strength = Global & s'.cl_strength <> Global then
- class_tab := Bijint.replace n cl s !class_tab
- with Not_found ->
+ if not (Bijint.mem cl !class_tab) then
class_tab := Bijint.add cl s !class_tab
let add_new_coercion coe s =
@@ -106,11 +103,19 @@ let add_new_path x y =
let init () =
class_tab:= Bijint.empty;
- add_new_class CL_FUN { cl_param = 0; cl_strength = Global };
- add_new_class CL_SORT { cl_param = 0; cl_strength = Global };
+ add_new_class CL_FUN { cl_param = 0 };
+ add_new_class CL_SORT { cl_param = 0 };
coercion_tab:= Gmap.empty;
inheritance_graph:= Gmap.empty
+let _ =
+ Summary.declare_summary "inh_graph"
+ { Summary.freeze_function = freeze;
+ Summary.unfreeze_function = unfreeze;
+ Summary.init_function = init;
+ Summary.survive_module = false;
+ Summary.survive_section = false }
+
let _ = init()
(* class_info : cl_typ -> int * cl_info_typ *)
@@ -146,80 +151,44 @@ let lookup_pattern_path_between (s,t) =
(fun coe ->
let c, _ =
Reductionops.whd_betadeltaiota_stack (Global.env()) Evd.empty
- coe.coe_value.uj_val
+ coe.coe_value
in
match kind_of_term c with
| Construct sp -> (sp, coe.coe_param)
| _ -> raise Not_found) l
+(* find_class_type : constr -> cl_typ * int *)
+
+let find_class_type t =
+ let t', args = decompose_app (Reductionops.whd_betaiotazeta t) in
+ match kind_of_term t' with
+ | Var id -> CL_SECVAR id, args
+ | Const sp -> CL_CONST sp, args
+ | Ind ind_sp -> CL_IND ind_sp, args
+ | Prod (_,_,_) -> CL_FUN, []
+ | Sort _ -> CL_SORT, []
+ | _ -> raise Not_found
+
let subst_cl_typ subst ct = match ct with
CL_SORT
| CL_FUN
| CL_SECVAR _ -> ct
| CL_CONST kn ->
- let kn' = subst_kn subst kn in
+ let kn',t = subst_con subst kn in
if kn' == kn then ct else
- CL_CONST kn'
+ fst (find_class_type t)
| CL_IND (kn,i) ->
let kn' = subst_kn subst kn in
if kn' == kn then ct else
CL_IND (kn',i)
-let subst_coe_typ = subst_global
-
-let subst_coe_info subst info =
- let jud = info.coe_value in
- let val' = subst_mps subst (j_val jud) in
- let type' = subst_mps subst (j_type jud) in
- if val' == j_val jud && type' == j_type jud then info else
- {info with coe_value = make_judge val' type'}
-
-(* library, summary *)
-
-(*val inClass : (cl_typ * cl_info_typ) -> Libobject.object = <fun>
- val outClass : Libobject.object -> (cl_typ * cl_info_typ) = <fun> *)
-
-let cache_class (_,(x,y)) = add_new_class x y
-
-let subst_class (_,subst,(ct,ci as obj)) =
- let ct' = subst_cl_typ subst ct in
- if ct' == ct then obj else
- (ct',ci)
-
-let (inClass,outClass) =
- declare_object {(default_object "CLASS") with
- load_function = (fun _ o -> cache_class o);
- cache_function = cache_class;
- subst_function = subst_class;
- classify_function = (fun (_,x) -> Substitute x);
- export_function = (function x -> Some x) }
-
-let declare_class (cl,stre,p) =
- Lib.add_anonymous_leaf (inClass ((cl,{ cl_strength = stre; cl_param = p })))
-
-let _ =
- Summary.declare_summary "inh_graph"
- { Summary.freeze_function = freeze;
- Summary.unfreeze_function = unfreeze;
- Summary.init_function = init;
- Summary.survive_module = false;
- Summary.survive_section = false }
+(*CSC: here we should change the datatype for coercions: it should be possible
+ to declare any term as a coercion *)
+let subst_coe_typ subst t = fst (subst_global subst t)
(* classe d'un terme *)
-(* find_class_type : constr -> cl_typ * int *)
-
-let find_class_type t =
- let t', args = decompose_app (Reductionops.whd_betaiotazeta t) in
- match kind_of_term t' with
- | Var id -> CL_SECVAR id, args
- | Const sp -> CL_CONST sp, args
- | Ind ind_sp -> CL_IND ind_sp, args
- | Prod (_,_,_) -> CL_FUN, []
- | Sort _ -> CL_SORT, []
- | _ -> raise Not_found
-
(* class_of : Term.constr -> int *)
let class_of env sigma t =
@@ -241,8 +210,8 @@ let inductive_class_of ind = fst (class_info (CL_IND ind))
let class_args_of c = snd (decompose_app c)
let string_of_class = function
- | CL_FUN -> if !Options.v7 then "FUNCLASS" else "Funclass"
- | CL_SORT -> if !Options.v7 then "SORTCLASS" else "Sortclass"
+ | CL_FUN -> "Funclass"
+ | CL_SORT -> "Sortclass"
| CL_CONST sp ->
string_of_qualid (shortest_qualid_of_global Idset.empty (ConstRef sp))
| CL_IND sp ->
@@ -254,7 +223,8 @@ let pr_class x = str (string_of_class x)
(* coercion_value : coe_index -> unsafe_judgment * bool *)
-let coercion_value { coe_value = j; coe_is_identity = b } = (j,b)
+let coercion_value { coe_value = c; coe_type = t; coe_is_identity = b } =
+ (make_judge c t, b)
(* pretty-print functions are now in Pretty *)
(* rajouter une coercion dans le graphe *)
@@ -319,49 +289,81 @@ let add_coercion_in_graph (ic,source,target) =
if (!ambig_paths <> []) && is_verbose () then
ppnl (message_ambig !ambig_paths)
-type coercion = coe_typ * coe_info_typ * cl_typ * cl_typ
+type coercion = coe_typ * strength * bool * cl_typ * cl_typ * int
+
+(* Calcul de l'arité d'une classe *)
-let cache_coercion (_,(coe,xf,cls,clt)) =
+let reference_arity_length ref =
+ let t = Global.type_of_global ref in
+ List.length (fst (Reductionops.splay_arity (Global.env()) Evd.empty t))
+
+let class_params = function
+ | CL_FUN | CL_SORT -> 0
+ | CL_CONST sp -> reference_arity_length (ConstRef sp)
+ | CL_SECVAR sp -> reference_arity_length (VarRef sp)
+ | CL_IND sp -> reference_arity_length (IndRef sp)
+
+(* add_class : cl_typ -> strength option -> bool -> unit *)
+
+let add_class cl =
+ add_new_class cl { cl_param = class_params cl }
+
+let load_coercion i (_,(coe,stre,isid,cls,clt,ps)) =
+ add_class cls;
+ add_class clt;
let is,_ = class_info cls in
let it,_ = class_info clt in
+ let xf =
+ { coe_value = constr_of_global coe;
+ coe_type = Global.type_of_global coe;
+ coe_strength = stre;
+ coe_is_identity = isid;
+ coe_param = ps } in
add_new_coercion coe xf;
add_coercion_in_graph (xf,is,it)
-let subst_coercion (_,subst,(coe,xf,cls,clt as obj)) =
+let cache_coercion o =
+ load_coercion 1 o
+
+let subst_coercion (_,subst,(coe,stre,isid,cls,clt,ps as obj)) =
let coe' = subst_coe_typ subst coe in
- let xf' = subst_coe_info subst xf in
let cls' = subst_cl_typ subst cls in
let clt' = subst_cl_typ subst clt in
- if coe' == coe && xf' == xf && cls' == cls & clt' == clt then obj else
- (coe',xf',cls',clt')
-
-
-(* val inCoercion : coercion -> Libobject.object
- val outCoercion : Libobject.object -> coercion *)
+ if coe' == coe && cls' == cls & clt' == clt then obj else
+ (coe',stre,isid,cls',clt',ps)
+
+let discharge_cl = function
+ | CL_CONST kn -> CL_CONST (Lib.discharge_con kn)
+ | CL_IND ind -> CL_IND (Lib.discharge_inductive ind)
+ | cl -> cl
+
+let discharge_coercion (_,(coe,stre,isid,cls,clt,ps)) =
+ if stre = Local then None else
+ let n = try Array.length (Lib.section_instance coe) with Not_found -> 0 in
+ Some (Lib.discharge_global coe,
+ stre,
+ isid,
+ discharge_cl cls,
+ discharge_cl clt,
+ n + ps)
let (inCoercion,outCoercion) =
declare_object {(default_object "COERCION") with
- load_function = (fun _ o -> cache_coercion o);
- cache_function = cache_coercion;
- subst_function = subst_coercion;
- classify_function = (fun (_,x) -> Substitute x);
- export_function = (function x -> Some x) }
-
-let declare_coercion coef v stre ~isid ~src:cls ~target:clt ~params:ps =
- Lib.add_anonymous_leaf
- (inCoercion
- (coef,
- { coe_value = v;
- coe_strength = stre;
- coe_is_identity = isid;
- coe_param = ps },
- cls, clt))
+ load_function = load_coercion;
+ cache_function = cache_coercion;
+ subst_function = subst_coercion;
+ classify_function = (fun (_,x) -> Substitute x);
+ discharge_function = discharge_coercion;
+ export_function = (function x -> Some x) }
+
+let declare_coercion coef stre ~isid ~src:cls ~target:clt ~params:ps =
+ Lib.add_anonymous_leaf (inCoercion (coef,stre,isid,cls,clt,ps))
let coercion_strength v = v.coe_strength
let coercion_identity v = v.coe_is_identity
(* For printing purpose *)
-let get_coercion_value v = v.coe_value.uj_val
+let get_coercion_value v = v.coe_value
let classes () = Bijint.dom !class_tab
let coercions () = Gmap.rng !coercion_tab
diff --git a/pretyping/classops.mli b/pretyping/classops.mli
index f846a9e5..276b14d1 100644
--- a/pretyping/classops.mli
+++ b/pretyping/classops.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: classops.mli,v 1.30.2.1 2004/07/16 19:30:44 herbelin Exp $ i*)
+(*i $Id: classops.mli 6748 2005-02-18 22:17:50Z herbelin $ i*)
(*i*)
open Names
@@ -15,6 +15,7 @@ open Term
open Evd
open Environ
open Nametab
+open Mod_subst
(*i*)
(*s This is the type of class kinds *)
@@ -29,7 +30,6 @@ val subst_cl_typ : substitution -> cl_typ -> cl_typ
(* This is the type of infos for declared classes *)
type cl_info_typ = {
- cl_strength : strength;
cl_param : int }
(* This is the type of coercion kinds *)
@@ -47,9 +47,6 @@ type coe_index
(* This is the type of paths from a class to another *)
type inheritance_path = coe_index list
-(*s [declare_class] adds a class to the set of declared classes *)
-val declare_class : cl_typ * strength * int -> unit
-
(*s Access to classes infos *)
val class_info : cl_typ -> (cl_index * cl_info_typ)
val class_exists : cl_typ -> bool
@@ -69,7 +66,7 @@ val class_args_of : constr -> constr list
(*s [declare_coercion] adds a coercion in the graph of coercion paths *)
val declare_coercion :
- coe_typ -> unsafe_judgment -> strength -> isid:bool ->
+ coe_typ -> strength -> isid:bool ->
src:cl_typ -> target:cl_typ -> params:int -> unit
(*s Access to coercions infos *)
@@ -84,19 +81,6 @@ val lookup_path_to_sort_from : cl_index -> inheritance_path
val lookup_pattern_path_between :
cl_index * cl_index -> (constructor * int) list
-(*i Pour le discharge *)
-type coercion = coe_typ * coe_info_typ * cl_typ * cl_typ
-
-open Libobject
-val inClass : (cl_typ * cl_info_typ) -> Libobject.obj
-val outClass : Libobject.obj -> (cl_typ * cl_info_typ)
-val inCoercion : coercion -> Libobject.obj
-val outCoercion : Libobject.obj -> coercion
-val coercion_strength : coe_info_typ -> strength
-val coercion_identity : coe_info_typ -> bool
-val coercion_params : coe_info_typ -> int
-(*i*)
-
(*i Crade *)
open Pp
val install_path_printer :
diff --git a/pretyping/clenv.ml b/pretyping/clenv.ml
new file mode 100644
index 00000000..0b88b14b
--- /dev/null
+++ b/pretyping/clenv.ml
@@ -0,0 +1,435 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id: clenv.ml 8688 2006-04-07 15:08:12Z msozeau $ *)
+
+open Pp
+open Util
+open Names
+open Nameops
+open Term
+open Termops
+open Sign
+open Environ
+open Evd
+open Reduction
+open Reductionops
+open Rawterm
+open Pattern
+open Tacexpr
+open Tacred
+open Pretype_errors
+open Evarutil
+open Unification
+open Mod_subst
+
+(* *)
+let w_coerce env c ctyp target evd =
+ let j = make_judge c ctyp in
+ let (evd',j') = Coercion.Default.inh_conv_coerce_to dummy_loc env evd j (mk_tycon_type target) in
+ (evd',j'.uj_val)
+
+let pf_env gls = Global.env_of_context gls.it.evar_hyps
+let pf_type_of gls c = Typing.type_of (pf_env gls) gls.sigma c
+let pf_hnf_constr gls c = hnf_constr (pf_env gls) gls.sigma c
+let pf_concl gl = gl.it.evar_concl
+
+(******************************************************************)
+(* Clausal environments *)
+
+type clausenv = {
+ templenv : env;
+ env : evar_defs;
+ templval : constr freelisted;
+ templtyp : constr freelisted }
+
+let cl_env ce = ce.templenv
+let cl_sigma ce = evars_of ce.env
+
+let subst_clenv sub clenv =
+ { templval = map_fl (subst_mps sub) clenv.templval;
+ templtyp = map_fl (subst_mps sub) clenv.templtyp;
+ env = subst_evar_defs sub clenv.env;
+ templenv = clenv.templenv }
+
+let clenv_nf_meta clenv c = nf_meta clenv.env c
+let clenv_meta_type clenv mv = Typing.meta_type clenv.env mv
+let clenv_value clenv = meta_instance clenv.env clenv.templval
+let clenv_type clenv = meta_instance clenv.env clenv.templtyp
+
+
+let clenv_hnf_constr ce t = hnf_constr (cl_env ce) (cl_sigma ce) t
+
+let clenv_get_type_of ce c =
+ let metamap =
+ List.map
+ (function
+ | (n,Clval(_,_,typ)) -> (n,typ.rebus)
+ | (n,Cltyp (_,typ)) -> (n,typ.rebus))
+ (meta_list ce.env) in
+ Retyping.get_type_of_with_meta (cl_env ce) (cl_sigma ce) metamap c
+
+let clenv_environments evd bound c =
+ let rec clrec (e,metas) n c =
+ match n, kind_of_term c with
+ | (Some 0, _) -> (e, List.rev metas, c)
+ | (n, Cast (c,_,_)) -> clrec (e,metas) n c
+ | (n, Prod (na,c1,c2)) ->
+ let mv = new_meta () in
+ let dep = dependent (mkRel 1) c2 in
+ let na' = if dep then na else Anonymous in
+ let e' = meta_declare mv c1 ~name:na' e in
+ clrec (e', (mkMeta mv)::metas) (option_app ((+) (-1)) n)
+ (if dep then (subst1 (mkMeta mv) c2) else c2)
+ | (n, LetIn (na,b,_,c)) ->
+ clrec (e,metas) (option_app ((+) (-1)) n) (subst1 b c)
+ | (n, _) -> (e, List.rev metas, c)
+ in
+ clrec (evd,[]) bound c
+
+let clenv_environments_evars env evd bound c =
+ let rec clrec (e,ts) n c =
+ match n, kind_of_term c with
+ | (Some 0, _) -> (e, List.rev ts, c)
+ | (n, Cast (c,_,_)) -> clrec (e,ts) n c
+ | (n, Prod (na,c1,c2)) ->
+ let e',constr = Evarutil.new_evar e env c1 in
+ let dep = dependent (mkRel 1) c2 in
+ clrec (e', constr::ts) (option_app ((+) (-1)) n)
+ (if dep then (subst1 constr c2) else c2)
+ | (n, LetIn (na,b,_,c)) ->
+ clrec (e,ts) (option_app ((+) (-1)) n) (subst1 b c)
+ | (n, _) -> (e, List.rev ts, c)
+ in
+ clrec (evd,[]) bound c
+
+let mk_clenv_from_n gls n (c,cty) =
+ let evd = create_evar_defs gls.sigma in
+ let (env,args,concl) = clenv_environments evd n cty in
+ { templval = mk_freelisted (match args with [] -> c | _ -> applist (c,args));
+ templtyp = mk_freelisted concl;
+ env = env;
+ templenv = Global.env_of_context gls.it.evar_hyps }
+
+let mk_clenv_from gls = mk_clenv_from_n gls None
+
+let mk_clenv_rename_from gls (c,t) =
+ mk_clenv_from gls (c,rename_bound_var (pf_env gls) [] t)
+
+let mk_clenv_rename_from_n gls n (c,t) =
+ mk_clenv_from_n gls n (c,rename_bound_var (pf_env gls) [] t)
+
+let mk_clenv_type_of gls t = mk_clenv_from gls (t,pf_type_of gls t)
+
+(******************************************************************)
+
+(* [mentions clenv mv0 mv1] is true if mv1 is defined and mentions
+ * mv0, or if one of the free vars on mv1's freelist mentions
+ * mv0 *)
+
+let mentions clenv mv0 =
+ let rec menrec mv1 =
+ mv0 = mv1 ||
+ let mlist =
+ try (meta_fvalue clenv.env mv1).freemetas
+ with Anomaly _ | Not_found -> Metaset.empty in
+ meta_exists menrec mlist
+ in menrec
+
+let clenv_defined clenv mv = meta_defined clenv.env mv
+
+let error_incompatible_inst clenv mv =
+ let na = meta_name clenv.env mv in
+ match na with
+ Name id ->
+ errorlabstrm "clenv_assign"
+ (str "An incompatible instantiation has already been found for " ++
+ pr_id id)
+ | _ ->
+ anomaly "clenv_assign: non dependent metavar already assigned"
+
+(* TODO: replace by clenv_unify (mkMeta mv) rhs ? *)
+let clenv_assign mv rhs clenv =
+ let rhs_fls = mk_freelisted rhs in
+ if meta_exists (mentions clenv mv) rhs_fls.freemetas then
+ error "clenv_assign: circularity in unification";
+ try
+ if meta_defined clenv.env mv then
+ if not (eq_constr (meta_fvalue clenv.env mv).rebus rhs) then
+ error_incompatible_inst clenv mv
+ else
+ clenv
+ else {clenv with env = meta_assign mv rhs_fls.rebus clenv.env}
+ with Not_found ->
+ error "clenv_assign: undefined meta"
+
+
+let clenv_wtactic f clenv = {clenv with env = f clenv.env }
+
+
+(* [clenv_dependent hyps_only clenv]
+ * returns a list of the metavars which appear in the template of clenv,
+ * and which are dependent, This is computed by taking the metavars in cval,
+ * in right-to-left order, and collecting the metavars which appear
+ * in their types, and adding in all the metavars appearing in the
+ * type of clenv.
+ * If [hyps_only] then metavariables occurring in the type are _excluded_ *)
+
+(* collects all metavar occurences, in left-to-right order, preserving
+ * repetitions and all. *)
+
+let collect_metas c =
+ let rec collrec acc c =
+ match kind_of_term c with
+ | Meta mv -> mv::acc
+ | _ -> fold_constr collrec acc c
+ in
+ List.rev (collrec [] c)
+
+(* [clenv_metavars clenv mv]
+ * returns a list of the metavars which appear in the type of
+ * the metavar mv. The list is unordered. *)
+
+let clenv_metavars clenv mv = (meta_ftype clenv mv).freemetas
+
+let dependent_metas clenv mvs conclmetas =
+ List.fold_right
+ (fun mv deps ->
+ Metaset.union deps (clenv_metavars clenv.env mv))
+ mvs conclmetas
+
+let clenv_dependent hyps_only clenv =
+ let mvs = collect_metas (clenv_value clenv) in
+ let ctyp_mvs = (mk_freelisted (clenv_type clenv)).freemetas in
+ let deps = dependent_metas clenv mvs ctyp_mvs in
+ List.filter
+ (fun mv -> Metaset.mem mv deps &&
+ not (hyps_only && Metaset.mem mv ctyp_mvs))
+ mvs
+
+let clenv_missing ce = clenv_dependent true ce
+
+(******************************************************************)
+
+let clenv_unify allow_K cv_pb t1 t2 clenv =
+ { clenv with env = w_unify allow_K clenv.templenv cv_pb t1 t2 clenv.env }
+
+let clenv_unique_resolver allow_K clause gl =
+ clenv_unify allow_K CUMUL (clenv_type clause) (pf_concl gl) clause
+
+
+(* [clenv_pose_dependent_evars clenv]
+ * For each dependent evar in the clause-env which does not have a value,
+ * pose a value for it by constructing a fresh evar. We do this in
+ * left-to-right order, so that every evar's type is always closed w.r.t.
+ * metas. *)
+let clenv_pose_dependent_evars clenv =
+ let dep_mvs = clenv_dependent false clenv in
+ List.fold_left
+ (fun clenv mv ->
+ let ty = clenv_meta_type clenv mv in
+ let (evd,evar) = new_evar clenv.env (cl_env clenv) ty in
+ clenv_assign mv evar {clenv with env=evd})
+ clenv
+ dep_mvs
+
+let evar_clenv_unique_resolver clenv gls =
+ clenv_pose_dependent_evars (clenv_unique_resolver false clenv gls)
+
+
+(******************************************************************)
+
+let connect_clenv gls clenv =
+ { clenv with
+ env = evars_reset_evd gls.sigma clenv.env;
+ templenv = Global.env_of_context gls.it.evar_hyps }
+
+(* [clenv_fchain mv clenv clenv']
+ *
+ * Resolves the value of "mv" (which must be undefined) in clenv to be
+ * the template of clenv' be the value "c", applied to "n" fresh
+ * metavars, whose types are chosen by destructing "clf", which should
+ * be a clausale forme generated from the type of "c". The process of
+ * resolution can cause unification of already-existing metavars, and
+ * of the fresh ones which get created. This operation is a composite
+ * of operations which pose new metavars, perform unification on
+ * terms, and make bindings. *)
+let clenv_fchain mv clenv nextclenv =
+ (* Add the metavars of [nextclenv] to [clenv], with their name-environment *)
+ let clenv' =
+ { templval = clenv.templval;
+ templtyp = clenv.templtyp;
+ env = meta_merge clenv.env nextclenv.env;
+ templenv = nextclenv.templenv } in
+ (* unify the type of the template of [nextclenv] with the type of [mv] *)
+ let clenv'' =
+ clenv_unify true CUMUL
+ (clenv_nf_meta clenv' nextclenv.templtyp.rebus)
+ (clenv_meta_type clenv' mv)
+ clenv' in
+ (* assign the metavar *)
+ let clenv''' =
+ clenv_assign mv (clenv_nf_meta clenv' nextclenv.templval.rebus) clenv''
+ in
+ clenv'''
+
+(***************************************************************)
+(* Bindings *)
+
+type arg_bindings = (int * constr) list
+
+(* [clenv_independent clenv]
+ * returns a list of metavariables which appear in the term cval,
+ * and which are not dependent. That is, they do not appear in
+ * the types of other metavars which are in cval, nor in the type
+ * of cval, ctyp. *)
+
+let clenv_independent clenv =
+ let mvs = collect_metas (clenv_value clenv) in
+ let ctyp_mvs = (mk_freelisted (clenv_type clenv)).freemetas in
+ let deps = dependent_metas clenv mvs ctyp_mvs in
+ List.filter (fun mv -> not (Metaset.mem mv deps)) mvs
+
+let meta_of_binder clause loc b t mvs =
+ match b with
+ | NamedHyp s ->
+ if List.exists (fun (_,b',_) -> b=b') t then
+ errorlabstrm "clenv_match_args"
+ (str "The variable " ++ pr_id s ++
+ str " occurs more than once in binding");
+ meta_with_name clause.env s
+ | AnonHyp n ->
+ if List.exists (fun (_,b',_) -> b=b') t then
+ errorlabstrm "clenv_match_args"
+ (str "The position " ++ int n ++
+ str " occurs more than once in binding");
+ try List.nth mvs (n-1)
+ with (Failure _|Invalid_argument _) ->
+ errorlabstrm "clenv_match_args" (str "No such binder")
+
+let error_already_defined b =
+ match b with
+ NamedHyp id ->
+ errorlabstrm "clenv_match_args"
+ (str "Binder name \"" ++ pr_id id ++
+ str"\" already defined with incompatible value")
+ | AnonHyp n ->
+ anomalylabstrm "clenv_match_args"
+ (str "Position " ++ int n ++ str" already defined")
+
+let clenv_match_args s clause =
+ let mvs = clenv_independent clause in
+ let rec matchrec clause = function
+ | [] -> clause
+ | (loc,b,c)::t ->
+ let k = meta_of_binder clause loc b t mvs in
+ if meta_defined clause.env k then
+ if eq_constr (meta_fvalue clause.env k).rebus c then
+ matchrec clause t
+ else error_already_defined b
+ else
+ let k_typ = clenv_hnf_constr clause (clenv_meta_type clause k)
+ (* nf_betaiota was before in type_of - useful to reduce
+ types like (x:A)([x]P u) *)
+ and c_typ =
+ clenv_hnf_constr clause
+ (nf_betaiota (clenv_get_type_of clause c)) in
+ let cl =
+ (* Try to infer some Meta/Evar from the type of [c] *)
+ try clenv_assign k c (clenv_unify true CUMUL c_typ k_typ clause)
+ with e when precatchable_exception e ->
+ (* Try to coerce to the type of [k]; cannot merge with the
+ previous case because Coercion does not handle Meta *)
+ let (_,c') = w_coerce (cl_env clause) c c_typ k_typ clause.env in
+ try clenv_unify true CONV (mkMeta k) c' clause
+ with PretypeError (env,CannotUnify (m,n)) ->
+ Stdpp.raise_with_loc loc
+ (PretypeError (env,CannotUnifyBindingType (m,n)))
+ in matchrec cl t
+ in
+ matchrec clause s
+
+
+let clenv_constrain_with_bindings bl clause =
+ if bl = [] then
+ clause
+ else
+ let all_mvs = collect_metas clause.templval.rebus in
+ let rec matchrec clause = function
+ | [] -> clause
+ | (n,c)::t ->
+ let k =
+ (try
+ if n > 0 then
+ List.nth all_mvs (n-1)
+ else if n < 0 then
+ List.nth (List.rev all_mvs) (-n-1)
+ else error "clenv_constrain_with_bindings"
+ with Failure _ ->
+ errorlabstrm "clenv_constrain_with_bindings"
+ (str"Clause did not have " ++ int n ++ str"-th" ++
+ str" absolute argument")) in
+ let k_typ = nf_betaiota (clenv_meta_type clause k) in
+ let c_typ = nf_betaiota (clenv_get_type_of clause c) in
+ matchrec
+ (clenv_assign k c (clenv_unify true CUMUL c_typ k_typ clause)) t
+ in
+ matchrec clause bl
+
+
+(* not exported: maybe useful ? *)
+let clenv_constrain_dep_args hyps_only clause = function
+ | [] -> clause
+ | mlist ->
+ let occlist = clenv_dependent hyps_only clause in
+ if List.length occlist = List.length mlist then
+ List.fold_left2
+ (fun clenv k c ->
+ try
+ let k_typ =
+ clenv_hnf_constr clause (clenv_meta_type clause k) in
+ let c_typ =
+ clenv_hnf_constr clause (clenv_get_type_of clause c) in
+ (* faire quelque chose avec le sigma retourne ? *)
+ let (_,c') = w_coerce (cl_env clenv) c c_typ k_typ clenv.env in
+ clenv_unify true CONV (mkMeta k) c' clenv
+ with _ ->
+ clenv_unify true CONV (mkMeta k) c clenv)
+ clause occlist mlist
+ else
+ error ("Not the right number of missing arguments (expected "
+ ^(string_of_int (List.length occlist))^")")
+
+let clenv_constrain_missing_args mlist clause =
+ clenv_constrain_dep_args true clause mlist
+
+
+(****************************************************************)
+(* Clausal environment for an application *)
+
+let make_clenv_binding_gen n gls (c,t) = function
+ | ImplicitBindings largs ->
+ let clause = mk_clenv_from_n gls n (c,t) in
+ clenv_constrain_dep_args (n <> None) clause largs
+ | ExplicitBindings lbind ->
+ let clause = mk_clenv_rename_from_n gls n (c,t) in
+ clenv_match_args lbind clause
+ | NoBindings ->
+ mk_clenv_from_n gls n (c,t)
+
+let make_clenv_binding_apply wc n = make_clenv_binding_gen (Some n) wc
+let make_clenv_binding = make_clenv_binding_gen None
+
+(****************************************************************)
+(* Pretty-print *)
+
+let pr_clenv clenv =
+ h 0
+ (str"TEMPL: " ++ print_constr clenv.templval.rebus ++
+ str" : " ++ print_constr clenv.templtyp.rebus ++ fnl () ++
+ pr_evar_defs clenv.env)
diff --git a/pretyping/clenv.mli b/pretyping/clenv.mli
new file mode 100644
index 00000000..f585dfea
--- /dev/null
+++ b/pretyping/clenv.mli
@@ -0,0 +1,117 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(*i $Id: clenv.mli 7659 2005-12-17 21:07:17Z herbelin $ i*)
+
+(*i*)
+open Util
+open Names
+open Term
+open Sign
+open Environ
+open Evd
+open Evarutil
+open Mod_subst
+(*i*)
+
+(***************************************************************)
+(* The Type of Constructions clausale environments. *)
+
+(* [templenv] is the typing context
+ * [env] is the mapping from metavar and evar numbers to their types
+ * and values.
+ * [templval] is the template which we are trying to fill out.
+ * [templtyp] is its type.
+ * [namenv] is a mapping from metavar numbers to names, for
+ * use in instantiating metavars by name.
+ *)
+type clausenv = {
+ templenv : env;
+ env : evar_defs;
+ templval : constr freelisted;
+ templtyp : constr freelisted }
+
+(* Substitution is not applied on templenv (because [subst_clenv] is
+ applied only on hints which typing env is overwritten by the
+ goal env) *)
+val subst_clenv : substitution -> clausenv -> clausenv
+
+(* subject of clenv (instantiated) *)
+val clenv_value : clausenv -> constr
+(* type of clenv (instantiated) *)
+val clenv_type : clausenv -> types
+(* substitute resolved metas *)
+val clenv_nf_meta : clausenv -> constr -> constr
+(* type of a meta in clenv context *)
+val clenv_meta_type : clausenv -> metavariable -> types
+
+val mk_clenv_from : evar_info sigma -> constr * types -> clausenv
+val mk_clenv_from_n :
+ evar_info sigma -> int option -> constr * types -> clausenv
+val mk_clenv_rename_from : evar_info sigma -> constr * types -> clausenv
+val mk_clenv_rename_from_n :
+ evar_info sigma -> int option -> constr * types -> clausenv
+val mk_clenv_type_of : evar_info sigma -> constr -> clausenv
+
+(***************************************************************)
+(* linking of clenvs *)
+
+val connect_clenv : evar_info sigma -> clausenv -> clausenv
+val clenv_fchain : metavariable -> clausenv -> clausenv -> clausenv
+
+(***************************************************************)
+(* Unification with clenvs *)
+
+(* Unifies two terms in a clenv. The boolean is [allow_K] (see [Unification]) *)
+val clenv_unify :
+ bool -> conv_pb -> constr -> constr -> clausenv -> clausenv
+
+(* unifies the concl of the goal with the type of the clenv *)
+val clenv_unique_resolver :
+ bool -> clausenv -> evar_info sigma -> clausenv
+
+(* same as above ([allow_K=false]) but replaces remaining metas
+ with fresh evars *)
+val evar_clenv_unique_resolver :
+ clausenv -> evar_info sigma -> clausenv
+
+(***************************************************************)
+(* Bindings *)
+
+(* bindings where the key is the position in the template of the
+ clenv (dependent or not). Positions can be negative meaning to
+ start from the rightmost argument of the template. *)
+type arg_bindings = (int * constr) list
+
+val clenv_independent : clausenv -> metavariable list
+val clenv_missing : clausenv -> metavariable list
+
+(* defines metas corresponding to the name of the bindings *)
+val clenv_match_args :
+ constr Rawterm.explicit_bindings -> clausenv -> clausenv
+val clenv_constrain_with_bindings : arg_bindings -> clausenv -> clausenv
+
+(* start with a clenv to refine with a given term with bindings *)
+
+(* 1- the arity of the lemma is fixed *)
+val make_clenv_binding_apply :
+ evar_info sigma -> int -> constr * constr -> constr Rawterm.bindings ->
+ clausenv
+val make_clenv_binding :
+ evar_info sigma -> constr * constr -> constr Rawterm.bindings -> clausenv
+
+(* other stuff *)
+val clenv_environments :
+ evar_defs -> int option -> types -> evar_defs * constr list * types
+val clenv_environments_evars :
+ env -> evar_defs -> int option -> types -> evar_defs * constr list * types
+
+(***************************************************************)
+(* Pretty-print *)
+val pr_clenv : clausenv -> Pp.std_ppcmds
+
diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml
index be78eb2c..e01dac47 100644
--- a/pretyping/coercion.ml
+++ b/pretyping/coercion.ml
@@ -5,7 +5,7 @@
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: coercion.ml,v 1.38.6.2 2005/11/29 21:40:52 letouzey Exp $ *)
+(* $Id: coercion.ml 8695 2006-04-10 16:33:52Z msozeau $ *)
open Util
open Names
@@ -19,189 +19,248 @@ open Recordops
open Evarutil
open Evarconv
open Retyping
+open Evd
-(* Typing operations dealing with coercions *)
-
-let class_of1 env sigma t = class_of env sigma (nf_evar sigma t)
-
-(* Here, funj is a coercion therefore already typed in global context *)
-let apply_coercion_args env argl funj =
- let rec apply_rec acc typ = function
- | [] -> { uj_val = applist (j_val funj,argl);
- uj_type = typ }
- | h::restl ->
- (* On devrait pouvoir s'arranger pour qu'on n'ait pas à faire hnf_constr *)
- match kind_of_term (whd_betadeltaiota env Evd.empty typ) with
- | Prod (_,c1,c2) ->
- (* Typage garanti par l'appel à app_coercion*)
- apply_rec (h::acc) (subst1 h c2) restl
- | _ -> anomaly "apply_coercion_args"
- in
- apply_rec [] funj.uj_type argl
-
-exception NoCoercion
-
-(* appliquer le chemin de coercions de patterns p *)
-
-let apply_pattern_coercion loc pat p =
- List.fold_left
- (fun pat (co,n) ->
- let f i = if i<n then Rawterm.PatVar (loc, Anonymous) else pat in
- Rawterm.PatCstr (loc, co, list_tabulate f (n+1), Anonymous))
- pat p
-
-(* raise Not_found if no coercion found *)
-let inh_pattern_coerce_to loc pat ind1 ind2 =
- let i1 = inductive_class_of ind1 in
- let i2 = inductive_class_of ind2 in
- let p = lookup_pattern_path_between (i1,i2) in
- apply_pattern_coercion loc pat p
-
-(* appliquer le chemin de coercions p à hj *)
-
-let apply_coercion env p hj typ_cl =
- try
- fst (List.fold_left
- (fun (ja,typ_cl) i ->
- let fv,isid = coercion_value i in
- let argl = (class_args_of typ_cl)@[ja.uj_val] in
- let jres = apply_coercion_args env argl fv in
- (if isid then
- { uj_val = ja.uj_val; uj_type = jres.uj_type }
- else
- jres),
- jres.uj_type)
- (hj,typ_cl) p)
- with _ -> anomaly "apply_coercion"
-
-let inh_app_fun env isevars j =
- let t = whd_betadeltaiota env (evars_of isevars) j.uj_type in
- match kind_of_term t with
- | Prod (_,_,_) -> j
- | Evar ev when not (is_defined_evar isevars ev) ->
- let t = define_evar_as_arrow isevars ev in
- { uj_val = j.uj_val; uj_type = t }
- | _ ->
- (try
- let t,i1 = class_of1 env (evars_of isevars) j.uj_type in
- let p = lookup_path_to_fun_from i1 in
- apply_coercion env p j t
- with Not_found -> j)
-
-let inh_tosort_force env isevars j =
- try
- let t,i1 = class_of1 env (evars_of isevars) j.uj_type in
- let p = lookup_path_to_sort_from i1 in
- apply_coercion env p j t
- with Not_found ->
- j
-
-let inh_coerce_to_sort env isevars j =
- let typ = whd_betadeltaiota env (evars_of isevars) j.uj_type in
- match kind_of_term typ with
- | Sort s -> { utj_val = j.uj_val; utj_type = s }
- | Evar ev when not (is_defined_evar isevars ev) ->
- let s = define_evar_as_sort isevars ev in
- { utj_val = j.uj_val; utj_type = s }
- | _ ->
- let j1 = inh_tosort_force env isevars j in
- type_judgment env (j_nf_evar (evars_of isevars) j1)
-
-let inh_coerce_to_fail env isevars c1 hj =
- let hj' =
- try
- let t1,i1 = class_of1 env (evars_of isevars) c1 in
- let t2,i2 = class_of1 env (evars_of isevars) hj.uj_type in
- let p = lookup_path_between (i2,i1) in
- apply_coercion env p hj t2
- with Not_found -> raise NoCoercion
- in
- if the_conv_x_leq env isevars hj'.uj_type c1 then
- hj'
- else
- raise NoCoercion
-
-let rec inh_conv_coerce_to_fail env isevars hj c1 =
- let {uj_val = v; uj_type = t} = hj in
- if the_conv_x_leq env isevars t c1 then hj
- else
- try
- inh_coerce_to_fail env isevars c1 hj
- with NoCoercion -> (* try ... with _ -> ... is BAD *)
- (match kind_of_term (whd_betadeltaiota env (evars_of isevars) t),
- kind_of_term (whd_betadeltaiota env (evars_of isevars) c1) with
- | Prod (_,t1,t2), Prod (name,u1,u2) ->
- let v' = whd_betadeltaiota env (evars_of isevars) v in
- if (match kind_of_term v' with
- | Lambda (_,v1,v2) ->
- the_conv_x env isevars v1 u1 (* leq v1 u1? *)
- | _ -> false)
- then
- let (x,v1,v2) = destLambda v' in
- let env1 = push_rel (x,None,v1) env in
- let h2 = inh_conv_coerce_to_fail env1 isevars
- {uj_val = v2; uj_type = t2 } u2 in
- { uj_val = mkLambda (x, v1, h2.uj_val);
- uj_type = mkProd (x, v1, h2.uj_type) }
- else
- (* Mismatch on t1 and u1 or not a lambda: we eta-expand *)
- (* we look for a coercion c:u1->t1 s.t. [name:u1](v' (c x)) *)
- (* has type (name:u1)u2 (with v' recursively obtained) *)
- let name = (match name with
- | Anonymous -> Name (id_of_string "x")
- | _ -> name) in
- let env1 = push_rel (name,None,u1) env in
- let h1 =
- inh_conv_coerce_to_fail env1 isevars
- {uj_val = mkRel 1; uj_type = (lift 1 u1) }
- (lift 1 t1) in
- let h2 = inh_conv_coerce_to_fail env1 isevars
- { uj_val = mkApp (lift 1 v, [|h1.uj_val|]);
- uj_type = subst1 h1.uj_val t2 }
- u2
- in
- { uj_val = mkLambda (name, u1, h2.uj_val);
- uj_type = mkProd (name, u1, h2.uj_type) }
- | _ -> raise NoCoercion)
-
-(* Look for cj' obtained from cj by inserting coercions, s.t. cj'.typ = t *)
-let inh_conv_coerce_to loc env isevars cj t =
- let cj' =
+module type S = sig
+ (*s Coercions. *)
+
+ (* [inh_app_fun env isevars j] coerces [j] to a function; i.e. it
+ inserts a coercion into [j], if needed, in such a way it gets as
+ type a product; it returns [j] if no coercion is applicable *)
+ val inh_app_fun :
+ env -> evar_defs -> unsafe_judgment -> evar_defs * unsafe_judgment
+
+ (* [inh_coerce_to_sort env isevars j] coerces [j] to a type; i.e. it
+ inserts a coercion into [j], if needed, in such a way it gets as
+ type a sort; it fails if no coercion is applicable *)
+ val inh_coerce_to_sort : loc ->
+ env -> evar_defs -> unsafe_judgment -> evar_defs * unsafe_type_judgment
+
+ (* [inh_conv_coerce_to loc env isevars j t] coerces [j] to an object of type
+ [t]; i.e. it inserts a coercion into [j], if needed, in such a way [t] and
+ [j.uj_type] are convertible; it fails if no coercion is applicable *)
+ val inh_conv_coerce_to : loc ->
+ env -> evar_defs -> unsafe_judgment -> type_constraint_type -> evar_defs * unsafe_judgment
+
+
+ (* [inh_conv_coerces_to loc env isevars t t'] checks if an object of type [t]
+ is coercible to an object of type [t'] adding evar constraints if needed;
+ it fails if no coercion exists *)
+ val inh_conv_coerces_to : loc ->
+ env -> evar_defs -> types -> type_constraint_type -> evar_defs
+
+ (* [inh_pattern_coerce_to loc env isevars pat ind1 ind2] coerces the Cases
+ pattern [pat] typed in [ind1] into a pattern typed in [ind2];
+ raises [Not_found] if no coercion found *)
+ val inh_pattern_coerce_to :
+ loc -> Rawterm.cases_pattern -> inductive -> inductive -> Rawterm.cases_pattern
+end
+
+module Default = struct
+ (* Typing operations dealing with coercions *)
+ exception NoCoercion
+
+ let class_of1 env sigma t = class_of env sigma (nf_evar sigma t)
+
+ (* Here, funj is a coercion therefore already typed in global context *)
+ let apply_coercion_args env argl funj =
+ let rec apply_rec acc typ = function
+ | [] -> { uj_val = applist (j_val funj,argl);
+ uj_type = typ }
+ | h::restl ->
+ (* On devrait pouvoir s'arranger pour qu'on n'ait pas à faire hnf_constr *)
+ match kind_of_term (whd_betadeltaiota env Evd.empty typ) with
+ | Prod (_,c1,c2) ->
+ (* Typage garanti par l'appel à app_coercion*)
+ apply_rec (h::acc) (subst1 h c2) restl
+ | _ -> anomaly "apply_coercion_args"
+ in
+ apply_rec [] funj.uj_type argl
+
+ (* appliquer le chemin de coercions de patterns p *)
+
+ let apply_pattern_coercion loc pat p =
+ List.fold_left
+ (fun pat (co,n) ->
+ let f i = if i<n then Rawterm.PatVar (loc, Anonymous) else pat in
+ Rawterm.PatCstr (loc, co, list_tabulate f (n+1), Anonymous))
+ pat p
+
+ (* raise Not_found if no coercion found *)
+ let inh_pattern_coerce_to loc pat ind1 ind2 =
+ let i1 = inductive_class_of ind1 in
+ let i2 = inductive_class_of ind2 in
+ let p = lookup_pattern_path_between (i1,i2) in
+ apply_pattern_coercion loc pat p
+
+ (* appliquer le chemin de coercions p à hj *)
+
+ let apply_coercion env p hj typ_cl =
try
- inh_conv_coerce_to_fail env isevars cj t
- with NoCoercion ->
- let sigma = evars_of isevars in
- error_actual_type_loc loc env sigma cj t
- in
- { uj_val = cj'.uj_val; uj_type = t }
-
-(* [inh_apply_rel_list loc env isevars args f tycon] tries to type [(f
- args)] of type [tycon] (if any) by inserting coercions in front of
- each arg$_i$, if necessary *)
-
-let inh_apply_rel_list apploc env isevars argjl (funloc,funj) tycon =
- let rec apply_rec env n resj = function
- | [] -> resj
- | (loc,hj)::restjl ->
- let sigma = evars_of isevars in
- let resj = inh_app_fun env isevars resj in
- let ntyp = whd_betadeltaiota env sigma resj.uj_type in
- match kind_of_term ntyp with
- | Prod (na,c1,c2) ->
- let hj' =
+ fst (List.fold_left
+ (fun (ja,typ_cl) i ->
+ let fv,isid = coercion_value i in
+ let argl = (class_args_of typ_cl)@[ja.uj_val] in
+ let jres = apply_coercion_args env argl fv in
+ (if isid then
+ { uj_val = ja.uj_val; uj_type = jres.uj_type }
+ else
+ jres),
+ jres.uj_type)
+ (hj,typ_cl) p)
+ with _ -> anomaly "apply_coercion"
+
+ let inh_app_fun env isevars j =
+ let t = whd_betadeltaiota env (evars_of isevars) j.uj_type in
+ match kind_of_term t with
+ | Prod (_,_,_) -> (isevars,j)
+ | Evar ev when not (is_defined_evar isevars ev) ->
+ let (isevars',t) = define_evar_as_arrow isevars ev in
+ (isevars',{ uj_val = j.uj_val; uj_type = t })
+ | _ ->
+ (try
+ let t,i1 = class_of1 env (evars_of isevars) j.uj_type in
+ let p = lookup_path_to_fun_from i1 in
+ (isevars,apply_coercion env p j t)
+ with Not_found -> (isevars,j))
+
+ let inh_tosort_force loc env isevars j =
+ try
+ let t,i1 = class_of1 env (evars_of isevars) j.uj_type in
+ let p = lookup_path_to_sort_from i1 in
+ let j1 = apply_coercion env p j t in
+ (isevars,type_judgment env (j_nf_evar (evars_of isevars) j1))
+ with Not_found ->
+ error_not_a_type_loc loc env (evars_of isevars) j
+
+ let inh_coerce_to_sort loc env isevars j =
+ let typ = whd_betadeltaiota env (evars_of isevars) j.uj_type in
+ match kind_of_term typ with
+ | Sort s -> (isevars,{ utj_val = j.uj_val; utj_type = s })
+ | Evar ev when not (is_defined_evar isevars ev) ->
+ let (isevars',s) = define_evar_as_sort isevars ev in
+ (isevars',{ utj_val = j.uj_val; utj_type = s })
+ | _ ->
+ inh_tosort_force loc env isevars j
+
+ let inh_coerce_to_fail env isevars c1 v t =
+ let v', t' =
+ try
+ let t1,i1 = class_of1 env (evars_of isevars) c1 in
+ let t2,i2 = class_of1 env (evars_of isevars) t in
+ let p = lookup_path_between (i2,i1) in
+ match v with
+ Some v ->
+ let j = apply_coercion env p {uj_val = v; uj_type = t} t2 in
+ Some j.uj_val, j.uj_type
+ | None -> None, t
+ with Not_found -> raise NoCoercion
+ in
+ try (the_conv_x_leq env t' c1 isevars, v', t')
+ with Reduction.NotConvertible -> raise NoCoercion
+ open Pp
+ let rec inh_conv_coerce_to_fail loc env isevars v t c1 =
+ try (the_conv_x_leq env t c1 isevars, v, t)
+ with Reduction.NotConvertible ->
+ (try
+ inh_coerce_to_fail env isevars c1 v t
+ with NoCoercion ->
+ (match kind_of_term (whd_betadeltaiota env (evars_of isevars) t),
+ kind_of_term (whd_betadeltaiota env (evars_of isevars) c1) with
+ | Prod (_,t1,t2), Prod (name,u1,u2) ->
+ let v' = option_app (whd_betadeltaiota env (evars_of isevars)) v in
+ let (evd',b) =
+ match v' with
+ Some v' ->
+ (match kind_of_term v' with
+ | Lambda (x,v1,v2) ->
+ (try the_conv_x env v1 u1 isevars, Some (x, v1, v2) (* leq v1 u1? *)
+ with Reduction.NotConvertible -> (isevars, None))
+ | _ -> (isevars, None))
+ | None -> (isevars, None)
+ in
+ (match b with
+ Some (x, v1, v2) ->
+ let env1 = push_rel (x,None,v1) env in
+ let (evd'', v2', t2') = inh_conv_coerce_to_fail loc env1 evd'
+ (Some v2) t2 u2 in
+ (evd'', option_app (fun v2' -> mkLambda (x, v1, v2')) v2',
+ mkProd (x, v1, t2'))
+ | None ->
+ (* Mismatch on t1 and u1 or not a lambda: we eta-expand *)
+ (* we look for a coercion c:u1->t1 s.t. [name:u1](v' (c x)) *)
+ (* has type (name:u1)u2 (with v' recursively obtained) *)
+ let name = (match name with
+ | Anonymous -> Name (id_of_string "x")
+ | _ -> name) in
+ let env1 = push_rel (name,None,u1) env in
+ let (evd', v1', t1') =
+ inh_conv_coerce_to_fail loc env1 isevars
+ (Some (mkRel 1)) (lift 1 u1) (lift 1 t1)
+ in
+ let (evd'', v2', t2') =
+ let v2 =
+ match v with
+ Some v -> option_app (fun v1' -> mkApp (lift 1 v, [|v1'|])) v1'
+ | None -> None
+ and evd', t2 =
+ match v1' with
+ Some v1' -> evd', subst1 v1' t2
+ | None ->
+ let evd', ev = new_evar evd' env ~src:(loc, InternalHole) t1' in
+ evd', subst1 ev t2
+ in
+ inh_conv_coerce_to_fail loc env1 evd' v2 t2 u2
+ in
+ (evd'', option_app (fun v2' -> mkLambda (name, u1, v2')) v2',
+ mkProd (name, u1, t2')))
+ | _ -> raise NoCoercion))
+
+ (* Look for cj' obtained from cj by inserting coercions, s.t. cj'.typ = t *)
+ let inh_conv_coerce_to loc env isevars cj (n, t) =
+ match n with
+ None ->
+ let (evd', val', type') =
+ try
+ inh_conv_coerce_to_fail loc env isevars (Some cj.uj_val) cj.uj_type t
+ with NoCoercion ->
+ let sigma = evars_of isevars in
+ error_actual_type_loc loc env sigma cj t
+ in
+ let val' = match val' with Some v -> v | None -> assert(false) in
+ let nf = nf_isevar evd' in
+ (evd',{ uj_val = nf val'; uj_type = nf t })
+ | Some (init, cur) -> (isevars, cj)
+
+ let inh_conv_coerces_to loc env (isevars : evar_defs) t (abs, t') = isevars
+ (* Still problematic, as it changes unification
+ let nabsinit, nabs =
+ match abs with
+ None -> 0, 0
+ | Some (init, cur) -> init, cur
+ in
+ try
+ let (rels, rng) =
+ (* a little more effort to get products is needed *)
+ try decompose_prod_n nabs t
+ with _ ->
+ if !Options.debug then
+ msg_warning (str "decompose_prod_n failed");
+ raise (Invalid_argument "Coercion.inh_conv_coerces_to")
+ in
+ (* The final range free variables must have been replaced by evars, we accept only that evars
+ in rng are applied to free vars. *)
+ if noccur_with_meta 0 (succ nabsinit) rng then (
+ let env', t, t' =
+ let env' = List.fold_right (fun (n, t) env -> push_rel (n, None, t) env) rels env in
+ env', rng, lift nabs t'
+ in
try
- inh_conv_coerce_to_fail env isevars hj c1
+ pi1 (inh_conv_coerce_to_fail loc env' isevars None t t')
with NoCoercion ->
- error_cant_apply_bad_type_loc apploc env sigma
- (1,c1,hj.uj_type) resj (List.map snd restjl) in
- let newresj =
- { uj_val = applist (j_val resj, [j_val hj']);
- uj_type = subst1 hj'.uj_val c2 } in
- apply_rec (push_rel (na,None,c1) env) (n+1) newresj restjl
- | _ ->
- error_cant_apply_not_functional_loc
- (join_loc funloc loc) env sigma resj
- (List.map snd restjl)
- in
- apply_rec env 1 funj argjl
-
+ isevars) (* Maybe not enough information to unify *)
+ (*let sigma = evars_of isevars in
+ error_cannot_coerce env' sigma (t, t'))*)
+ else isevars
+ with Invalid_argument _ -> isevars *)
+end
diff --git a/pretyping/coercion.mli b/pretyping/coercion.mli
index 658844eb..f675beff 100644
--- a/pretyping/coercion.mli
+++ b/pretyping/coercion.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: coercion.mli,v 1.20.14.2 2004/07/16 19:30:44 herbelin Exp $ i*)
+(*i $Id: coercion.mli 8688 2006-04-07 15:08:12Z msozeau $ i*)
(*i*)
open Util
@@ -19,28 +19,38 @@ open Evarutil
open Rawterm
(*i*)
-(*s Coercions. *)
+module type S = sig
+ (*s Coercions. *)
+
+ (* [inh_app_fun env isevars j] coerces [j] to a function; i.e. it
+ inserts a coercion into [j], if needed, in such a way it gets as
+ type a product; it returns [j] if no coercion is applicable *)
+ val inh_app_fun :
+ env -> evar_defs -> unsafe_judgment -> evar_defs * unsafe_judgment
+
+ (* [inh_coerce_to_sort env isevars j] coerces [j] to a type; i.e. it
+ inserts a coercion into [j], if needed, in such a way it gets as
+ type a sort; it fails if no coercion is applicable *)
+ val inh_coerce_to_sort : loc ->
+ env -> evar_defs -> unsafe_judgment -> evar_defs * unsafe_type_judgment
+
+ (* [inh_conv_coerce_to loc env isevars j t] coerces [j] to an object of type
+ [t]; i.e. it inserts a coercion into [j], if needed, in such a way [t] and
+ [j.uj_type] are convertible; it fails if no coercion is applicable *)
+ val inh_conv_coerce_to : loc ->
+ env -> evar_defs -> unsafe_judgment -> type_constraint_type -> evar_defs * unsafe_judgment
-(* [inh_app_fun env isevars j] coerces [j] to a function; i.e. it
- inserts a coercion into [j], if needed, in such a way it gets as
- type a product; it returns [j] if no coercion is applicable *)
-val inh_app_fun :
- env -> evar_defs -> unsafe_judgment -> unsafe_judgment
+ (* [inh_conv_coerces_to loc env isevars t t'] checks if an object of type [t]
+ is coercible to an object of type [t'] adding evar constraints if needed;
+ it fails if no coercion exists *)
+ val inh_conv_coerces_to : loc ->
+ env -> evar_defs -> types -> type_constraint_type -> evar_defs
+
+ (* [inh_pattern_coerce_to loc env isevars pat ind1 ind2] coerces the Cases
+ pattern [pat] typed in [ind1] into a pattern typed in [ind2];
+ raises [Not_found] if no coercion found *)
+ val inh_pattern_coerce_to :
+ loc -> cases_pattern -> inductive -> inductive -> cases_pattern
+end
-(* [inh_coerce_to_sort env isevars j] coerces [j] to a type; i.e. it
- inserts a coercion into [j], if needed, in such a way it gets as
- type a sort; it fails if no coercion is applicable *)
-val inh_coerce_to_sort :
- env -> evar_defs -> unsafe_judgment -> unsafe_type_judgment
-
-(* [inh_conv_coerce_to loc env isevars j t] coerces [j] to an object of type
- [t]; i.e. it inserts a coercion into [j], if needed, in such a way [t] and
- [j.uj_type] are convertible; it fails if no coercion is applicable *)
-val inh_conv_coerce_to : loc ->
- env -> evar_defs -> unsafe_judgment -> constr -> unsafe_judgment
-
-(* [inh_pattern_coerce_to loc env isevars pat ind1 ind2] coerces the Cases
- pattern [pat] typed in [ind1] into a pattern typed in [ind2];
- raises [Not_found] if no coercion found *)
-val inh_pattern_coerce_to :
- loc -> cases_pattern -> inductive -> inductive -> cases_pattern
+module Default : S
diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml
index 040a185e..3f2aed34 100644
--- a/pretyping/detyping.ml
+++ b/pretyping/detyping.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: detyping.ml,v 1.75.2.5 2005/09/06 14:30:41 herbelin Exp $ *)
+(* $Id: detyping.ml 8624 2006-03-13 17:38:17Z msozeau $ *)
open Pp
open Util
@@ -23,6 +23,10 @@ open Nameops
open Termops
open Libnames
open Nametab
+open Evd
+open Mod_subst
+
+let dl = dummy_loc
(****************************************************************************)
(* Tools for printing of Cases *)
@@ -130,11 +134,21 @@ let synthetize_type () = !synth_type_value
let _ = declare_bool_option
{ optsync = true;
- optname = "synthesizability";
+ optname = "pattern matching return type synthesizability";
optkey = SecondaryTable ("Printing","Synth");
optread = synthetize_type;
optwrite = (:=) synth_type_value }
+let reverse_matching_value = ref true
+let reverse_matching () = !reverse_matching_value
+
+let _ = declare_bool_option
+ { optsync = true;
+ optname = "pattern-matching reversibility";
+ optkey = SecondaryTable ("Printing","Matching");
+ optread = reverse_matching;
+ optwrite = (:=) reverse_matching_value }
+
(* Auxiliary function for MutCase printing *)
(* [computable] tries to tell if the predicate typing the result is inferable*)
@@ -175,7 +189,7 @@ let lookup_name_as_renamed env t s =
if id=s then (Some n)
else lookup avoid' (add_name (Name id) env_names) (n+1) c'
| (Anonymous,avoid') -> lookup avoid' env_names (n+1) (pop c'))
- | Cast (c,_) -> lookup avoid env_names n c
+ | Cast (c,_,_) -> lookup avoid env_names n c
| _ -> None
in lookup (ids_of_named_context (named_context env)) empty_names_context 1 t
@@ -189,10 +203,65 @@ let lookup_index_as_renamed env t n =
(match concrete_name true [] empty_names_context name c' with
| (Name _,_) -> lookup n (d+1) c'
| (Anonymous,_) -> if n=1 then Some d else lookup (n-1) (d+1) c')
- | Cast (c,_) -> lookup n d c
+ | Cast (c,_,_) -> lookup n d c
| _ -> None
in lookup n 1 t
+(**********************************************************************)
+(* Fragile algorithm to reverse pattern-matching compilation *)
+
+let update_name na ((_,e),c) =
+ match na with
+ | Name _ when force_wildcard () & noccurn (list_index na e) c ->
+ Anonymous
+ | _ ->
+ na
+
+let rec decomp_branch n nal b (avoid,env as e) c =
+ if n=0 then (List.rev nal,(e,c))
+ else
+ let na,c,f =
+ match kind_of_term (strip_outer_cast c) with
+ | Lambda (na,_,c) -> na,c,concrete_let_name
+ | LetIn (na,_,_,c) -> na,c,concrete_name
+ | _ ->
+ Name (id_of_string "x"),(applist (lift 1 c, [mkRel 1])),
+ concrete_name in
+ let na',avoid' = f b avoid env na c in
+ decomp_branch (n-1) (na'::nal) b (avoid',add_name na' env) c
+
+let rec build_tree na isgoal e ci cl =
+ let mkpat n rhs pl = PatCstr(dl,(ci.ci_ind,n+1),pl,update_name na rhs) in
+ let cnl = ci.ci_cstr_nargs in
+ List.flatten
+ (list_tabulate (fun i -> contract_branch isgoal e (cnl.(i),mkpat i,cl.(i)))
+ (Array.length cl))
+
+and align_tree nal isgoal (e,c as rhs) = match nal with
+ | [] -> [[],rhs]
+ | na::nal ->
+ match kind_of_term c with
+ | Case (ci,_,c,cl) when c = mkRel (list_index na (snd e)) ->
+ let clauses = build_tree na isgoal e ci cl in
+ List.flatten
+ (List.map (fun (pat,rhs) ->
+ let lines = align_tree nal isgoal rhs in
+ List.map (fun (hd,rest) -> pat::hd,rest) lines)
+ clauses)
+ | _ ->
+ let pat = PatVar(dl,update_name na rhs) in
+ let mat = align_tree nal isgoal rhs in
+ List.map (fun (hd,rest) -> pat::hd,rest) mat
+
+and contract_branch isgoal e (cn,mkpat,b) =
+ let nal,rhs = decomp_branch cn [] isgoal e b in
+ let mat = align_tree nal isgoal rhs in
+ List.map (fun (hd,rhs) -> (mkpat rhs hd,rhs)) mat
+
+(**********************************************************************)
+(* Transform internal representation of pattern-matching into list of *)
+(* clauses *)
+
let is_nondep_branch c n =
try
let _,ccl = decompose_lam_n_assum n c in
@@ -208,26 +277,17 @@ let extract_nondep_branches test c b n =
| _ -> assert false in
if test c n then Some (strip n b) else None
-let detype_case computable detype detype_eqn testdep
- tenv avoid indsp st p k c bl =
+let detype_case computable detype detype_eqns testdep avoid data p c bl =
+ let (indsp,st,nparams,consnargsl,k) = data in
let synth_type = synthetize_type () in
let tomatch = detype c in
-
- (* Find constructors arity *)
- let (mib,mip) = Inductive.lookup_mind_specif tenv indsp in
- let get_consnarg j =
- let typi = mis_nf_constructor_type (indsp,mib,mip) (j+1) in
- let _,t = decompose_prod_n_assum (List.length mip.mind_params_ctxt) typi in
- List.rev (fst (decompose_prod_assum t)) in
- let consnargs = Array.init (Array.length mip.mind_consnames) get_consnarg in
- let consnargsl = Array.map List.length consnargs in
- let alias, aliastyp, newpred, pred =
- if (not !Options.raw_print) & synth_type & computable & bl <> [||] then
- Anonymous, None, None, None
+ let alias, aliastyp, pred=
+ if (not !Options.raw_print) & synth_type & computable & Array.length bl<>0
+ then
+ Anonymous, None, None
else
- let p = option_app detype p in
- match p with
- | None -> Anonymous, None, None, None
+ match option_app detype p with
+ | None -> Anonymous, None, None
| Some p ->
let decompose_lam k c =
let rec lamdec_rec l avoid k c =
@@ -237,10 +297,10 @@ let detype_case computable detype detype_eqn testdep
| c ->
let x = next_ident_away (id_of_string "x") avoid in
lamdec_rec ((Name x)::l) (x::avoid) (k-1)
- (let a = RVar (dummy_loc,x) in
+ (let a = RVar (dl,x) in
match c with
| RApp (loc,p,l) -> RApp (loc,p,l@[a])
- | _ -> (RApp (dummy_loc,c,[a])))
+ | _ -> (RApp (dl,c,[a])))
in
lamdec_rec [] [] k c in
let nl,typ = decompose_lam k p in
@@ -250,13 +310,12 @@ let detype_case computable detype detype_eqn testdep
let aliastyp =
if List.for_all ((=) Anonymous) nl then None
else
- let pars = list_tabulate (fun _ -> Anonymous) mip.mind_nparams
- in Some (dummy_loc,indsp,pars@nl) in
- n, aliastyp, Some typ, Some p
+ let pars = list_tabulate (fun _ -> Anonymous) nparams in
+ Some (dl,indsp,pars@nl) in
+ n, aliastyp, Some typ
in
let constructs = Array.init (Array.length bl) (fun i -> (indsp,i+1)) in
- let eqnv = array_map3 detype_eqn constructs consnargsl bl in
- let eqnl = Array.to_list eqnv in
+ let eqnl = detype_eqns constructs consnargsl bl in
let tag =
try
if !Options.raw_print then
@@ -268,12 +327,10 @@ let detype_case computable detype detype_eqn testdep
else
st
with Not_found -> st
- in
- if tag = RegularStyle then
- RCases (dummy_loc,(pred,ref newpred),[tomatch,ref (alias,aliastyp)],eqnl)
- else
- let bl' = Array.map detype bl in
- if not !Options.v7 && tag = LetStyle && aliastyp = None then
+ in
+ match tag with
+ | LetStyle when aliastyp = None ->
+ let bl' = Array.map detype bl in
let rec decomp_lam_force n avoid l p =
if n = 0 then (List.rev l,p) else
match p with
@@ -285,91 +342,75 @@ let detype_case computable detype detype_eqn testdep
let x = Nameops.next_ident_away (id_of_string "x") avoid in
decomp_lam_force (n-1) (x::avoid) (Name x :: l)
(* eta-expansion *)
- (let a = RVar (dummy_loc,x) in
+ (let a = RVar (dl,x) in
match p with
| RApp (loc,p,l) -> RApp (loc,p,l@[a])
- | _ -> (RApp (dummy_loc,p,[a]))) in
+ | _ -> (RApp (dl,p,[a]))) in
let (nal,d) = decomp_lam_force consnargsl.(0) avoid [] bl'.(0) in
- RLetTuple (dummy_loc,nal,(alias,newpred),tomatch,d)
- else
- let nondepbrs =
- array_map3 (extract_nondep_branches testdep) bl bl' consnargsl in
- if not !Options.v7 && tag = IfStyle && aliastyp = None
- && array_for_all ((<>) None) nondepbrs then
- RIf (dummy_loc,tomatch,(alias,newpred),
- out_some nondepbrs.(0),out_some nondepbrs.(1))
- else if !Options.v7 then
- let rec remove_type avoid args c =
- match c,args with
- | RLambda (loc,na,t,c), _::args ->
- let h = RHole (dummy_loc,BinderType na) in
- RLambda (loc,na,h,remove_type avoid args c)
- | RLetIn (loc,na,b,c), _::args ->
- RLetIn (loc,na,b,remove_type avoid args c)
- | c, (na,None,t)::args ->
- let id = next_name_away_with_default "x" na avoid in
- let h = RHole (dummy_loc,BinderType na) in
- let c = remove_type (id::avoid) args
- (RApp (dummy_loc,c,[RVar (dummy_loc,id)])) in
- RLambda (dummy_loc,Name id,h,c)
- | c, (na,Some b,t)::args ->
- let h = RHole (dummy_loc,BinderType na) in
- let avoid = name_fold (fun x l -> x::l) na avoid in
- RLetIn (dummy_loc,na,h,remove_type avoid args c)
- | c, [] -> c in
- let bl' = array_map2 (remove_type avoid) consnargs bl' in
- ROrderedCase (dummy_loc,tag,pred,tomatch,bl',ref None)
- else
- RCases(dummy_loc,(pred,ref newpred),[tomatch,ref (alias,aliastyp)],eqnl)
-
-
-let rec detype tenv avoid env t =
+ RLetTuple (dl,nal,(alias,pred),tomatch,d)
+ | IfStyle when aliastyp = None ->
+ let bl' = Array.map detype bl in
+ let nondepbrs =
+ array_map3 (extract_nondep_branches testdep) bl bl' consnargsl in
+ if array_for_all ((<>) None) nondepbrs then
+ RIf (dl,tomatch,(alias,pred),
+ out_some nondepbrs.(0),out_some nondepbrs.(1))
+ else
+ RCases (dl,pred,[tomatch,(alias,aliastyp)],eqnl)
+ | _ ->
+ RCases (dl,pred,[tomatch,(alias,aliastyp)],eqnl)
+
+(**********************************************************************)
+(* Main detyping function *)
+
+let rec detype isgoal avoid env t =
match kind_of_term (collapse_appl t) with
| Rel n ->
(try match lookup_name_of_rel n env with
- | Name id -> RVar (dummy_loc, id)
+ | Name id -> RVar (dl, id)
| Anonymous -> anomaly "detype: index to an anonymous variable"
with Not_found ->
let s = "_UNBOUND_REL_"^(string_of_int n)
- in RVar (dummy_loc, id_of_string s))
+ in RVar (dl, id_of_string s))
| Meta n ->
(* Meta in constr are not user-parsable and are mapped to Evar *)
- REvar (dummy_loc, n, None)
+ REvar (dl, n, None)
| Var id ->
(try
- let _ = Global.lookup_named id in RRef (dummy_loc, VarRef id)
+ let _ = Global.lookup_named id in RRef (dl, VarRef id)
with _ ->
- RVar (dummy_loc, id))
- | Sort (Prop c) -> RSort (dummy_loc,RProp c)
- | Sort (Type u) -> RSort (dummy_loc,RType (Some u))
- | Cast (c1,c2) ->
- RCast(dummy_loc,detype tenv avoid env c1,
- detype tenv avoid env c2)
- | Prod (na,ty,c) -> detype_binder tenv BProd avoid env na ty c
- | Lambda (na,ty,c) -> detype_binder tenv BLambda avoid env na ty c
- | LetIn (na,b,_,c) -> detype_binder tenv BLetIn avoid env na b c
+ RVar (dl, id))
+ | Sort (Prop c) -> RSort (dl,RProp c)
+ | Sort (Type u) -> RSort (dl,RType (Some u))
+ | Cast (c1,k,c2) ->
+ RCast(dl,detype isgoal avoid env c1, k,
+ detype isgoal avoid env c2)
+ | Prod (na,ty,c) -> detype_binder isgoal BProd avoid env na ty c
+ | Lambda (na,ty,c) -> detype_binder isgoal BLambda avoid env na ty c
+ | LetIn (na,b,_,c) -> detype_binder isgoal BLetIn avoid env na b c
| App (f,args) ->
- RApp (dummy_loc,detype tenv avoid env f,
- array_map_to_list (detype tenv avoid env) args)
- | Const sp -> RRef (dummy_loc, ConstRef sp)
+ RApp (dl,detype isgoal avoid env f,
+ array_map_to_list (detype isgoal avoid env) args)
+ | Const sp -> RRef (dl, ConstRef sp)
| Evar (ev,cl) ->
- REvar (dummy_loc, ev,
- Some (List.map (detype tenv avoid env) (Array.to_list cl)))
+ REvar (dl, ev,
+ Some (List.map (detype isgoal avoid env) (Array.to_list cl)))
| Ind ind_sp ->
- RRef (dummy_loc, IndRef ind_sp)
+ RRef (dl, IndRef ind_sp)
| Construct cstr_sp ->
- RRef (dummy_loc, ConstructRef cstr_sp)
- | Case (annot,p,c,bl) ->
- let comp = computable p (annot.ci_pp_info.ind_nargs) in
- let ind = annot.ci_ind in
- let st = annot.ci_pp_info.style in
- detype_case comp (detype tenv avoid env) (detype_eqn tenv avoid env)
- is_nondep_branch
- (snd tenv) avoid ind st (Some p) annot.ci_pp_info.ind_nargs c bl
- | Fix (nvn,recdef) -> detype_fix tenv avoid env nvn recdef
- | CoFix (n,recdef) -> detype_cofix tenv avoid env n recdef
-
-and detype_fix tenv avoid env (vn,_ as nvn) (names,tys,bodies) =
+ RRef (dl, ConstructRef cstr_sp)
+ | Case (ci,p,c,bl) ->
+ let comp = computable p (ci.ci_pp_info.ind_nargs) in
+ detype_case comp (detype isgoal avoid env)
+ (detype_eqns isgoal avoid env ci comp)
+ is_nondep_branch avoid
+ (ci.ci_ind,ci.ci_pp_info.style,ci.ci_npar,
+ ci.ci_cstr_nargs,ci.ci_pp_info.ind_nargs)
+ (Some p) c bl
+ | Fix (nvn,recdef) -> detype_fix isgoal avoid env nvn recdef
+ | CoFix (n,recdef) -> detype_cofix isgoal avoid env n recdef
+
+and detype_fix isgoal avoid env (vn,_ as nvn) (names,tys,bodies) =
let def_avoid, def_env, lfi =
Array.fold_left
(fun (avoid, env, l) na ->
@@ -378,14 +419,14 @@ and detype_fix tenv avoid env (vn,_ as nvn) (names,tys,bodies) =
(avoid, env, []) names in
let n = Array.length tys in
let v = array_map3
- (fun c t i -> share_names tenv (i+1) [] def_avoid def_env c (lift n t))
+ (fun c t i -> share_names isgoal (i+1) [] def_avoid def_env c (lift n t))
bodies tys vn in
- RRec(dummy_loc,RFix nvn,Array.of_list (List.rev lfi),
+ RRec(dl,RFix (Array.map (fun i -> i, RStructRec) (fst nvn), snd nvn),Array.of_list (List.rev lfi),
Array.map (fun (bl,_,_) -> bl) v,
Array.map (fun (_,_,ty) -> ty) v,
Array.map (fun (_,bd,_) -> bd) v)
-and detype_cofix tenv avoid env n (names,tys,bodies) =
+and detype_cofix isgoal avoid env n (names,tys,bodies) =
let def_avoid, def_env, lfi =
Array.fold_left
(fun (avoid, env, l) na ->
@@ -394,19 +435,14 @@ and detype_cofix tenv avoid env n (names,tys,bodies) =
(avoid, env, []) names in
let ntys = Array.length tys in
let v = array_map2
- (fun c t -> share_names tenv 0 [] def_avoid def_env c (lift ntys t))
+ (fun c t -> share_names isgoal 0 [] def_avoid def_env c (lift ntys t))
bodies tys in
- RRec(dummy_loc,RCoFix n,Array.of_list (List.rev lfi),
+ RRec(dl,RCoFix n,Array.of_list (List.rev lfi),
Array.map (fun (bl,_,_) -> bl) v,
Array.map (fun (_,_,ty) -> ty) v,
Array.map (fun (_,bd,_) -> bd) v)
-and share_names tenv n l avoid env c t =
- if !Options.v7 && n=0 then
- let c = detype tenv avoid env c in
- let t = detype tenv avoid env t in
- (List.rev l,c,t)
- else
+and share_names isgoal n l avoid env c t =
match kind_of_term c, kind_of_term t with
(* factorize even when not necessary to have better presentation *)
| Lambda (na,t,c), Prod (na',t',c') ->
@@ -414,47 +450,57 @@ and share_names tenv n l avoid env c t =
Name _, _ -> na
| _, Name _ -> na'
| _ -> na in
- let t = detype tenv avoid env t in
+ let t = detype isgoal avoid env t in
let id = next_name_away na avoid in
let avoid = id::avoid and env = add_name (Name id) env in
- share_names tenv (n-1) ((Name id,None,t)::l) avoid env c c'
+ share_names isgoal (n-1) ((Name id,None,t)::l) avoid env c c'
(* May occur for fix built interactively *)
| LetIn (na,b,t',c), _ when n > 0 ->
- let t' = detype tenv avoid env t' in
- let b = detype tenv avoid env b in
+ let t' = detype isgoal avoid env t' in
+ let b = detype isgoal avoid env b in
let id = next_name_away na avoid in
let avoid = id::avoid and env = add_name (Name id) env in
- share_names tenv n ((Name id,Some b,t')::l) avoid env c t
+ share_names isgoal n ((Name id,Some b,t')::l) avoid env c t
(* Only if built with the f/n notation or w/o let-expansion in types *)
| _, LetIn (_,b,_,t) when n > 0 ->
- share_names tenv n l avoid env c (subst1 b t)
+ share_names isgoal n l avoid env c (subst1 b t)
(* If it is an open proof: we cheat and eta-expand *)
| _, Prod (na',t',c') when n > 0 ->
- let t' = detype tenv avoid env t' in
+ let t' = detype isgoal avoid env t' in
let id = next_name_away na' avoid in
let avoid = id::avoid and env = add_name (Name id) env in
let appc = mkApp (lift 1 c,[|mkRel 1|]) in
- share_names tenv (n-1) ((Name id,None,t')::l) avoid env appc c'
+ share_names isgoal (n-1) ((Name id,None,t')::l) avoid env appc c'
(* If built with the f/n notation: we renounce to share names *)
| _ ->
if n>0 then warning "Detyping.detype: cannot factorize fix enough";
- let c = detype tenv avoid env c in
- let t = detype tenv avoid env t in
+ let c = detype isgoal avoid env c in
+ let t = detype isgoal avoid env t in
(List.rev l,c,t)
-and detype_eqn tenv avoid env constr construct_nargs branch =
+and detype_eqns isgoal avoid env ci computable constructs consnargsl bl =
+ try
+ if !Options.raw_print or not (reverse_matching ()) then raise Exit;
+ let mat = build_tree Anonymous isgoal (avoid,env) ci bl in
+ List.map (fun (pat,((avoid,env),c)) -> (dl,[],[pat],detype isgoal avoid env c))
+ mat
+ with _ ->
+ Array.to_list
+ (array_map3 (detype_eqn isgoal avoid env) constructs consnargsl bl)
+
+and detype_eqn isgoal avoid env constr construct_nargs branch =
let make_pat x avoid env b ids =
if force_wildcard () & noccurn 1 b then
- PatVar (dummy_loc,Anonymous),avoid,(add_name Anonymous env),ids
- else
+ PatVar (dl,Anonymous),avoid,(add_name Anonymous env),ids
+ else
let id = next_name_away_with_default "x" x avoid in
- PatVar (dummy_loc,Name id),id::avoid,(add_name (Name id) env),id::ids
+ PatVar (dl,Name id),id::avoid,(add_name (Name id) env),id::ids
in
let rec buildrec ids patlist avoid env n b =
if n=0 then
- (dummy_loc, ids,
- [PatCstr(dummy_loc, constr, List.rev patlist,Anonymous)],
- detype tenv avoid env b)
+ (dl, ids,
+ [PatCstr(dl, constr, List.rev patlist,Anonymous)],
+ detype isgoal avoid env b)
else
match kind_of_term b with
| Lambda (x,_,b) ->
@@ -465,7 +511,7 @@ and detype_eqn tenv avoid env constr construct_nargs branch =
let pat,new_avoid,new_env,new_ids = make_pat x avoid env b ids in
buildrec new_ids (pat::patlist) new_avoid new_env (n-1) b
- | Cast (c,_) -> (* Oui, il y a parfois des cast *)
+ | Cast (c,_,_) -> (* Oui, il y a parfois des cast *)
buildrec ids patlist avoid env n c
| _ -> (* eta-expansion : n'arrivera plus lorsque tous les
@@ -479,14 +525,123 @@ and detype_eqn tenv avoid env constr construct_nargs branch =
in
buildrec [] [] avoid env construct_nargs branch
-and detype_binder tenv bk avoid env na ty c =
+and detype_binder isgoal bk avoid env na ty c =
let na',avoid' =
if bk = BLetIn then
- concrete_let_name (fst tenv) avoid env na c
+ concrete_let_name isgoal avoid env na c
else
- concrete_name (fst tenv) avoid env na c in
- let r = detype tenv avoid' (add_name na' env) c in
+ concrete_name isgoal avoid env na c in
+ let r = detype isgoal avoid' (add_name na' env) c in
match bk with
- | BProd -> RProd (dummy_loc, na',detype tenv avoid env ty, r)
- | BLambda -> RLambda (dummy_loc, na',detype tenv avoid env ty, r)
- | BLetIn -> RLetIn (dummy_loc, na',detype tenv avoid env ty, r)
+ | BProd -> RProd (dl, na',detype isgoal avoid env ty, r)
+ | BLambda -> RLambda (dl, na',detype isgoal avoid env ty, r)
+ | BLetIn -> RLetIn (dl, na',detype isgoal avoid env ty, r)
+
+(**********************************************************************)
+(* Module substitution: relies on detyping *)
+
+let rec subst_cases_pattern subst pat =
+ match pat with
+ | PatVar _ -> pat
+ | PatCstr (loc,((kn,i),j),cpl,n) ->
+ let kn' = subst_kn subst kn
+ and cpl' = list_smartmap (subst_cases_pattern subst) cpl in
+ if kn' == kn && cpl' == cpl then pat else
+ PatCstr (loc,((kn',i),j),cpl',n)
+
+let rec subst_rawconstr subst raw =
+ match raw with
+ | RRef (loc,ref) ->
+ let ref',t = subst_global subst ref in
+ if ref' == ref then raw else
+ detype false [] [] t
+
+ | RVar _ -> raw
+ | REvar _ -> raw
+ | RPatVar _ -> raw
+
+ | RApp (loc,r,rl) ->
+ let r' = subst_rawconstr subst r
+ and rl' = list_smartmap (subst_rawconstr subst) rl in
+ if r' == r && rl' == rl then raw else
+ RApp(loc,r',rl')
+
+ | RLambda (loc,n,r1,r2) ->
+ let r1' = subst_rawconstr subst r1 and r2' = subst_rawconstr subst r2 in
+ if r1' == r1 && r2' == r2 then raw else
+ RLambda (loc,n,r1',r2')
+
+ | RProd (loc,n,r1,r2) ->
+ let r1' = subst_rawconstr subst r1 and r2' = subst_rawconstr subst r2 in
+ if r1' == r1 && r2' == r2 then raw else
+ RProd (loc,n,r1',r2')
+
+ | RLetIn (loc,n,r1,r2) ->
+ let r1' = subst_rawconstr subst r1 and r2' = subst_rawconstr subst r2 in
+ if r1' == r1 && r2' == r2 then raw else
+ RLetIn (loc,n,r1',r2')
+
+ | RCases (loc,rtno,rl,branches) ->
+ let rtno' = option_smartmap (subst_rawconstr subst) rtno
+ and rl' = list_smartmap (fun (a,x as y) ->
+ let a' = subst_rawconstr subst a in
+ let (n,topt) = x in
+ let topt' = option_smartmap
+ (fun (loc,(sp,i),x as t) ->
+ let sp' = subst_kn subst sp in
+ if sp == sp' then t else (loc,(sp',i),x)) topt in
+ if a == a' && topt == topt' then y else (a',(n,topt'))) rl
+ and branches' = list_smartmap
+ (fun (loc,idl,cpl,r as branch) ->
+ let cpl' =
+ list_smartmap (subst_cases_pattern subst) cpl
+ and r' = subst_rawconstr subst r in
+ if cpl' == cpl && r' == r then branch else
+ (loc,idl,cpl',r'))
+ branches
+ in
+ if rtno' == rtno && rl' == rl && branches' == branches then raw else
+ RCases (loc,rtno',rl',branches')
+
+ | RLetTuple (loc,nal,(na,po),b,c) ->
+ let po' = option_smartmap (subst_rawconstr subst) po
+ and b' = subst_rawconstr subst b
+ and c' = subst_rawconstr subst c in
+ if po' == po && b' == b && c' == c then raw else
+ RLetTuple (loc,nal,(na,po'),b',c')
+
+ | RIf (loc,c,(na,po),b1,b2) ->
+ let po' = option_smartmap (subst_rawconstr subst) po
+ and b1' = subst_rawconstr subst b1
+ and b2' = subst_rawconstr subst b2
+ and c' = subst_rawconstr subst c in
+ if c' == c & po' == po && b1' == b1 && b2' == b2 then raw else
+ RIf (loc,c',(na,po'),b1',b2')
+
+ | RRec (loc,fix,ida,bl,ra1,ra2) ->
+ let ra1' = array_smartmap (subst_rawconstr subst) ra1
+ and ra2' = array_smartmap (subst_rawconstr subst) ra2 in
+ let bl' = array_smartmap
+ (list_smartmap (fun (na,obd,ty as dcl) ->
+ let ty' = subst_rawconstr subst ty in
+ let obd' = option_smartmap (subst_rawconstr subst) obd in
+ if ty'==ty & obd'==obd then dcl else (na,obd',ty')))
+ bl in
+ if ra1' == ra1 && ra2' == ra2 && bl'==bl then raw else
+ RRec (loc,fix,ida,bl',ra1',ra2')
+
+ | RSort _ -> raw
+
+ | RHole (loc,ImplicitArg (ref,i)) ->
+ let ref',_ = subst_global subst ref in
+ if ref' == ref then raw else
+ RHole (loc,InternalHole)
+ | RHole (loc, (BinderType _ | QuestionMark | CasesType |
+ InternalHole | TomatchTypeParameter _)) -> raw
+
+ | RCast (loc,r1,k,r2) ->
+ let r1' = subst_rawconstr subst r1 and r2' = subst_rawconstr subst r2 in
+ if r1' == r1 && r2' == r2 then raw else
+ RCast (loc,r1',k,r2')
+
+ | RDynamic _ -> raw
diff --git a/pretyping/detyping.mli b/pretyping/detyping.mli
index c2a70928..0b35728c 100644
--- a/pretyping/detyping.mli
+++ b/pretyping/detyping.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: detyping.mli,v 1.13.2.2 2004/07/16 19:30:44 herbelin Exp $ i*)
+(*i $Id: detyping.mli 7881 2006-01-16 14:03:05Z herbelin $ i*)
(*i*)
open Util
@@ -16,20 +16,27 @@ open Sign
open Environ
open Rawterm
open Termops
+open Mod_subst
(*i*)
-(* [detype env avoid nenv c] turns [c], typed in [env], into a rawconstr. *)
-(* De Bruijn indexes are turned to bound names, avoiding names in [avoid] *)
+val subst_cases_pattern : substitution -> cases_pattern -> cases_pattern
-val detype : bool * env -> identifier list -> names_context -> constr ->
- rawconstr
+val subst_rawconstr : substitution -> rawconstr -> rawconstr
+
+(* [detype isgoal avoid ctx c] turns a closed [c], into a rawconstr *)
+(* de Bruijn indexes are turned to bound names, avoiding names in [avoid] *)
+(* [isgoal] tells if naming must avoid global-level synonyms as intro does *)
+(* [ctx] gives the names of the free variables *)
+
+val detype : bool -> identifier list -> names_context -> constr -> rawconstr
val detype_case :
bool -> ('a -> rawconstr) ->
- (constructor -> int -> 'a -> loc * identifier list * cases_pattern list *
- rawconstr) -> ('a -> int -> bool) ->
- env -> identifier list -> inductive -> case_style ->
- 'a option -> int -> 'a -> 'a array -> rawconstr
+ (constructor array -> int array -> 'a array ->
+ (loc * identifier list * cases_pattern list * rawconstr) list) ->
+ ('a -> int -> bool) ->
+ identifier list -> inductive * case_style * int * int array * int ->
+ 'a option -> 'a -> 'a array -> rawconstr
(* look for the index of a named var or a nondep var as it is renamed *)
val lookup_name_as_renamed : env -> constr -> identifier -> int option
diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml
index 2264f82b..2b04b693 100644
--- a/pretyping/evarconv.ml
+++ b/pretyping/evarconv.ml
@@ -6,20 +6,21 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: evarconv.ml,v 1.44.6.3 2005/11/29 21:40:52 letouzey Exp $ *)
+(* $Id: evarconv.ml 8111 2006-03-02 17:23:41Z herbelin $ *)
open Util
open Names
open Term
+open Reduction
open Reductionops
open Closure
-open Instantiate
open Environ
open Typing
open Classops
open Recordops
open Evarutil
open Libnames
+open Evd
type flex_kind_of_term =
| Rigid of constr
@@ -69,7 +70,7 @@ let evar_apprec_nobeta env isevars stack c =
let (t,stack as s') = apprec_nobeta env (evars_of isevars) s in
match kind_of_term t with
| Evar (n,_ as ev) when Evd.is_defined (evars_of isevars) n ->
- aux (existential_value (evars_of isevars) ev, stack)
+ aux (Evd.existential_value (evars_of isevars) ev, stack)
| _ -> (t, list_of_stack stack)
in aux (c, append_stack (Array.of_list stack) empty_stack)
*)
@@ -77,10 +78,10 @@ let evar_apprec_nobeta env isevars stack c =
let evar_apprec env isevars stack c =
let sigma = evars_of isevars in
let rec aux s =
- let (t,stack as s') = Reductionops.apprec env sigma s in
+ let (t,stack) = Reductionops.apprec env sigma s in
match kind_of_term t with
| Evar (n,_ as ev) when Evd.is_defined sigma n ->
- aux (existential_value sigma ev, stack)
+ aux (Evd.existential_value sigma ev, stack)
| _ -> (t, list_of_stack stack)
in aux (c, append_stack (Array.of_list stack) empty_stack)
@@ -99,11 +100,11 @@ let apprec_nohdbeta env isevars c =
(t2 us2) = (cstr us)
extra_args1 = extra_args2
- by finding a record R and an object c := [xs:bs](Build_R a1..am v1..vn)
+ by finding a record R and an object c := [xs:bs](Build_R params v1..vn)
with vi = (cstr us), for which we know that the i-th projection proji
satisfies
- (proji params c) = (cstr us)
+ (proji params (c xs)) = (cstr us)
Rem: such objects, usable for conversion, are defined in the objdef
table; practically, it amounts to "canonically" equip t2 into a
@@ -112,10 +113,10 @@ let apprec_nohdbeta env isevars c =
let check_conv_record (t1,l1) (t2,l2) =
try
- let proji = reference_of_constr t1 in
- let cstr = reference_of_constr t2 in
+ let proji = global_of_constr t1 in
+ let cstr = global_of_constr t2 in
let { o_DEF = c; o_TABS = bs; o_TPARAMS = params; o_TCOMPS = us } =
- objdef_info (proji, cstr) in
+ lookup_canonical_conversion (proji, cstr) in
let params1, c1, extra_args1 =
match list_chop (List.length params) l1 with
| params1, c1::extra_args1 -> params1, c1, extra_args1
@@ -126,9 +127,47 @@ let check_conv_record (t1,l1) (t2,l2) =
raise Not_found
-(* Precondition: one of the terms of the pb is an uninstanciated evar,
+(* Precondition: one of the terms of the pb is an uninstantiated evar,
* possibly applied to arguments. *)
+let rec ise_try isevars = function
+ [] -> assert false
+ | [f] -> f isevars
+ | f1::l ->
+ let (isevars',b) = f1 isevars in
+ if b then (isevars',b) else ise_try isevars l
+
+let ise_and isevars l =
+ let rec ise_and i = function
+ [] -> assert false
+ | [f] -> f i
+ | f1::l ->
+ let (i',b) = f1 i in
+ if b then ise_and i' l else (isevars,false) in
+ ise_and isevars l
+
+let ise_list2 isevars f l1 l2 =
+ let rec ise_list2 i l1 l2 =
+ match l1,l2 with
+ [], [] -> (i, true)
+ | [x], [y] -> f i x y
+ | x::l1, y::l2 ->
+ let (i',b) = f i x y in
+ if b then ise_list2 i' l1 l2 else (isevars,false)
+ | _ -> (isevars, false) in
+ ise_list2 isevars l1 l2
+
+let ise_array2 isevars f v1 v2 =
+ let rec allrec i = function
+ | -1 -> (i,true)
+ | n ->
+ let (i',b) = f i v1.(n) v2.(n) in
+ if b then allrec i' (n-1) else (isevars,false)
+ in
+ let lv1 = Array.length v1 in
+ if lv1 = Array.length v2 then allrec isevars (pred lv1)
+ else (isevars,false)
+
let rec evar_conv_x env isevars pbty term1 term2 =
let sigma = evars_of isevars in
let term1 = whd_castappevar sigma term1 in
@@ -138,15 +177,15 @@ let rec evar_conv_x env isevars pbty term1 term2 =
true
else
*)
- (* Maybe convertible but since reducing can erase evars which [evar_apprec]*)
- (* could have found, we do it only if the terms are free of evar *)
- (not (has_undefined_isevars isevars term1) &
- not (has_undefined_isevars isevars term2) &
- is_fconv pbty env (evars_of isevars) term1 term2)
- or
- if ise_undefined isevars term1 then
+ (* Maybe convertible but since reducing can erase evars which [evar_apprec]
+ could have found, we do it only if the terms are free of evar.
+ Note: incomplete heuristic... *)
+ if is_ground_term isevars term1 && is_ground_term isevars term2 &
+ is_fconv pbty env (evars_of isevars) term1 term2 then
+ (isevars,true)
+ else if is_undefined_evar isevars term1 then
solve_simple_eqn evar_conv_x env isevars (pbty,destEvar term1,term2)
- else if ise_undefined isevars term2 then
+ else if is_undefined_evar isevars term2 then
solve_simple_eqn evar_conv_x env isevars (pbty,destEvar term2,term1)
else
let (t1,l1) = apprec_nohdbeta env isevars term1 in
@@ -154,7 +193,7 @@ let rec evar_conv_x env isevars pbty term1 term2 =
if (head_is_embedded_evar isevars t1 & not(is_eliminator t2))
or (head_is_embedded_evar isevars t2 & not(is_eliminator t1))
then
- (add_conv_pb isevars (pbty,applist(t1,l1),applist(t2,l2)); true)
+ (add_conv_pb (pbty,applist(t1,l1),applist(t2,l2)) isevars, true)
else
evar_eqappr_x env isevars pbty (t1,l1) (t2,l2)
@@ -162,67 +201,81 @@ and evar_eqappr_x env isevars pbty (term1,l1 as appr1) (term2,l2 as appr2) =
(* Evar must be undefined since we have whd_ised *)
match (flex_kind_of_term term1 l1, flex_kind_of_term term2 l2) with
| Flexible (sp1,al1 as ev1), Flexible (sp2,al2 as ev2) ->
- let f1 () =
+ let f1 i =
if List.length l1 > List.length l2 then
let (deb1,rest1) = list_chop (List.length l1-List.length l2) l1 in
- solve_simple_eqn evar_conv_x env isevars
- (pbty,ev2,applist(term1,deb1))
- & list_for_all2eq (evar_conv_x env isevars CONV) rest1 l2
+ ise_and i
+ [(fun i -> solve_simple_eqn evar_conv_x env i
+ (pbty,ev2,applist(term1,deb1)));
+ (fun i -> ise_list2 i
+ (fun i -> evar_conv_x env i CONV) rest1 l2)]
else
let (deb2,rest2) = list_chop (List.length l2-List.length l1) l2 in
- solve_simple_eqn evar_conv_x env isevars
- (pbty,ev1,applist(term2,deb2))
- & list_for_all2eq (evar_conv_x env isevars CONV) l1 rest2
- and f2 () =
- (sp1 = sp2)
- & (array_for_all2 (evar_conv_x env isevars CONV) al1 al2)
- & (list_for_all2eq (evar_conv_x env isevars CONV) l1 l2)
+ ise_and i
+ [(fun i -> solve_simple_eqn evar_conv_x env i
+ (pbty,ev1,applist(term2,deb2)));
+ (fun i -> ise_list2 i
+ (fun i -> evar_conv_x env i CONV) l1 rest2)]
+ and f2 i =
+ if sp1 = sp2 then
+ ise_and i
+ [(fun i -> ise_array2 i
+ (fun i -> evar_conv_x env i CONV) al1 al2);
+ (fun i -> ise_list2 i
+ (fun i -> evar_conv_x env i CONV) l1 l2)]
+ else (i,false)
in
ise_try isevars [f1; f2]
| Flexible ev1, MaybeFlexible flex2 ->
- let f1 () =
- (List.length l1 <= List.length l2) &
- let (deb2,rest2) = list_chop (List.length l2-List.length l1) l2 in
- (* First compare extra args for better failure message *)
- list_for_all2eq (evar_conv_x env isevars CONV) l1 rest2 &
- evar_conv_x env isevars pbty term1 (applist(term2,deb2))
- and f4 () =
+ let f1 i =
+ if List.length l1 <= List.length l2 then
+ let (deb2,rest2) =
+ list_chop (List.length l2-List.length l1) l2 in
+ ise_and i
+ (* First compare extra args for better failure message *)
+ [(fun i -> ise_list2 i
+ (fun i -> evar_conv_x env i CONV) l1 rest2);
+ (fun i -> evar_conv_x env i pbty term1 (applist(term2,deb2)))]
+ else (i,false)
+ and f4 i =
match eval_flexible_term env flex2 with
| Some v2 ->
- evar_eqappr_x env isevars pbty
- appr1 (evar_apprec env isevars l2 v2)
- | None -> false
+ evar_eqappr_x env i pbty appr1 (evar_apprec env i l2 v2)
+ | None -> (i,false)
in
ise_try isevars [f1; f4]
| MaybeFlexible flex1, Flexible ev2 ->
- let f1 () =
- (List.length l2 <= List.length l1) &
- let (deb1,rest1) = list_chop (List.length l1-List.length l2) l1 in
- (* First compare extra args for better failure message *)
- list_for_all2eq (evar_conv_x env isevars CONV) rest1 l2 &
- evar_conv_x env isevars pbty (applist(term1,deb1)) term2
- and f4 () =
+ let f1 i =
+ if List.length l2 <= List.length l1 then
+ let (deb1,rest1) = list_chop (List.length l1-List.length l2) l1 in
+ ise_and i
+ (* First compare extra args for better failure message *)
+ [(fun i -> ise_list2 i
+ (fun i -> evar_conv_x env i CONV) rest1 l2);
+ (fun i -> evar_conv_x env i pbty (applist(term1,deb1)) term2)]
+ else (i,false)
+ and f4 i =
match eval_flexible_term env flex1 with
| Some v1 ->
- evar_eqappr_x env isevars pbty
- (evar_apprec env isevars l1 v1) appr2
- | None -> false
+ evar_eqappr_x env i pbty (evar_apprec env i l1 v1) appr2
+ | None -> (i,false)
in
ise_try isevars [f1; f4]
| MaybeFlexible flex1, MaybeFlexible flex2 ->
- let f2 () =
- (flex1 = flex2)
- & (List.length l1 = List.length l2)
- & (list_for_all2eq (evar_conv_x env isevars CONV) l1 l2)
- and f3 () =
- (try conv_record env isevars
+ let f2 i =
+ if flex1 = flex2 then
+ ise_list2 i (fun i -> evar_conv_x env i CONV) l1 l2
+ else (i,false)
+ and f3 i =
+ (try conv_record env i
(try check_conv_record appr1 appr2
with Not_found -> check_conv_record appr2 appr1)
- with _ -> false)
- and f4 () =
+(* TODO: remove this _ !!! *)
+ with _ -> (i,false))
+ and f4 i =
(* heuristic: unfold second argument first, exception made
if the first argument is a beta-redex (expand a constant
only if necessary) *)
@@ -232,87 +285,98 @@ and evar_eqappr_x env isevars pbty (term1,l1 as appr1) (term2,l2 as appr2) =
| _ -> eval_flexible_term env flex2 in
match val2 with
| Some v2 ->
- evar_eqappr_x env isevars pbty
- appr1 (evar_apprec env isevars l2 v2)
+ evar_eqappr_x env i pbty appr1 (evar_apprec env i l2 v2)
| None ->
match eval_flexible_term env flex1 with
| Some v1 ->
- evar_eqappr_x env isevars pbty
- (evar_apprec env isevars l1 v1) appr2
- | None -> false
+ evar_eqappr_x env i pbty (evar_apprec env i l1 v1) appr2
+ | None -> (i,false)
in
ise_try isevars [f2; f3; f4]
| Flexible ev1, Rigid _ ->
- (List.length l1 <= List.length l2) &
- let (deb2,rest2) = list_chop (List.length l2-List.length l1) l2 in
- (* First compare extra args for better failure message *)
- list_for_all2eq (evar_conv_x env isevars CONV) l1 rest2 &
- solve_simple_eqn evar_conv_x env isevars
- (pbty,ev1,applist(term2,deb2))
-
+ if (List.length l1 <= List.length l2) then
+ let (deb2,rest2) = list_chop (List.length l2-List.length l1) l2 in
+ ise_and isevars
+ (* First compare extra args for better failure message *)
+ [(fun i -> ise_list2 i (fun i -> evar_conv_x env i CONV) l1 rest2);
+ (fun i ->
+ (* Then instantiate evar unless already done by unifying args *)
+ let t2 = applist(term2,deb2) in
+ if is_defined_evar i ev1 then
+ evar_conv_x env i pbty (mkEvar ev1) t2
+ else
+ solve_simple_eqn evar_conv_x env i (pbty,ev1,t2))]
+ else (isevars,false)
| Rigid _, Flexible ev2 ->
- (List.length l2 <= List.length l1) &
- let (deb1,rest1) = list_chop (List.length l1-List.length l2) l1 in
- (* First compare extra args for better failure message *)
- list_for_all2eq (evar_conv_x env isevars CONV) rest1 l2 &
- solve_simple_eqn evar_conv_x env isevars
- (pbty,ev2,applist(term1,deb1))
-
+ if List.length l2 <= List.length l1 then
+ let (deb1,rest1) = list_chop (List.length l1-List.length l2) l1 in
+ ise_and isevars
+ (* First compare extra args for better failure message *)
+ [(fun i -> ise_list2 i (fun i -> evar_conv_x env i CONV) rest1 l2);
+ (fun i ->
+ (* Then instantiate evar unless already done by unifying args *)
+ let t1 = applist(term1,deb1) in
+ if is_defined_evar i ev2 then
+ evar_conv_x env i pbty t1 (mkEvar ev2)
+ else
+ solve_simple_eqn evar_conv_x env i (pbty,ev2,t1))]
+ else (isevars,false)
| MaybeFlexible flex1, Rigid _ ->
- let f3 () =
- (try conv_record env isevars (check_conv_record appr1 appr2)
- with _ -> false)
- and f4 () =
+ let f3 i =
+ (try conv_record env i (check_conv_record appr1 appr2)
+ with _ -> (i,false))
+ and f4 i =
match eval_flexible_term env flex1 with
| Some v1 ->
- evar_eqappr_x env isevars pbty
- (evar_apprec env isevars l1 v1) appr2
- | None -> false
+ evar_eqappr_x env i pbty (evar_apprec env i l1 v1) appr2
+ | None -> (i,false)
in
ise_try isevars [f3; f4]
| Rigid _ , MaybeFlexible flex2 ->
- let f3 () =
- (try (conv_record env isevars (check_conv_record appr2 appr1))
- with _ -> false)
- and f4 () =
+ let f3 i =
+ (try (conv_record env i (check_conv_record appr2 appr1))
+ with _ -> (i,false))
+ and f4 i =
match eval_flexible_term env flex2 with
| Some v2 ->
- evar_eqappr_x env isevars pbty
- appr1 (evar_apprec env isevars l2 v2)
- | None -> false
+ evar_eqappr_x env i pbty appr1 (evar_apprec env i l2 v2)
+ | None -> (i,false)
in
ise_try isevars [f3; f4]
| Rigid c1, Rigid c2 -> match kind_of_term c1, kind_of_term c2 with
- | Cast (c1,_), _ -> evar_eqappr_x env isevars pbty (c1,l1) appr2
+ | Cast (c1,_,_), _ -> evar_eqappr_x env isevars pbty (c1,l1) appr2
- | _, Cast (c2,_) -> evar_eqappr_x env isevars pbty appr1 (c2,l2)
+ | _, Cast (c2,_,_) -> evar_eqappr_x env isevars pbty appr1 (c2,l2)
- | Sort s1, Sort s2 when l1=[] & l2=[] -> base_sort_cmp pbty s1 s2
+ | Sort s1, Sort s2 when l1=[] & l2=[] ->
+ (isevars,base_sort_cmp pbty s1 s2)
| Lambda (na,c1,c'1), Lambda (_,c2,c'2) when l1=[] & l2=[] ->
- evar_conv_x env isevars CONV c1 c2
- &
- (let c = nf_evar (evars_of isevars) c1 in
- evar_conv_x (push_rel (na,None,c) env) isevars CONV c'1 c'2)
+ ise_and isevars
+ [(fun i -> evar_conv_x env i CONV c1 c2);
+ (fun i ->
+ let c = nf_evar (evars_of i) c1 in
+ evar_conv_x (push_rel (na,None,c) env) i CONV c'1 c'2)]
| LetIn (na,b1,t1,c'1), LetIn (_,b2,_,c'2) ->
- let f1 () =
- evar_conv_x env isevars CONV b1 b2
- &
- (let b = nf_evar (evars_of isevars) b1 in
- let t = nf_evar (evars_of isevars) t1 in
- evar_conv_x (push_rel (na,Some b,t) env) isevars pbty c'1 c'2)
- & (List.length l1 = List.length l2)
- & (List.for_all2 (evar_conv_x env isevars CONV) l1 l2)
- and f2 () =
- let appr1 = evar_apprec env isevars l1 (subst1 b1 c'1)
- and appr2 = evar_apprec env isevars l2 (subst1 b2 c'2)
- in evar_eqappr_x env isevars pbty appr1 appr2
+ let f1 i =
+ ise_and i
+ [(fun i -> evar_conv_x env i CONV b1 b2);
+ (fun i ->
+ let b = nf_evar (evars_of i) b1 in
+ let t = nf_evar (evars_of i) t1 in
+ evar_conv_x (push_rel (na,Some b,t) env) i pbty c'1 c'2);
+ (fun i -> ise_list2 i
+ (fun i -> evar_conv_x env i CONV) l1 l2)]
+ and f2 i =
+ let appr1 = evar_apprec env i l1 (subst1 b1 c'1)
+ and appr2 = evar_apprec env i l2 (subst1 b2 c'2)
+ in evar_eqappr_x env i pbty appr1 appr2
in
ise_try isevars [f1; f2]
@@ -325,71 +389,102 @@ and evar_eqappr_x env isevars pbty (term1,l1 as appr1) (term2,l2 as appr2) =
in evar_eqappr_x env isevars pbty appr1 appr2
| Prod (n,c1,c'1), Prod (_,c2,c'2) when l1=[] & l2=[] ->
- evar_conv_x env isevars CONV c1 c2
- &
- (let c = nf_evar (evars_of isevars) c1 in
- evar_conv_x (push_rel (n,None,c) env) isevars pbty c'1 c'2)
+ ise_and isevars
+ [(fun i -> evar_conv_x env i CONV c1 c2);
+ (fun i ->
+ let c = nf_evar (evars_of i) c1 in
+ evar_conv_x (push_rel (n,None,c) env) i pbty c'1 c'2)]
| Ind sp1, Ind sp2 ->
- sp1=sp2
- & list_for_all2eq (evar_conv_x env isevars CONV) l1 l2
-
+ if sp1=sp2 then
+ ise_list2 isevars (fun i -> evar_conv_x env i CONV) l1 l2
+ else (isevars, false)
+
| Construct sp1, Construct sp2 ->
- sp1=sp2
- & list_for_all2eq (evar_conv_x env isevars CONV) l1 l2
+ if sp1=sp2 then
+ ise_list2 isevars (fun i -> evar_conv_x env i CONV) l1 l2
+ else (isevars, false)
| Case (_,p1,c1,cl1), Case (_,p2,c2,cl2) ->
- evar_conv_x env isevars CONV p1 p2
- & evar_conv_x env isevars CONV c1 c2
- & (array_for_all2 (evar_conv_x env isevars CONV) cl1 cl2)
- & (list_for_all2eq (evar_conv_x env isevars CONV) l1 l2)
+ ise_and isevars
+ [(fun i -> evar_conv_x env i CONV p1 p2);
+ (fun i -> evar_conv_x env i CONV c1 c2);
+ (fun i -> ise_array2 i
+ (fun i -> evar_conv_x env i CONV) cl1 cl2);
+ (fun i -> ise_list2 i (fun i -> evar_conv_x env i CONV) l1 l2)]
| Fix (li1,(_,tys1,bds1 as recdef1)), Fix (li2,(_,tys2,bds2)) ->
- li1=li2
- & (array_for_all2 (evar_conv_x env isevars CONV) tys1 tys2)
- & (array_for_all2
- (evar_conv_x (push_rec_types recdef1 env) isevars CONV)
- bds1 bds2)
- & (list_for_all2eq (evar_conv_x env isevars CONV) l1 l2)
-
+ if li1=li2 then
+ ise_and isevars
+ [(fun i -> ise_array2 i
+ (fun i -> evar_conv_x env i CONV) tys1 tys2);
+ (fun i -> ise_array2 i
+ (fun i -> evar_conv_x (push_rec_types recdef1 env) i CONV)
+ bds1 bds2);
+ (fun i -> ise_list2 i
+ (fun i -> evar_conv_x env i CONV) l1 l2)]
+ else (isevars,false)
| CoFix (i1,(_,tys1,bds1 as recdef1)), CoFix (i2,(_,tys2,bds2)) ->
- i1=i2
- & (array_for_all2 (evar_conv_x env isevars CONV) tys1 tys2)
- & (array_for_all2
- (evar_conv_x (push_rec_types recdef1 env) isevars CONV)
- bds1 bds2)
- & (list_for_all2eq (evar_conv_x env isevars CONV) l1 l2)
-
- | (Meta _ | Lambda _), _ -> false
- | _, (Meta _ | Lambda _) -> false
-
- | (Ind _ | Construct _ | Sort _ | Prod _), _ -> false
- | _, (Ind _ | Construct _ | Sort _ | Prod _) -> false
+ if i1=i2 then
+ ise_and isevars
+ [(fun i -> ise_array2 i
+ (fun i -> evar_conv_x env i CONV) tys1 tys2);
+ (fun i -> ise_array2 i
+ (fun i -> evar_conv_x (push_rec_types recdef1 env) i CONV)
+ bds1 bds2);
+ (fun i -> ise_list2 i
+ (fun i -> evar_conv_x env i CONV) l1 l2)]
+ else (isevars,false)
+
+ | (Meta _ | Lambda _), _ -> (isevars,false)
+ | _, (Meta _ | Lambda _) -> (isevars,false)
+
+ | (Ind _ | Construct _ | Sort _ | Prod _), _ -> (isevars,false)
+ | _, (Ind _ | Construct _ | Sort _ | Prod _) -> (isevars,false)
| (App _ | Case _ | Fix _ | CoFix _),
- (App _ | Case _ | Fix _ | CoFix _) -> false
+ (App _ | Case _ | Fix _ | CoFix _) -> (isevars,false)
| (Rel _ | Var _ | Const _ | Evar _), _ -> assert false
| _, (Rel _ | Var _ | Const _ | Evar _) -> assert false
and conv_record env isevars (c,bs,(params,params1),(us,us2),(ts,ts1),c1) =
- let ks =
+ let (isevars',ks) =
List.fold_left
- (fun ks b ->
- let dloc = (dummy_loc,Rawterm.InternalHole) in
- (new_isevar isevars env dloc (substl ks b)) :: ks)
- [] bs
+ (fun (i,ks) b ->
+ let dloc = (dummy_loc,InternalHole) in
+ let (i',ev) = new_evar i env ~src:dloc (substl ks b) in
+ (i', ev :: ks))
+ (isevars,[]) bs
in
- (list_for_all2eq
- (fun u1 u -> evar_conv_x env isevars CONV u1 (substl ks u))
- us2 us)
- &
- (list_for_all2eq
- (fun x1 x -> evar_conv_x env isevars CONV x1 (substl ks x))
- params1 params)
- & (list_for_all2eq (evar_conv_x env isevars CONV) ts ts1)
- & (evar_conv_x env isevars CONV c1 (applist (c,(List.rev ks))))
+ ise_and isevars'
+ [(fun i ->
+ ise_list2 i
+ (fun i u1 u -> evar_conv_x env i CONV u1 (substl ks u))
+ us2 us);
+ (fun i ->
+ ise_list2 i
+ (fun i x1 x -> evar_conv_x env i CONV x1 (substl ks x))
+ params1 params);
+ (fun i -> ise_list2 i (fun i -> evar_conv_x env i CONV) ts ts1);
+ (fun i -> evar_conv_x env i CONV c1 (applist (c,(List.rev ks))))]
-let the_conv_x env isevars t1 t2 = evar_conv_x env isevars CONV t1 t2
-let the_conv_x_leq env isevars t1 t2 = evar_conv_x env isevars CUMUL t1 t2
+let the_conv_x env t1 t2 isevars =
+ match evar_conv_x env isevars CONV t1 t2 with
+ (evd',true) -> evd'
+ | _ -> raise Reduction.NotConvertible
+
+let the_conv_x_leq env t1 t2 isevars =
+ match evar_conv_x env isevars CUMUL t1 t2 with
+ (evd', true) -> evd'
+ | _ -> raise Reduction.NotConvertible
+let e_conv env isevars t1 t2 =
+ match evar_conv_x env !isevars CONV t1 t2 with
+ (evd',true) -> isevars := evd'; true
+ | _ -> false
+
+let e_cumul env isevars t1 t2 =
+ match evar_conv_x env !isevars CUMUL t1 t2 with
+ (evd',true) -> isevars := evd'; true
+ | _ -> false
diff --git a/pretyping/evarconv.mli b/pretyping/evarconv.mli
index 8785d855..a6f5b489 100644
--- a/pretyping/evarconv.mli
+++ b/pretyping/evarconv.mli
@@ -6,23 +6,30 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: evarconv.mli,v 1.11.14.1 2004/07/16 19:30:44 herbelin Exp $ i*)
+(*i $Id: evarconv.mli 6109 2004-09-15 16:50:56Z barras $ i*)
(*i*)
open Term
open Sign
open Environ
open Reductionops
-open Evarutil
+open Evd
(*i*)
-val the_conv_x : env -> evar_defs -> constr -> constr -> bool
+(* returns exception Reduction.NotConvertible if not unifiable *)
+val the_conv_x : env -> constr -> constr -> evar_defs -> evar_defs
+val the_conv_x_leq : env -> constr -> constr -> evar_defs -> evar_defs
-val the_conv_x_leq : env -> evar_defs -> constr -> constr -> bool
+(* The same function resolving evars by side-effect and
+ catching the exception *)
+val e_conv : env -> evar_defs ref -> constr -> constr -> bool
+val e_cumul : env -> evar_defs ref -> constr -> constr -> bool
(*i For debugging *)
-val evar_conv_x : env -> evar_defs -> conv_pb -> constr -> constr -> bool
+val evar_conv_x :
+ env -> evar_defs -> conv_pb -> constr -> constr -> evar_defs * bool
val evar_eqappr_x :
env -> evar_defs ->
- conv_pb -> constr * constr list -> constr * constr list -> bool
+ conv_pb -> constr * constr list -> constr * constr list ->
+ evar_defs * bool
(*i*)
diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml
index 4337c0fc..aeaaefef 100644
--- a/pretyping/evarutil.ml
+++ b/pretyping/evarutil.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: evarutil.ml,v 1.64.2.5 2004/12/09 14:45:38 herbelin Exp $ *)
+(* $Id: evarutil.ml 8695 2006-04-10 16:33:52Z msozeau $ *)
open Util
open Pp
@@ -18,9 +18,7 @@ open Termops
open Sign
open Environ
open Evd
-open Instantiate
open Reductionops
-open Indrec
open Pretype_errors
@@ -50,7 +48,7 @@ let whd_castappevar_stack sigma c =
match kind_of_term c with
| Evar (ev,args) when Evd.in_dom sigma ev & Evd.is_defined sigma ev ->
whrec (existential_value sigma (ev,args), l)
- | Cast (c,_) -> whrec (c, l)
+ | Cast (c,_,_) -> whrec (c, l)
| App (f,args) -> whrec (f, Array.fold_right (fun a l -> a::l) args l)
| _ -> s
in
@@ -64,207 +62,121 @@ let jl_nf_evar = Pretype_errors.jl_nf_evar
let jv_nf_evar = Pretype_errors.jv_nf_evar
let tj_nf_evar = Pretype_errors.tj_nf_evar
-(**********************)
-(* Creating new evars *)
-(**********************)
-
-let evar_env evd = Global.env_of_context evd.evar_hyps
-
-(* Generator of existential names *)
-let new_evar =
- let evar_ctr = ref 0 in
- fun () -> incr evar_ctr; existential_of_int !evar_ctr
-
-let make_evar_instance env =
- fold_named_context
- (fun env (id, b, _) l -> (*if b=None then*) mkVar id :: l (*else l*))
- env ~init:[]
+let nf_evar_info evc info =
+ { evar_concl = Reductionops.nf_evar evc info.evar_concl;
+ evar_hyps = map_named_val (Reductionops.nf_evar evc) info.evar_hyps;
+ evar_body = info.evar_body}
-(* create an untyped existential variable *)
-let new_evar_in_sign env =
- let ev = new_evar () in
- mkEvar (ev, Array.of_list (make_evar_instance env))
+let nf_evars evm = Evd.fold (fun ev evi evm' -> Evd.add evm' ev (nf_evar_info evm evi))
+ evm Evd.empty
-(*------------------------------------*
- * functional operations on evar sets *
- *------------------------------------*)
+let nf_evar_defs isevars = Evd.evars_reset_evd (nf_evars (Evd.evars_of isevars)) isevars
-(* All ids of sign must be distincts! *)
-let new_isevar_sign env sigma typ instance =
- let sign = named_context env in
- if not (list_distinct (ids_of_named_context sign)) then
- error "new_isevar_sign: two vars have the same name";
- let newev = new_evar() in
- let info = { evar_concl = typ; evar_hyps = sign;
- evar_body = Evar_empty } in
- (Evd.add sigma newev info, mkEvar (newev,Array.of_list instance))
+let nf_isevar isevars = nf_evar (Evd.evars_of isevars)
+let j_nf_isevar isevars = j_nf_evar (Evd.evars_of isevars)
+let jl_nf_isevar isevars = jl_nf_evar (Evd.evars_of isevars)
+let jv_nf_isevar isevars = jv_nf_evar (Evd.evars_of isevars)
+let tj_nf_isevar isevars = tj_nf_evar (Evd.evars_of isevars)
-(* We don't try to guess in which sort the type should be defined, since
- any type has type Type. May cause some trouble, but not so far... *)
-let new_Type () = mkType (new_univ ())
-
-let new_Type_sort () = Type (new_univ ())
+(**********************)
+(* Creating new metas *)
+(**********************)
-let judge_of_new_Type () = Typeops.judge_of_type (new_univ ())
-(*
-let new_Type () = mkType dummy_univ
-
-let new_Type_sort () = Type dummy_univ
-
-let judge_of_new_Type () =
- { uj_val = mkSort (Type dummy_univ);
- uj_type = mkSort (Type dummy_univ) }
-*)
-
-(* This refreshes universes in types; works only for inferred types (i.e. for
- types of the form (x1:A1)...(xn:An)B with B a sort or an atom in
- head normal form) *)
-let refresh_universes t =
- let modified = ref false in
- let rec refresh t = match kind_of_term t with
- | Sort (Type _) -> modified := true; new_Type ()
- | Prod (na,u,v) -> mkProd (na,u,refresh v)
- | _ -> t in
- let t' = refresh t in
- if !modified then t' else t
+(* Generator of metavariables *)
+let new_meta =
+ let meta_ctr = ref 0 in
+ fun () -> incr meta_ctr; !meta_ctr
-(* Declaring any type to be in the sort Type shouldn't be harmful since
- cumulativity now includes Prop and Set in Type. *)
-let new_type_var env sigma =
- let instance = make_evar_instance env in
- new_isevar_sign env sigma (new_Type ()) instance
-
-let split_evar_to_arrow sigma (ev,args) =
- let evd = Evd.map sigma ev in
- let evenv = evar_env evd in
- let (sigma1,dom) = new_type_var evenv sigma in
- let hyps = evd.evar_hyps in
- let nvar = next_ident_away (id_of_string "x") (ids_of_named_context hyps) in
- let newenv = push_named (nvar, None, dom) evenv in
- let (sigma2,rng) = new_type_var newenv sigma1 in
- let x = named_hd newenv dom Anonymous in
- let prod = mkProd (x, dom, subst_var nvar rng) in
- let sigma3 = Evd.define sigma2 ev prod in
- let evdom = fst (destEvar dom), args in
- let evrng =
- fst (destEvar rng), array_cons (mkRel 1) (Array.map (lift 1) args) in
- let prod' = mkProd (x, mkEvar evdom, mkEvar evrng) in
- (sigma3,prod', evdom, evrng)
+let mk_new_meta () = mkMeta(new_meta())
-(* Redefines an evar with a smaller context (i.e. it may depend on less
- * variables) such that c becomes closed.
- * Example: in [x:?1; y:(list ?2)] <?3>x=y /\ x=(nil bool)
- * ?3 <-- ?1 no pb: env of ?3 is larger than ?1's
- * ?1 <-- (list ?2) pb: ?2 may depend on x, but not ?1.
- * What we do is that ?2 is defined by a new evar ?4 whose context will be
- * a prefix of ?2's env, included in ?1's env. *)
+let collect_evars emap c =
+ let rec collrec acc c =
+ match kind_of_term c with
+ | Evar (k,_) ->
+ if Evd.in_dom emap k & not (Evd.is_defined emap k) then k::acc
+ else (* No recursion on the evar instantiation *) acc
+ | _ ->
+ fold_constr collrec acc c in
+ list_uniquize (collrec [] c)
+
+let push_dependent_evars sigma emap =
+ Evd.fold (fun ev {evar_concl = ccl} (sigma',emap') ->
+ List.fold_left
+ (fun (sigma',emap') ev ->
+ (Evd.add sigma' ev (Evd.map emap' ev),Evd.rmv emap' ev))
+ (sigma',emap') (collect_evars emap' ccl))
+ emap (sigma,emap)
+
+(* replaces a mapping of existentials into a mapping of metas.
+ Problem if an evar appears in the type of another one (pops anomaly) *)
+let evars_to_metas sigma (emap, c) =
+ let sigma',emap' = push_dependent_evars sigma emap in
+ let change_exist evar =
+ let ty = nf_betaiota (nf_evar emap (existential_type emap evar)) in
+ let n = new_meta() in
+ mkCast (mkMeta n, DEFAULTcast, ty) in
+ let rec replace c =
+ match kind_of_term c with
+ Evar (k,_ as ev) when Evd.in_dom emap' k -> change_exist ev
+ | _ -> map_constr replace c in
+ (sigma', replace c)
+
+(* The list of non-instantiated existential declarations *)
+
+let non_instantiated sigma =
+ let listev = to_list sigma in
+ List.fold_left
+ (fun l (ev,evd) ->
+ if evd.evar_body = Evar_empty then
+ ((ev,nf_evar_info sigma evd)::l) else l)
+ [] listev
+
+(*************************************)
+(* Metas *)
+
+let meta_value evd mv =
+ let rec valrec mv =
+ try
+ let b = meta_fvalue evd mv in
+ instance
+ (List.map (fun mv' -> (mv',valrec mv')) (Metaset.elements b.freemetas))
+ b.rebus
+ with Anomaly _ | Not_found ->
+ mkMeta mv
+ in
+ valrec mv
-let do_restrict_hyps sigma ev args =
- let args = Array.to_list args in
- let evd = Evd.map sigma ev in
- let env = evar_env evd in
- let hyps = evd.evar_hyps in
- let (sign,ncargs) = list_filter2 (fun _ a -> closed0 a) (hyps,args) in
- let env' = reset_with_named_context sign env in
- let (sigma',nc) = new_isevar_sign env' sigma evd.evar_concl ncargs in
- let nc = refresh_universes nc in (* needed only if nc is an inferred type *)
- let sigma'' = Evd.define sigma' ev nc in
- (sigma'', nc)
+let meta_instance env b =
+ let c_sigma =
+ List.map
+ (fun mv -> (mv,meta_value env mv)) (Metaset.elements b.freemetas)
+ in
+ instance c_sigma b.rebus
+let nf_meta env c = meta_instance env (mk_freelisted c)
+(**********************)
+(* Creating new evars *)
+(**********************)
+(* Generator of existential names *)
+let new_untyped_evar =
+ let evar_ctr = ref 0 in
+ fun () -> incr evar_ctr; existential_of_int !evar_ctr
(*------------------------------------*
- * operations on the evar constraints *
+ * functional operations on evar sets *
*------------------------------------*)
-type evar_constraint = conv_pb * constr * constr
-type evar_defs =
- { mutable evars : Evd.evar_map;
- mutable conv_pbs : evar_constraint list;
- mutable history : (existential_key * (loc * Rawterm.hole_kind)) list }
-
-let create_evar_defs evd = { evars=evd; conv_pbs=[]; history=[] }
-let evars_of d = d.evars
-let evars_reset_evd evd d = d.evars <- evd
-let add_conv_pb d pb = d.conv_pbs <- pb::d.conv_pbs
-let evar_source ev d =
- try List.assoc ev d.history
- with Failure _ -> (dummy_loc, Rawterm.InternalHole)
-
-(* ise_try [f1;...;fn] tries fi() for i=1..n, restoring the evar constraints
- * when fi returns false or an exception. Returns true if one of the fi
- * returns true, and false if every fi return false (in the latter case,
- * the evar constraints are restored).
- *)
-let ise_try isevars l =
- let u = isevars.evars in
- let rec test = function
- [] -> isevars.evars <- u; false
- | f::l ->
- (try f() with reraise -> isevars.evars <- u; raise reraise)
- or (isevars.evars <- u; test l)
- in test l
-
-
-
-(* say if the section path sp corresponds to an existential *)
-let ise_in_dom isevars sp = Evd.in_dom isevars.evars sp
-
-(* map the given section path to the enamed_declaration *)
-let ise_map isevars sp = Evd.map isevars.evars sp
-
-(* define the existential of section path sp as the constr body *)
-let ise_define isevars sp body =
- let body = refresh_universes body in (* needed only if an inferred type *)
- isevars.evars <- Evd.define isevars.evars sp body
-
-let is_defined_evar isevars (n,_) = Evd.is_defined isevars.evars n
-
-(* Does k corresponds to an (un)defined existential ? *)
-let ise_undefined isevars c = match kind_of_term c with
- | Evar ev -> not (is_defined_evar isevars ev)
- | _ -> false
-
-let need_restriction isevars args = not (array_for_all closed0 args)
-
-
-(* We try to instanciate the evar assuming the body won't depend
- * on arguments that are not Rels or Vars, or appearing several times.
- *)
-(* Note: error_not_clean should not be an error: it simply means that the
- * conversion test that lead to the faulty call to [real_clean] should return
- * false. The problem is that we won't get the right error message.
- *)
-
-let real_clean env isevars ev args rhs =
- let subst = List.map (fun (x,y) -> (y,mkVar x)) (filter_unique args) in
- let rec subs k t =
- match kind_of_term t with
- | Rel i ->
- if i<=k then t
- else (try List.assoc (mkRel (i-k)) subst with Not_found -> t)
- | Evar (ev,args) ->
- let args' = Array.map (subs k) args in
- if need_restriction isevars args' then
- if Evd.is_defined isevars.evars ev then
- subs k (existential_value isevars.evars (ev,args'))
- else begin
- let (sigma,rc) = do_restrict_hyps isevars.evars ev args' in
- isevars.evars <- sigma;
- isevars.history <-
- (fst (destEvar rc),evar_source ev isevars)::isevars.history;
- rc
- end
- else
- mkEvar (ev,args')
- | Var _ -> (try List.assoc t subst with Not_found -> t)
- | _ -> map_constr_with_binders succ subs k t
- in
- let body = subs 0 rhs in
- if not (closed0 body)
- then error_not_clean env isevars.evars ev body (evar_source ev isevars);
- body
+(* All ids of sign must be distincts! *)
+let new_evar_instance sign evd typ ?(src=(dummy_loc,InternalHole)) instance =
+ let ctxt = named_context_of_val sign in
+ assert (List.length instance = named_context_length ctxt);
+ if not (list_distinct (ids_of_named_context ctxt)) then
+ anomaly "new_evar_instance: two vars have the same name";
+ let newev = new_untyped_evar() in
+ (evar_declare sign newev typ ~src:src evd,
+ mkEvar (newev,Array.of_list instance))
let make_evar_instance_with_rel env =
let n = rel_context_length (rel_context env) in
@@ -279,7 +191,7 @@ let make_evar_instance_with_rel env =
let make_subst env args =
snd (fold_named_context
- (fun env (id,b,c) (args,l as g) ->
+ (fun env (id,b,c) (args,l) ->
match b, args with
| (* None *) _ , a::rest -> (rest, (id,a)::l)
(* | Some _, _ -> g*)
@@ -290,28 +202,175 @@ let make_subst env args =
(* Converting the env into the sign of the evar to define *)
let push_rel_context_to_named_context env =
- let sign0 = named_context env in
- let (subst,_,sign) =
+ let (subst,_,env) =
Sign.fold_rel_context
- (fun (na,c,t) (subst,avoid,sign) ->
+ (fun (na,c,t) (subst,avoid,env) ->
let na = if na = Anonymous then Name(id_of_string"_") else na in
let id = next_name_away na avoid in
((mkVar id)::subst,
id::avoid,
- add_named_decl (id,option_app (substl subst) c,
+ push_named (id,option_app (substl subst) c,
type_app (substl subst) t)
- sign))
- (rel_context env) ~init:([],ids_of_named_context sign0,sign0)
- in (subst, reset_with_named_context sign env)
+ env))
+ (rel_context env) ~init:([],ids_of_named_context (named_context env),env)
+ in (subst, (named_context_val env))
-let new_isevar isevars env src typ =
- let subst,env' = push_rel_context_to_named_context env in
+let new_evar evd env ?(src=(dummy_loc,InternalHole)) typ =
+ let subst,sign = push_rel_context_to_named_context env in
let typ' = substl subst typ in
let instance = make_evar_instance_with_rel env in
- let (sigma',evar) = new_isevar_sign env' isevars.evars typ' instance in
- isevars.evars <- sigma';
- isevars.history <- (fst (destEvar evar),src)::isevars.history;
- evar
+ new_evar_instance sign evd typ' ~src:src instance
+
+(* The same using side-effect *)
+let e_new_evar evd env ?(src=(dummy_loc,InternalHole)) ty =
+ let (evd',ev) = new_evar !evd env ~src:src ty in
+ evd := evd';
+ ev
+
+(*------------------------------------*
+ * operations on the evar constraints *
+ *------------------------------------*)
+
+(* Pb: defined Rels and Vars should not be considered as a pattern... *)
+let is_pattern inst =
+ let rec is_hopat l = function
+ [] -> true
+ | t :: tl ->
+ (isRel t or isVar t) && not (List.mem t l) && is_hopat (t::l) tl in
+ is_hopat [] (Array.to_list inst)
+
+let evar_well_typed_body evd ev evi body =
+ try
+ let env = evar_env evi in
+ let ty = evi.evar_concl in
+ Typing.check env (evars_of evd) body ty;
+ true
+ with e ->
+ pperrnl
+ (str "Ill-typed evar instantiation: " ++ fnl() ++
+ pr_evar_defs evd ++ fnl() ++
+ str "----> " ++ int ev ++ str " := " ++
+ print_constr body);
+ false
+
+let strict_inverse = false
+
+let inverse_instance env isevars ev evi inst rhs =
+ let subst = make_subst (evar_env evi) (Array.to_list inst) in
+ let subst = List.map (fun (x,y) -> (y,mkVar x)) subst in
+ let evd = ref isevars in
+ let error () =
+ error_not_clean env (evars_of !evd) ev rhs (evar_source ev !evd) in
+ let rec subs rigid k t =
+ match kind_of_term t with
+ | Rel i ->
+ if i<=k then t
+ else
+ (try List.assoc (mkRel (i-k)) subst
+ with Not_found ->
+ if rigid then error()
+ else if strict_inverse then
+ failwith "cannot solve pb yet"
+ else t)
+ | Var id ->
+ (try List.assoc t subst
+ with Not_found ->
+ if rigid then error()
+ else if
+ not strict_inverse &&
+ List.exists (fun (id',_,_) -> id=id') (evar_context evi)
+ then
+ failwith "cannot solve pb yet"
+ else t)
+ | Evar (ev,args) ->
+ if Evd.is_defined_evar !evd (ev,args) then
+ subs rigid k (existential_value (evars_of !evd) (ev,args))
+ else
+ let args' = Array.map (subs false k) args in
+ mkEvar (ev,args')
+ | _ -> map_constr_with_binders succ (subs rigid) k t in
+ let body = subs true 0 (nf_evar (evars_of isevars) rhs) in
+ (!evd,body)
+
+
+let is_defined_equation env evd (ev,inst) rhs =
+ is_pattern inst &&
+ not (occur_evar ev rhs) &&
+ try
+ let evi = Evd.map (evars_of evd) ev in
+ let (evd',body) = inverse_instance env evd ev evi inst rhs in
+ evar_well_typed_body evd' ev evi body
+ with Failure _ -> false
+
+
+(* Redefines an evar with a smaller context (i.e. it may depend on less
+ * variables) such that c becomes closed.
+ * Example: in [x:?1; y:(list ?2)] <?3>x=y /\ x=(nil bool)
+ * ?3 <-- ?1 no pb: env of ?3 is larger than ?1's
+ * ?1 <-- (list ?2) pb: ?2 may depend on x, but not ?1.
+ * What we do is that ?2 is defined by a new evar ?4 whose context will be
+ * a prefix of ?2's env, included in ?1's env. *)
+
+let do_restrict_hyps evd ev args =
+ let args = Array.to_list args in
+ let evi = Evd.map (evars_of !evd) ev in
+ let env = evar_env evi in
+ let hyps = evar_context evi in
+ let (sign,ncargs) = list_filter2 (fun _ a -> closed0 a) (hyps,args) in
+ (* No care is taken in case the evar type uses vars filtered out!
+ Is it important ? *)
+ let nc =
+ let env =
+ Sign.fold_named_context push_named sign ~init:(reset_context env) in
+ e_new_evar evd env ~src:(evar_source ev !evd) evi.evar_concl in
+ evd := Evd.evar_define ev nc !evd;
+ let (evn,_) = destEvar nc in
+ mkEvar(evn,Array.of_list ncargs)
+
+
+let need_restriction isevars args = not (array_for_all closed0 args)
+
+(* We try to instantiate the evar assuming the body won't depend
+ * on arguments that are not Rels or Vars, or appearing several times.
+ *)
+(* Note: error_not_clean should not be an error: it simply means that the
+ * conversion test that lead to the faulty call to [real_clean] should return
+ * false. The problem is that we won't get the right error message.
+ *)
+
+let real_clean env isevars ev evi args rhs =
+ let evd = ref isevars in
+ let subst = List.map (fun (x,y) -> (y,mkVar x)) (filter_unique args) in
+ let rec subs rigid k t =
+ match kind_of_term t with
+ | Rel i ->
+ if i<=k then t
+ else (try List.assoc (mkRel (i-k)) subst with Not_found -> t)
+ | Evar (ev,args) ->
+ if Evd.is_defined_evar !evd (ev,args) then
+ subs rigid k (existential_value (evars_of !evd) (ev,args))
+ else
+ let args' = Array.map (subs false k) args in
+ if need_restriction !evd args' then
+ do_restrict_hyps evd ev args'
+ else
+ mkEvar (ev,args')
+ | Var id ->
+ (try List.assoc t subst
+ with Not_found ->
+ if
+ not rigid
+ or List.exists (fun (id',_,_) -> id=id') (evar_context evi)
+ then t
+ else
+ error_not_clean env (evars_of !evd) ev rhs
+ (evar_source ev !evd))
+ | _ -> map_constr_with_binders succ (subs rigid) k t
+ in
+ let body = subs true 0 (nf_evar (evars_of isevars) rhs) in
+ if not (closed0 body)
+ then error_not_clean env (evars_of !evd) ev body (evar_source ev !evd);
+ (!evd,body)
(* [evar_define] solves the problem lhs = rhs when lhs is an uninstantiated
* evar, i.e. tries to find the body ?sp for lhs=mkEvar (sp,args)
@@ -331,30 +390,56 @@ let new_isevar isevars env src typ =
* ?1 would be instantiated by (le y y) but y is not in the scope of ?1
*)
-let evar_define env isevars (ev,argsv) rhs =
+(* env needed for error messages... *)
+let evar_define env (ev,argsv) rhs isevars =
if occur_evar ev rhs
then error_occur_check env (evars_of isevars) ev rhs;
let args = Array.to_list argsv in
- let evd = ise_map isevars ev in
+ let evi = Evd.map (evars_of isevars) ev in
(* the bindings to invert *)
- let worklist = make_subst (evar_env evd) args in
- let body = real_clean env isevars ev worklist rhs in
- ise_define isevars ev body;
- [ev]
+ let worklist = make_subst (evar_env evi) args in
+ let (isevars',body) = real_clean env isevars ev evi worklist rhs in
+ if occur_meta body then error "Meta cannot occur in evar body"
+ else
+ (* needed only if an inferred type *)
+ let body = refresh_universes body in
+(* Cannot strictly type instantiations since the unification algorithm
+ * does not unifies applications from left to right.
+ * e.g problem f x == g y yields x==y and f==g (in that order)
+ * Another problem is that type variables are evars of type Type
+ let _ =
+ try
+ let env = evar_env evi in
+ let ty = evi.evar_concl in
+ Typing.check env (evars_of isevars') body ty
+ with e ->
+ pperrnl
+ (str "Ill-typed evar instantiation: " ++ fnl() ++
+ pr_evar_defs isevars' ++ fnl() ++
+ str "----> " ++ int ev ++ str " := " ++
+ print_constr body);
+ raise e in*)
+ let isevars'' = Evd.evar_define ev body isevars' in
+ isevars'',[ev]
+
+
(*-------------------*)
(* Auxiliary functions for the conversion algorithms modulo evars
*)
-let has_undefined_isevars isevars t =
- try let _ = local_strong (whd_ise isevars.evars) t in false
+let has_undefined_evars isevars t =
+ try let _ = local_strong (whd_ise (evars_of isevars)) t in false
with Uninstantiated_evar _ -> true
+let is_ground_term isevars t =
+ not (has_undefined_evars isevars t)
+
let head_is_evar isevars =
let rec hrec k = match kind_of_term k with
- | Evar (n,_) -> not (Evd.is_defined isevars.evars n)
+ | Evar n -> not (Evd.is_defined_evar isevars n)
| App (f,_) -> hrec f
- | Cast (c,_) -> hrec c
+ | Cast (c,_,_) -> hrec c
| _ -> false
in
hrec
@@ -362,7 +447,7 @@ let head_is_evar isevars =
let rec is_eliminator c = match kind_of_term c with
| App _ -> true
| Case _ -> true
- | Cast (c,_) -> is_eliminator c
+ | Cast (c,_,_) -> is_eliminator c
| _ -> false
let head_is_embedded_evar isevars c =
@@ -373,7 +458,7 @@ let head_evar =
| Evar (ev,_) -> ev
| Case (_,_,c,_) -> hrec c
| App (c,_) -> hrec c
- | Cast (c,_) -> hrec c
+ | Cast (c,_,_) -> hrec c
| _ -> failwith "headconstant"
in
hrec
@@ -410,75 +495,70 @@ let status_changed lev (pbty,t1,t2) =
with Failure _ ->
try List.mem (head_evar t2) lev with Failure _ -> false
-let get_changed_pb isevars lev =
- let (pbs,pbs1) =
- List.fold_left
- (fun (pbs,pbs1) pb ->
- if status_changed lev pb then
- (pb::pbs,pbs1)
- else
- (pbs,pb::pbs1))
- ([],[])
- isevars.conv_pbs
- in
- isevars.conv_pbs <- pbs1;
- pbs
-
(* Solve pbs (?i x1..xn) = (?i y1..yn) which arises often in fixpoint
* definitions. We try to unify the xi with the yi pairwise. The pairs
* that don't unify are discarded (i.e. ?i is redefined so that it does not
* depend on these args). *)
let solve_refl conv_algo env isevars ev argsv1 argsv2 =
- if argsv1 = argsv2 then [] else
- let evd = Evd.map isevars.evars ev in
- let hyps = evd.evar_hyps in
- let (_,rsign) =
+ if argsv1 = argsv2 then (isevars,[]) else
+ let evd = Evd.map (evars_of isevars) ev in
+ let hyps = evar_context evd in
+ let (isevars',_,rsign) =
array_fold_left2
- (fun (sgn,rsgn) a1 a2 ->
- if conv_algo env isevars CONV a1 a2 then
- (List.tl sgn, add_named_decl (List.hd sgn) rsgn)
+ (fun (isevars,sgn,rsgn) a1 a2 ->
+ let (isevars',b) = conv_algo env isevars Reduction.CONV a1 a2 in
+ if b then
+ (isevars',List.tl sgn, add_named_decl (List.hd sgn) rsgn)
else
- (List.tl sgn, rsgn))
- (hyps,[]) argsv1 argsv2
+ (isevars,List.tl sgn, rsgn))
+ (isevars,hyps,[]) argsv1 argsv2
in
let nsign = List.rev rsign in
- let nargs = (Array.of_list (List.map mkVar (ids_of_named_context nsign))) in
- let newev = new_evar () in
- let info = { evar_concl = evd.evar_concl; evar_hyps = nsign;
- evar_body = Evar_empty } in
- isevars.evars <-
- Evd.define (Evd.add isevars.evars newev info) ev (mkEvar (newev,nargs));
- isevars.history <- (newev,evar_source ev isevars)::isevars.history;
- [ev]
+ let (evd',newev) =
+ let env =
+ Sign.fold_named_context push_named nsign ~init:(reset_context env) in
+ new_evar isevars env ~src:(evar_source ev isevars) evd.evar_concl in
+ let evd'' = Evd.evar_define ev newev evd' in
+ evd'', [ev]
(* Tries to solve problem t1 = t2.
- * Precondition: t1 is an uninstanciated evar
+ * Precondition: t1 is an uninstantiated evar
* Returns an optional list of evars that were instantiated, or None
* if the problem couldn't be solved. *)
(* Rq: uncomplete algorithm if pbty = CONV_X_LEQ ! *)
let solve_simple_eqn conv_algo env isevars (pbty,(n1,args1 as ev1),t2) =
- let t2 = nf_evar isevars.evars t2 in
- let lsp = match kind_of_term t2 with
- | Evar (n2,args2 as ev2)
- when not (Evd.is_defined isevars.evars n2) ->
- if n1 = n2 then
- solve_refl conv_algo env isevars n1 args1 args2
- else
- if Array.length args1 < Array.length args2 then
- evar_define env isevars ev2 (mkEvar ev1)
- else
- evar_define env isevars ev1 t2
- | _ ->
- evar_define env isevars ev1 t2 in
- let pbs = get_changed_pb isevars lsp in
- List.for_all (fun (pbty,t1,t2) -> conv_algo env isevars pbty t1 t2) pbs
+ try
+ let t2 = nf_evar (evars_of isevars) t2 in
+ let (isevars,lsp) = match kind_of_term t2 with
+ | Evar (n2,args2 as ev2) ->
+ if n1 = n2 then
+ solve_refl conv_algo env isevars n1 args1 args2
+ else
+ (try evar_define env ev1 t2 isevars
+ with e when precatchable_exception e ->
+ evar_define env ev2 (mkEvar ev1) isevars)
+(* if Array.length args1 < Array.length args2 then
+ evar_define env ev2 (mkEvar ev1) isevars
+ else
+ evar_define env ev1 t2 isevars*)
+ | _ ->
+ evar_define env ev1 t2 isevars in
+ let (isevars,pbs) = get_conv_pbs isevars (status_changed lsp) in
+ List.fold_left
+ (fun (isevars,b as p) (pbty,t1,t2) ->
+ if b then conv_algo env isevars pbty t1 t2 else p) (isevars,true)
+ pbs
+ with e when precatchable_exception e ->
+ (isevars,false)
(* Operations on value/type constraints *)
-type type_constraint = constr option
+type type_constraint_type = (int * int) option * constr
+type type_constraint = type_constraint_type option
+
type val_constraint = constr option
(* Old comment...
@@ -498,8 +578,14 @@ type val_constraint = constr option
(* The empty type constraint *)
let empty_tycon = None
+let mk_tycon_type c = (None, c)
+let mk_abstr_tycon_type n c = (Some (n, n), c) (* First component is initial abstraction, second
+ is current abstraction *)
+
(* Builds a type constraint *)
-let mk_tycon ty = Some ty
+let mk_tycon ty = Some (mk_tycon_type ty)
+
+let mk_abstr_tycon n ty = Some (mk_abstr_tycon_type n ty)
(* Constrains the value of a type *)
let empty_valcon = None
@@ -509,41 +595,98 @@ let mk_valcon c = Some c
(* Refining an evar to a product or a sort *)
-let refine_evar_as_arrow isevars ev =
- let (sigma,prod,evdom,evrng) = split_evar_to_arrow isevars.evars ev in
- evars_reset_evd sigma isevars;
- let hst = evar_source (fst ev) isevars in
- isevars.history <- (fst evrng,hst)::(fst evdom, hst)::isevars.history;
- (prod,evdom,evrng)
+(* Declaring any type to be in the sort Type shouldn't be harmful since
+ cumulativity now includes Prop and Set in Type...
+ It is, but that's not too bad *)
+let define_evar_as_abstraction abs evd (ev,args) =
+ let evi = Evd.map (evars_of evd) ev in
+ let evenv = evar_env evi in
+ let (evd1,dom) = new_evar evd evenv (new_Type()) in
+ let nvar =
+ next_ident_away (id_of_string "x")
+ (ids_of_named_context (evar_context evi)) in
+ let newenv = push_named (nvar, None, dom) evenv in
+ let (evd2,rng) =
+ new_evar evd1 newenv ~src:(evar_source ev evd1) (new_Type()) in
+ let prod = abs (Name nvar, dom, subst_var nvar rng) in
+ let evd3 = Evd.evar_define ev prod evd2 in
+ let evdom = fst (destEvar dom), args in
+ let evrng =
+ fst (destEvar rng), array_cons (mkRel 1) (Array.map (lift 1) args) in
+ let prod' = abs (Name nvar, mkEvar evdom, mkEvar evrng) in
+ (evd3,prod')
+
+let define_evar_as_arrow evd (ev,args) =
+ define_evar_as_abstraction (fun t -> mkProd t) evd (ev,args)
-let define_evar_as_arrow isevars ev =
- let (prod,_,_) = refine_evar_as_arrow isevars ev in
- prod
+let define_evar_as_lambda evd (ev,args) =
+ define_evar_as_abstraction (fun t -> mkLambda t) evd (ev,args)
let define_evar_as_sort isevars (ev,args) =
let s = new_Type () in
- let sigma' = Evd.define isevars.evars ev s in
- evars_reset_evd sigma' isevars;
- destSort s
+ Evd.evar_define ev s isevars, destSort s
+
+(* We don't try to guess in which sort the type should be defined, since
+ any type has type Type. May cause some trouble, but not so far... *)
+
+let judge_of_new_Type () = Typeops.judge_of_type (new_univ ())
(* Propagation of constraints through application and abstraction:
Given a type constraint on a functional term, returns the type
constraint on its domain and codomain. If the input constraint is
an evar instantiate it with the product of 2 new evars. *)
-let split_tycon loc env isevars = function
- | None -> Anonymous,None,None
- | Some c ->
- let sigma = evars_of isevars in
- let t = whd_betadeltaiota env sigma c in
+let split_tycon loc env isevars tycon =
+ let rec real_split c =
+ let sigma = evars_of isevars in
+ let t = whd_betadeltaiota env sigma c in
match kind_of_term t with
- | Prod (na,dom,rng) -> na, Some dom, Some rng
- | Evar (n,_ as ev) when not (Evd.is_defined isevars.evars n) ->
- let (_,evdom,evrng) = refine_evar_as_arrow isevars ev in
- Anonymous, Some (mkEvar evdom), Some (mkEvar evrng)
+ | Prod (na,dom,rng) -> isevars, (na, dom, rng)
+ | Evar ev when not (Evd.is_defined_evar isevars ev) ->
+ let (isevars',prod) = define_evar_as_arrow isevars ev in
+ let (_,dom,rng) = destProd prod in
+ isevars',(Anonymous, dom, rng)
| _ -> error_not_product_loc loc env sigma c
+ in
+ match tycon with
+ | None -> isevars,(Anonymous,None,None)
+ | Some (abs, c) ->
+ (match abs with
+ None ->
+ let isevars', (n, dom, rng) = real_split c in
+ isevars', (n, mk_tycon dom, mk_tycon rng)
+ | Some (init, cur) ->
+ if cur = 0 then
+ let isevars', (x, dom, rng) = real_split c in
+ isevars, (Anonymous,
+ Some (Some (init, 0), dom),
+ Some (Some (init, 0), rng))
+ else
+ isevars, (Anonymous, None, Some (Some (init, pred cur), c)))
+
+let valcon_of_tycon x =
+ match x with
+ | Some (None, t) -> Some t
+ | _ -> None
+
+let lift_abstr_tycon_type n (abs, t) =
+ match abs with
+ None -> raise (Invalid_argument "lift_abstr_tycon_type: not an abstraction")
+ | Some (init, abs) ->
+ let abs' = abs + n in
+ if abs' < 0 then raise (Invalid_argument "lift_abstr_tycon_type")
+ else (Some (init, abs'), t)
+
+let lift_tycon_type n (abs, t) = (abs, lift n t)
+let lift_tycon n = option_app (lift_tycon_type n)
+
+let pr_tycon_type env (abs, t) =
+ match abs with
+ None -> Termops.print_constr_env env t
+ | Some (init, cur) -> str "Abstract (" ++ int init ++ str "," ++ int cur ++ str ") " ++ Termops.print_constr_env env t
+
+let pr_tycon env = function
+ None -> str "None"
+ | Some t -> pr_tycon_type env t
-let valcon_of_tycon x = x
-
-let lift_tycon = option_app (lift 1)
diff --git a/pretyping/evarutil.mli b/pretyping/evarutil.mli
index 011d2a92..7429cd16 100644
--- a/pretyping/evarutil.mli
+++ b/pretyping/evarutil.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: evarutil.mli,v 1.33.2.2 2004/07/16 19:30:44 herbelin Exp $ i*)
+(*i $Id: evarutil.mli 8695 2006-04-10 16:33:52Z msozeau $ i*)
(*i*)
open Util
@@ -21,77 +21,132 @@ open Reductionops
(*s This modules provides useful functions for unification modulo evars *)
-(* [whd_ise] raise [Uninstantiated_evar] if an evar remains uninstantiated; *)
-(* *[whd_evar]* and *[nf_evar]* leave uninstantiated evar as is *)
+(***********************************************************)
+(* Metas *)
-val nf_evar : evar_map -> constr -> constr
-val j_nf_evar : evar_map -> unsafe_judgment -> unsafe_judgment
-val jl_nf_evar :
- evar_map -> unsafe_judgment list -> unsafe_judgment list
-val jv_nf_evar :
- evar_map -> unsafe_judgment array -> unsafe_judgment array
-val tj_nf_evar :
- evar_map -> unsafe_type_judgment -> unsafe_type_judgment
+(* [new_meta] is a generator of unique meta variables *)
+val new_meta : unit -> metavariable
+val mk_new_meta : unit -> constr
-(* Replacing all evars *)
-exception Uninstantiated_evar of existential_key
-val whd_ise : evar_map -> constr -> constr
-val whd_castappevar : evar_map -> constr -> constr
+(* [new_untyped_evar] is a generator of unique evar keys *)
+val new_untyped_evar : unit -> existential_key
+
+(***********************************************************)
+(* Creating a fresh evar given their type and context *)
+val new_evar :
+ evar_defs -> env -> ?src:loc * hole_kind -> types -> evar_defs * constr
+(* the same with side-effects *)
+val e_new_evar :
+ evar_defs ref -> env -> ?src:loc * hole_kind -> types -> constr
+
+(* Create a fresh evar in a context different from its definition context:
+ [new_evar_instance sign evd ty inst] creates a new evar of context
+ [sign] and type [ty], [inst] is a mapping of the evar context to
+ the context where the evar should occur. This means that the terms
+ of [inst] are typed in the occurrence context and their type (seen
+ as a telescope) is [sign] *)
+val new_evar_instance :
+ named_context_val -> evar_defs -> types -> ?src:loc * hole_kind ->
+ constr list -> evar_defs * constr
-(* Creating new existential variables *)
-val new_evar : unit -> evar
-val new_evar_in_sign : env -> constr
+(***********************************************************)
+(* Instanciate evars *)
-val evar_env : evar_info -> env
+(* suspicious env ? *)
+val evar_define :
+ env -> existential -> constr -> evar_defs -> evar_defs * evar list
-type evar_defs
-val evars_of : evar_defs -> evar_map
-val create_evar_defs : evar_map -> evar_defs
-val evars_reset_evd : evar_map -> evar_defs -> unit
-val evar_source : existential_key -> evar_defs -> loc * hole_kind
-type evar_constraint = conv_pb * constr * constr
-val add_conv_pb : evar_defs -> evar_constraint -> unit
+(***********************************************************)
+(* Evars/Metas switching... *)
-val is_defined_evar : evar_defs -> existential -> bool
-val ise_try : evar_defs -> (unit -> bool) list -> bool
-val ise_undefined : evar_defs -> constr -> bool
-val has_undefined_isevars : evar_defs -> constr -> bool
+(* [evars_to_metas] generates new metavariables for each non dependent
+ existential and performs the replacement in the given constr; it also
+ returns the evar_map extended with dependent evars *)
+val evars_to_metas : evar_map -> open_constr -> (evar_map * constr)
-val new_isevar_sign :
- Environ.env -> Evd.evar_map -> Term.constr -> Term.constr list ->
- Evd.evar_map * Term.constr
+val non_instantiated : evar_map -> (evar * evar_info) list
-val new_isevar : evar_defs -> env -> loc * hole_kind -> constr -> constr
+(***********************************************************)
+(* Unification utils *)
+val is_ground_term : evar_defs -> constr -> bool
val is_eliminator : constr -> bool
val head_is_embedded_evar : evar_defs -> constr -> bool
val solve_simple_eqn :
- (env -> evar_defs -> conv_pb -> constr -> constr -> bool)
- -> env -> evar_defs -> conv_pb * existential * constr -> bool
+ (env -> evar_defs -> conv_pb -> constr -> constr -> evar_defs * bool)
+ -> env -> evar_defs -> conv_pb * existential * constr ->
+ evar_defs * bool
-val define_evar_as_arrow : evar_defs -> existential -> types
-val define_evar_as_sort : evar_defs -> existential -> sorts
+val define_evar_as_arrow : evar_defs -> existential -> evar_defs * types
+val define_evar_as_lambda : evar_defs -> existential -> evar_defs * types
+val define_evar_as_sort : evar_defs -> existential -> evar_defs * sorts
+(***********************************************************)
(* Value/Type constraints *)
-val new_Type_sort : unit -> sorts
-val new_Type : unit -> constr
val judge_of_new_Type : unit -> unsafe_judgment
-val refresh_universes : types -> types
-type type_constraint = constr option
+type type_constraint_type = (int * int) option * constr
+type type_constraint = type_constraint_type option
+
type val_constraint = constr option
val empty_tycon : type_constraint
+val mk_tycon_type : constr -> type_constraint_type
+val mk_abstr_tycon_type : int -> constr -> type_constraint_type
val mk_tycon : constr -> type_constraint
+val mk_abstr_tycon : int -> constr -> type_constraint
val empty_valcon : val_constraint
val mk_valcon : constr -> val_constraint
val split_tycon :
loc -> env -> evar_defs -> type_constraint ->
- name * type_constraint * type_constraint
+ evar_defs * (name * type_constraint * type_constraint)
val valcon_of_tycon : type_constraint -> val_constraint
-val lift_tycon : type_constraint -> type_constraint
+val lift_abstr_tycon_type : int -> type_constraint_type -> type_constraint_type
+
+val lift_tycon_type : int -> type_constraint_type -> type_constraint_type
+val lift_tycon : int -> type_constraint -> type_constraint
+
+(***********************************************************)
+
+(* [whd_ise] raise [Uninstantiated_evar] if an evar remains uninstantiated; *)
+(* *[whd_evar]* and *[nf_evar]* leave uninstantiated evar as is *)
+
+val nf_evar : evar_map -> constr -> constr
+val j_nf_evar : evar_map -> unsafe_judgment -> unsafe_judgment
+val jl_nf_evar :
+ evar_map -> unsafe_judgment list -> unsafe_judgment list
+val jv_nf_evar :
+ evar_map -> unsafe_judgment array -> unsafe_judgment array
+val tj_nf_evar :
+ evar_map -> unsafe_type_judgment -> unsafe_type_judgment
+
+val nf_evar_info : evar_map -> evar_info -> evar_info
+val nf_evars : evar_map -> evar_map
+
+(* Same for evar defs *)
+val nf_isevar : evar_defs -> constr -> constr
+val j_nf_isevar : evar_defs -> unsafe_judgment -> unsafe_judgment
+val jl_nf_isevar :
+ evar_defs -> unsafe_judgment list -> unsafe_judgment list
+val jv_nf_isevar :
+ evar_defs -> unsafe_judgment array -> unsafe_judgment array
+val tj_nf_isevar :
+ evar_defs -> unsafe_type_judgment -> unsafe_type_judgment
+
+val nf_evar_defs : evar_defs -> evar_defs
+
+(* Replacing all evars *)
+exception Uninstantiated_evar of existential_key
+val whd_ise : evar_map -> constr -> constr
+val whd_castappevar : evar_map -> constr -> constr
+
+(*********************************************************************)
+(* debug pretty-printer: *)
+
+val pr_tycon_type : env -> type_constraint_type -> Pp.std_ppcmds
+val pr_tycon : env -> type_constraint -> Pp.std_ppcmds
diff --git a/pretyping/evd.ml b/pretyping/evd.ml
index 7a3e7c02..c9f771c9 100644
--- a/pretyping/evd.ml
+++ b/pretyping/evd.ml
@@ -6,12 +6,18 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: evd.ml,v 1.3.2.1 2004/07/16 19:30:44 herbelin Exp $ *)
+(* $Id: evd.ml 8688 2006-04-07 15:08:12Z msozeau $ *)
+open Pp
open Util
open Names
+open Nameops
open Term
+open Termops
open Sign
+open Environ
+open Libnames
+open Mod_subst
(* The type of mappings for existential variables *)
@@ -23,12 +29,20 @@ type evar_body =
type evar_info = {
evar_concl : constr;
- evar_hyps : named_context;
+ evar_hyps : named_context_val;
evar_body : evar_body}
+let evar_context evi = named_context_of_val evi.evar_hyps
+
+let eq_evar_info ei1 ei2 =
+ ei1 == ei2 ||
+ eq_constr ei1.evar_concl ei2.evar_concl &&
+ eq_named_context_val (ei1.evar_hyps) (ei2.evar_hyps) &&
+ ei1.evar_body = ei2.evar_body
+
module Evarmap = Intmap
-type evar_map = evar_info Evarmap.t
+type evar_map1 = evar_info Evarmap.t
let empty = Evarmap.empty
@@ -38,28 +52,21 @@ let map evc k = Evarmap.find k evc
let rmv evc k = Evarmap.remove k evc
let remap evc k i = Evarmap.add k i evc
let in_dom evc k = Evarmap.mem k evc
+let fold = Evarmap.fold
let add evd ev newinfo = Evarmap.add ev newinfo evd
let define evd ev body =
- let oldinfo = map evd ev in
+ let oldinfo =
+ try map evd ev
+ with Not_found -> error "Evd.define: cannot define undeclared evar" in
let newinfo =
{ evar_concl = oldinfo.evar_concl;
evar_hyps = oldinfo.evar_hyps;
- evar_body = Evar_defined body}
- in
+ evar_body = Evar_defined body} in
match oldinfo.evar_body with
| Evar_empty -> Evarmap.add ev newinfo evd
- | _ -> anomaly "cannot define an isevar twice"
-
-(* The list of non-instantiated existential declarations *)
-
-let non_instantiated sigma =
- let listev = to_list sigma in
- List.fold_left
- (fun l ((ev,evd) as d) ->
- if evd.evar_body = Evar_empty then (d::l) else l)
- [] listev
+ | _ -> anomaly "Evd.define: cannot define an isevar twice"
let is_evar sigma ev = in_dom sigma ev
@@ -68,7 +75,490 @@ let is_defined sigma ev =
not (info.evar_body = Evar_empty)
let evar_body ev = ev.evar_body
+let evar_env evd = Global.env_of_context evd.evar_hyps
let string_of_existential ev = "?" ^ string_of_int ev
let existential_of_int ev = ev
+
+(*******************************************************************)
+(* Formerly Instantiate module *)
+
+let is_id_inst inst =
+ let is_id (id,c) = match kind_of_term c with
+ | Var id' -> id = id'
+ | _ -> false
+ in
+ List.for_all is_id inst
+
+(* Vérifier que les instances des let-in sont compatibles ?? *)
+let instantiate_sign_including_let sign args =
+ let rec instrec = function
+ | ((id,b,_) :: sign, c::args) -> (id,c) :: (instrec (sign,args))
+ | ([],[]) -> []
+ | ([],_) | (_,[]) ->
+ anomaly "Signature and its instance do not match"
+ in
+ instrec (sign,args)
+
+let instantiate_evar sign c args =
+ let inst = instantiate_sign_including_let sign args in
+ if is_id_inst inst then
+ c
+ else
+ replace_vars inst c
+
+(* Existentials. *)
+
+let existential_type sigma (n,args) =
+ let info =
+ try map sigma n
+ with Not_found ->
+ anomaly ("Evar "^(string_of_existential n)^" was not declared") in
+ let hyps = evar_context info in
+ instantiate_evar hyps info.evar_concl (Array.to_list args)
+
+exception NotInstantiatedEvar
+
+let existential_value sigma (n,args) =
+ let info = map sigma n in
+ let hyps = evar_context info in
+ match evar_body info with
+ | Evar_defined c ->
+ instantiate_evar hyps c (Array.to_list args)
+ | Evar_empty ->
+ raise NotInstantiatedEvar
+
+let existential_opt_value sigma ev =
+ try Some (existential_value sigma ev)
+ with NotInstantiatedEvar -> None
+
+(*******************************************************************)
+(* Constraints for sort variables *)
+(*******************************************************************)
+
+type sort_var = Univ.universe
+
+type sort_constraint =
+ | DefinedSort of sorts (* instantiated sort var *)
+ | SortVar of sort_var list * sort_var list (* (leq,geq) *)
+ | EqSort of sort_var
+
+module UniverseOrdered = struct
+ type t = Univ.universe
+ let compare = Pervasives.compare
+end
+module UniverseMap = Map.Make(UniverseOrdered)
+
+type sort_constraints = sort_constraint UniverseMap.t
+
+let rec canonical_find u scstr =
+ match UniverseMap.find u scstr with
+ EqSort u' -> canonical_find u' scstr
+ | c -> (u,c)
+
+let whd_sort_var scstr t =
+ match kind_of_term t with
+ Sort(Type u) ->
+ (try
+ match canonical_find u scstr with
+ _, DefinedSort s -> mkSort s
+ | _ -> t
+ with Not_found -> t)
+ | _ -> t
+
+let rec set_impredicative u s scstr =
+ match UniverseMap.find u scstr with
+ | DefinedSort s' ->
+ if family_of_sort s = family_of_sort s' then scstr
+ else failwith "sort constraint inconsistency"
+ | EqSort u' ->
+ UniverseMap.add u (DefinedSort s) (set_impredicative u' s scstr)
+ | SortVar(_,ul) ->
+ (* also set sorts lower than u as impredicative *)
+ UniverseMap.add u (DefinedSort s)
+ (List.fold_left (fun g u' -> set_impredicative u' s g) scstr ul)
+
+let rec set_predicative u s scstr =
+ match UniverseMap.find u scstr with
+ | DefinedSort s' ->
+ if family_of_sort s = family_of_sort s' then scstr
+ else failwith "sort constraint inconsistency"
+ | EqSort u' ->
+ UniverseMap.add u (DefinedSort s) (set_predicative u' s scstr)
+ | SortVar(ul,_) ->
+ UniverseMap.add u (DefinedSort s)
+ (List.fold_left (fun g u' -> set_impredicative u' s g) scstr ul)
+
+let var_of_sort = function
+ Type u -> u
+ | _ -> assert false
+
+let is_sort_var s scstr =
+ match s with
+ Type u ->
+ (try
+ match canonical_find u scstr with
+ _, DefinedSort _ -> false
+ | _ -> true
+ with Not_found -> false)
+ | _ -> false
+
+let new_sort_var cstr =
+ let u = Termops.new_univ() in
+ (u, UniverseMap.add u (SortVar([],[])) cstr)
+
+
+let set_leq_sort (u1,(leq1,geq1)) (u2,(leq2,geq2)) scstr =
+ let rec search_rec (is_b, betw, not_betw) u1 =
+ if List.mem u1 betw then (true, betw, not_betw)
+ else if List.mem u1 not_betw then (is_b, betw, not_betw)
+ else if u1 = u2 then (true, u1::betw,not_betw) else
+ match UniverseMap.find u1 scstr with
+ EqSort u1' -> search_rec (is_b,betw,not_betw) u1'
+ | SortVar(leq,_) ->
+ let (is_b',betw',not_betw') =
+ List.fold_left search_rec (false,betw,not_betw) leq in
+ if is_b' then (true, u1::betw', not_betw')
+ else (false, betw', not_betw')
+ | DefinedSort _ -> (false,betw,u1::not_betw) in
+ let (is_betw,betw,_) = search_rec (false, [], []) u1 in
+ if is_betw then
+ UniverseMap.add u1 (SortVar(leq1@leq2,geq1@geq2))
+ (List.fold_left
+ (fun g u -> UniverseMap.add u (EqSort u1) g) scstr betw)
+ else
+ UniverseMap.add u1 (SortVar(u2::leq1,geq1))
+ (UniverseMap.add u2 (SortVar(leq2, u1::geq2)) scstr)
+
+let set_leq s1 s2 scstr =
+ let u1 = var_of_sort s1 in
+ let u2 = var_of_sort s2 in
+ let (cu1,c1) = canonical_find u1 scstr in
+ let (cu2,c2) = canonical_find u2 scstr in
+ if cu1=cu2 then scstr
+ else
+ match c1,c2 with
+ (EqSort _, _ | _, EqSort _) -> assert false
+ | SortVar(leq1,geq1), SortVar(leq2,geq2) ->
+ set_leq_sort (cu1,(leq1,geq1)) (cu2,(leq2,geq2)) scstr
+ | _, DefinedSort(Prop _ as s) -> set_impredicative u1 s scstr
+ | _, DefinedSort(Type _) -> scstr
+ | DefinedSort(Type _ as s), _ -> set_predicative u2 s scstr
+ | DefinedSort(Prop _), _ -> scstr
+
+let set_sort_variable s1 s2 scstr =
+ let u = var_of_sort s1 in
+ match s2 with
+ Prop _ -> set_impredicative u s2 scstr
+ | Type _ -> set_predicative u s2 scstr
+
+let pr_sort_cstrs g =
+ let l = UniverseMap.fold (fun u c l -> (u,c)::l) g [] in
+ str "SORT CONSTRAINTS:" ++ fnl() ++
+ prlist_with_sep fnl (fun (u,c) ->
+ match c with
+ EqSort u' -> Univ.pr_uni u ++ str" == " ++ Univ.pr_uni u'
+ | DefinedSort s -> Univ.pr_uni u ++ str " := " ++ print_sort s
+ | SortVar(leq,geq) ->
+ str"[" ++ hov 0 (prlist_with_sep spc Univ.pr_uni geq) ++
+ str"] <= "++ Univ.pr_uni u ++ brk(0,0) ++ str"<= [" ++
+ hov 0 (prlist_with_sep spc Univ.pr_uni leq) ++ str"]")
+ l
+
+type evar_map = evar_map1 * sort_constraints
+let empty = empty, UniverseMap.empty
+let add (sigma,sm) k v = (add sigma k v, sm)
+let dom (sigma,_) = dom sigma
+let map (sigma,_) = map sigma
+let rmv (sigma,sm) k = (rmv sigma k, sm)
+let remap (sigma,sm) k v = (remap sigma k v, sm)
+let in_dom (sigma,_) = in_dom sigma
+let to_list (sigma,_) = to_list sigma
+let fold f (sigma,_) = fold f sigma
+let define (sigma,sm) k v = (define sigma k v, sm)
+let is_evar (sigma,_) = is_evar sigma
+let is_defined (sigma,_) = is_defined sigma
+let existential_value (sigma,_) = existential_value sigma
+let existential_type (sigma,_) = existential_type sigma
+let existential_opt_value (sigma,_) = existential_opt_value sigma
+
+(*******************************************************************)
+type open_constr = evar_map * constr
+
+(*******************************************************************)
+(* The type constructor ['a sigma] adds an evar map to an object of
+ type ['a] *)
+type 'a sigma = {
+ it : 'a ;
+ sigma : evar_map}
+
+let sig_it x = x.it
+let sig_sig x = x.sigma
+
+(*******************************************************************)
+(* Metamaps *)
+
+(*******************************************************************)
+(* Constraints for existential variables *)
+(*******************************************************************)
+
+type 'a freelisted = {
+ rebus : 'a;
+ freemetas : Intset.t }
+
+(* Collects all metavars appearing in a constr *)
+let metavars_of c =
+ let rec collrec acc c =
+ match kind_of_term c with
+ | Meta mv -> Intset.add mv acc
+ | _ -> fold_constr collrec acc c
+ in
+ collrec Intset.empty c
+
+let mk_freelisted c =
+ { rebus = c; freemetas = metavars_of c }
+
+let map_fl f cfl = { cfl with rebus=f cfl.rebus }
+
+
+(* Clausal environments *)
+
+type clbinding =
+ | Cltyp of name * constr freelisted
+ | Clval of name * constr freelisted * constr freelisted
+
+let map_clb f = function
+ | Cltyp (na,cfl) -> Cltyp (na,map_fl f cfl)
+ | Clval (na,cfl1,cfl2) -> Clval (na,map_fl f cfl1,map_fl f cfl2)
+
+(* name of defined is erased (but it is pretty-printed) *)
+let clb_name = function
+ Cltyp(na,_) -> (na,false)
+ | Clval (na,_,_) -> (na,true)
+
+(***********************)
+
+module Metaset = Intset
+
+let meta_exists p s = Metaset.fold (fun x b -> b || (p x)) s false
+
+module Metamap = Intmap
+
+let metamap_to_list m =
+ Metamap.fold (fun n v l -> (n,v)::l) m []
+
+(*************************)
+(* Unification state *)
+
+type hole_kind =
+ | ImplicitArg of global_reference * (int * identifier option)
+ | BinderType of name
+ | QuestionMark
+ | CasesType
+ | InternalHole
+ | TomatchTypeParameter of inductive * int
+
+type conv_pb = Reduction.conv_pb
+type evar_constraint = conv_pb * constr * constr
+type evar_defs =
+ { evars : evar_map;
+ conv_pbs : evar_constraint list;
+ history : (existential_key * (loc * hole_kind)) list;
+ metas : clbinding Metamap.t }
+
+let subst_evar_defs sub evd =
+ { evd with
+ conv_pbs =
+ List.map (fun (k,t1,t2) ->(k,subst_mps sub t1,subst_mps sub t2))
+ evd.conv_pbs;
+ metas = Metamap.map (map_clb (subst_mps sub)) evd.metas }
+
+let create_evar_defs sigma =
+ { evars=sigma; conv_pbs=[]; history=[]; metas=Metamap.empty }
+let evars_of d = d.evars
+let evars_reset_evd evd d = {d with evars = evd}
+let reset_evd (sigma,mmap) d = {d with evars = sigma; metas=mmap}
+let add_conv_pb pb d =
+(* let (pbty,c1,c2) = pb in
+ pperrnl
+ (Termops.print_constr c1 ++
+ (if pbty=Reduction.CUMUL then str " <="++ spc()
+ else str" =="++spc()) ++
+ Termops.print_constr c2);*)
+ {d with conv_pbs = pb::d.conv_pbs}
+let evar_source ev d =
+ try List.assoc ev d.history
+ with Not_found -> (dummy_loc, InternalHole)
+
+(* define the existential of section path sp as the constr body *)
+let evar_define sp body isevars =
+ {isevars with evars = define isevars.evars sp body}
+
+let evar_declare hyps evn ty ?(src=(dummy_loc,InternalHole)) evd =
+ { evd with
+ evars = add evd.evars evn
+ {evar_hyps=hyps; evar_concl=ty; evar_body=Evar_empty};
+ history = (evn,src)::evd.history }
+
+let is_defined_evar isevars (n,_) = is_defined isevars.evars n
+
+(* Does k corresponds to an (un)defined existential ? *)
+let is_undefined_evar isevars c = match kind_of_term c with
+ | Evar ev -> not (is_defined_evar isevars ev)
+ | _ -> false
+
+let undefined_evars isevars =
+ let evd =
+ fold (fun ev evi sigma -> if evi.evar_body = Evar_empty then
+ add sigma ev evi else sigma)
+ isevars.evars empty
+ in
+ { isevars with evars = evd }
+
+(* extracts conversion problems that satisfy predicate p *)
+(* Note: conv_pbs not satisying p are stored back in reverse order *)
+let get_conv_pbs isevars p =
+ let (pbs,pbs1) =
+ List.fold_left
+ (fun (pbs,pbs1) pb ->
+ if p pb then
+ (pb::pbs,pbs1)
+ else
+ (pbs,pb::pbs1))
+ ([],[])
+ isevars.conv_pbs
+ in
+ {isevars with conv_pbs = pbs1},
+ pbs
+
+
+(**********************************************************)
+(* Sort variables *)
+
+let new_sort_variable (sigma,sm) =
+ let (u,scstr) = new_sort_var sm in
+ (Type u,(sigma,scstr))
+let is_sort_variable (_,sm) s =
+ is_sort_var s sm
+let whd_sort_variable (_,sm) t = whd_sort_var sm t
+let set_leq_sort_variable (sigma,sm) u1 u2 =
+ (sigma, set_leq u1 u2 sm)
+let define_sort_variable (sigma,sm) u s =
+ (sigma, set_sort_variable u s sm)
+let pr_sort_constraints (_,sm) = pr_sort_cstrs sm
+
+(**********************************************************)
+(* Accessing metas *)
+
+let meta_list evd = metamap_to_list evd.metas
+
+let meta_defined evd mv =
+ match Metamap.find mv evd.metas with
+ | Clval _ -> true
+ | Cltyp _ -> false
+
+let meta_fvalue evd mv =
+ match Metamap.find mv evd.metas with
+ | Clval(_,b,_) -> b
+ | Cltyp _ -> anomaly "meta_fvalue: meta has no value"
+
+let meta_ftype evd mv =
+ match Metamap.find mv evd.metas with
+ | Cltyp (_,b) -> b
+ | Clval(_,_,b) -> b
+
+let meta_declare mv v ?(name=Anonymous) evd =
+ { evd with metas = Metamap.add mv (Cltyp(name,mk_freelisted v)) evd.metas }
+
+let meta_assign mv v evd =
+ match Metamap.find mv evd.metas with
+ Cltyp(na,ty) ->
+ { evd with
+ metas = Metamap.add mv (Clval(na,mk_freelisted v, ty)) evd.metas }
+ | _ -> anomaly "meta_assign: already defined"
+
+(* If the meta is defined then forget its name *)
+let meta_name evd mv =
+ try
+ let (na,def) = clb_name (Metamap.find mv evd.metas) in
+ if def then Anonymous else na
+ with Not_found -> Anonymous
+
+let meta_with_name evd id =
+ let na = Name id in
+ let (mvl,mvnodef) =
+ Metamap.fold
+ (fun n clb (l1,l2 as l) ->
+ let (na',def) = clb_name clb in
+ if na = na' then if def then (n::l1,l2) else (n::l1,n::l2)
+ else l)
+ evd.metas ([],[]) in
+ match mvnodef, mvl with
+ | _,[] ->
+ errorlabstrm "Evd.meta_with_name"
+ (str"No such bound variable " ++ pr_id id)
+ | ([n],_|_,[n]) ->
+ n
+ | _ ->
+ errorlabstrm "Evd.meta_with_name"
+ (str "Binder name \"" ++ pr_id id ++
+ str"\" occurs more than once in clause")
+
+
+let meta_merge evd1 evd2 =
+ {evd2 with
+ metas = List.fold_left (fun m (n,v) -> Metamap.add n v m)
+ evd2.metas (metamap_to_list evd1.metas) }
+
+
+(**********************************************************)
+(* Pretty-printing *)
+
+let pr_meta_map mmap =
+ let pr_name = function
+ Name id -> str"[" ++ pr_id id ++ str"]"
+ | _ -> mt() in
+ let pr_meta_binding = function
+ | (mv,Cltyp (na,b)) ->
+ hov 0
+ (pr_meta mv ++ pr_name na ++ str " : " ++
+ print_constr b.rebus ++ fnl ())
+ | (mv,Clval(na,b,_)) ->
+ hov 0
+ (pr_meta mv ++ pr_name na ++ str " := " ++
+ print_constr b.rebus ++ fnl ())
+ in
+ prlist pr_meta_binding (metamap_to_list mmap)
+
+let pr_idl idl = prlist_with_sep pr_spc pr_id idl
+
+let pr_evar_info evi =
+ let phyps = pr_idl (List.rev (ids_of_named_context (evar_context evi))) in
+ let pty = print_constr evi.evar_concl in
+ let pb =
+ match evi.evar_body with
+ | Evar_empty -> mt ()
+ | Evar_defined c -> spc() ++ str"=> " ++ print_constr c
+ in
+ hov 2 (str"[" ++ phyps ++ spc () ++ str"|- " ++ pty ++ pb ++ str"]")
+
+let pr_evar_map sigma =
+ h 0
+ (prlist_with_sep pr_fnl
+ (fun (ev,evi) ->
+ h 0 (str(string_of_existential ev)++str"=="++ pr_evar_info evi))
+ (to_list sigma))
+
+let pr_evar_defs evd =
+ let pp_evm =
+ if evd.evars = empty then mt() else
+ str"EVARS:"++brk(0,1)++pr_evar_map evd.evars++fnl() in
+ let n = List.length evd.conv_pbs in
+ let cstrs =
+ if n=0 then mt() else
+ str"=> " ++ int n ++ str" constraints" ++ fnl() ++ fnl() in
+ let pp_met =
+ if evd.metas = Metamap.empty then mt() else
+ str"METAS:"++brk(0,1)++pr_meta_map evd.metas in
+ v 0 (pp_evm ++ cstrs ++ pp_met)
diff --git a/pretyping/evd.mli b/pretyping/evd.mli
index f66667aa..40ecce6e 100644
--- a/pretyping/evd.mli
+++ b/pretyping/evd.mli
@@ -6,12 +6,15 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: evd.mli,v 1.3.2.1 2004/07/16 19:30:44 herbelin Exp $ i*)
+(*i $Id: evd.mli 8688 2006-04-07 15:08:12Z msozeau $ i*)
(*i*)
+open Util
open Names
open Term
open Sign
+open Libnames
+open Mod_subst
(*i*)
(* The type of mappings for existential variables.
@@ -28,9 +31,11 @@ type evar_body =
type evar_info = {
evar_concl : constr;
- evar_hyps : named_context;
+ evar_hyps : Environ.named_context_val;
evar_body : evar_body}
+val eq_evar_info : evar_info -> evar_info -> bool
+val evar_context : evar_info -> named_context
type evar_map
val empty : evar_map
@@ -43,15 +48,127 @@ val rmv : evar_map -> evar -> evar_map
val remap : evar_map -> evar -> evar_info -> evar_map
val in_dom : evar_map -> evar -> bool
val to_list : evar_map -> (evar * evar_info) list
+val fold : (evar -> evar_info -> 'a -> 'a) -> evar_map -> 'a -> 'a
val define : evar_map -> evar -> constr -> evar_map
-val non_instantiated : evar_map -> (evar * evar_info) list
val is_evar : evar_map -> evar -> bool
val is_defined : evar_map -> evar -> bool
val evar_body : evar_info -> evar_body
+val evar_env : evar_info -> Environ.env
val string_of_existential : evar -> string
val existential_of_int : int -> evar
+
+(*s [existential_value sigma ev] raises [NotInstantiatedEvar] if [ev] has
+ no body and [Not_found] if it does not exist in [sigma] *)
+
+exception NotInstantiatedEvar
+val existential_value : evar_map -> existential -> constr
+val existential_type : evar_map -> existential -> types
+val existential_opt_value : evar_map -> existential -> constr option
+
+(*********************************************************************)
+(* constr with holes *)
+type open_constr = evar_map * constr
+
+(*********************************************************************)
+(* The type constructor ['a sigma] adds an evar map to an object of
+ type ['a] *)
+type 'a sigma = {
+ it : 'a ;
+ sigma : evar_map}
+
+val sig_it : 'a sigma -> 'a
+val sig_sig : 'a sigma -> evar_map
+
+(*********************************************************************)
+(* Meta map *)
+
+module Metaset : Set.S with type elt = metavariable
+
+val meta_exists : (metavariable -> bool) -> Metaset.t -> bool
+
+type 'a freelisted = {
+ rebus : 'a;
+ freemetas : Metaset.t }
+
+val mk_freelisted : constr -> constr freelisted
+val map_fl : ('a -> 'b) -> 'a freelisted -> 'b freelisted
+
+type clbinding =
+ | Cltyp of name * constr freelisted
+ | Clval of name * constr freelisted * constr freelisted
+
+val map_clb : (constr -> constr) -> clbinding -> clbinding
+
+(*********************************************************************)
+(* Unification state *)
+type evar_defs
+
+(* Substitution is not applied to the [evar_map] *)
+val subst_evar_defs : substitution -> evar_defs -> evar_defs
+
+(* create an [evar_defs] with empty meta map: *)
+val create_evar_defs : evar_map -> evar_defs
+val evars_of : evar_defs -> evar_map
+val evars_reset_evd : evar_map -> evar_defs -> evar_defs
+
+(* Evars *)
+type hole_kind =
+ | ImplicitArg of global_reference * (int * identifier option)
+ | BinderType of name
+ | QuestionMark
+ | CasesType
+ | InternalHole
+ | TomatchTypeParameter of inductive * int
+val is_defined_evar : evar_defs -> existential -> bool
+val is_undefined_evar : evar_defs -> constr -> bool
+val undefined_evars : evar_defs -> evar_defs
+val evar_declare :
+ Environ.named_context_val -> evar -> types -> ?src:loc * hole_kind ->
+ evar_defs -> evar_defs
+val evar_define : evar -> constr -> evar_defs -> evar_defs
+val evar_source : existential_key -> evar_defs -> loc * hole_kind
+
+(* Unification constraints *)
+type conv_pb = Reduction.conv_pb
+type evar_constraint = conv_pb * constr * constr
+val add_conv_pb : evar_constraint -> evar_defs -> evar_defs
+val get_conv_pbs : evar_defs -> (evar_constraint -> bool) ->
+ evar_defs * evar_constraint list
+
+(* Metas *)
+val meta_list : evar_defs -> (metavariable * clbinding) list
+val meta_defined : evar_defs -> metavariable -> bool
+(* [meta_fvalue] raises [Not_found] if meta not in map or [Anomaly] if
+ meta has no value *)
+val meta_fvalue : evar_defs -> metavariable -> constr freelisted
+val meta_ftype : evar_defs -> metavariable -> constr freelisted
+val meta_name : evar_defs -> metavariable -> name
+val meta_with_name : evar_defs -> identifier -> metavariable
+val meta_declare :
+ metavariable -> types -> ?name:name -> evar_defs -> evar_defs
+val meta_assign : metavariable -> constr -> evar_defs -> evar_defs
+
+(* [meta_merge evd1 evd2] returns [evd2] extended with the metas of [evd1] *)
+val meta_merge : evar_defs -> evar_defs -> evar_defs
+
+(**********************************************************)
+(* Sort variables *)
+
+val new_sort_variable : evar_map -> sorts * evar_map
+val is_sort_variable : evar_map -> sorts -> bool
+val whd_sort_variable : evar_map -> constr -> constr
+val set_leq_sort_variable : evar_map -> sorts -> sorts -> evar_map
+val define_sort_variable : evar_map -> sorts -> sorts -> evar_map
+
+(*********************************************************************)
+(* debug pretty-printer: *)
+
+val pr_evar_info : evar_info -> Pp.std_ppcmds
+val pr_evar_map : evar_map -> Pp.std_ppcmds
+val pr_evar_defs : evar_defs -> Pp.std_ppcmds
+val pr_sort_constraints : evar_map -> Pp.std_ppcmds
diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml
index 0b9283ae..a587dd20 100644
--- a/pretyping/indrec.ml
+++ b/pretyping/indrec.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: indrec.ml,v 1.20.2.3 2004/07/16 19:30:44 herbelin Exp $ *)
+(* $Id: indrec.ml 7662 2005-12-17 22:03:35Z herbelin $ *)
open Pp
open Util
@@ -19,14 +19,21 @@ open Declarations
open Entries
open Inductive
open Inductiveops
-open Instantiate
open Environ
open Reductionops
open Typeops
open Type_errors
-open Indtypes (* pour les erreurs *)
open Safe_typing
open Nametab
+open Sign
+
+(* Errors related to recursors building *)
+type recursion_scheme_error =
+ | NotAllowedCaseAnalysis of bool * sorts * inductive
+ | BadInduction of bool * identifier * sorts
+ | NotMutualInScheme
+
+exception RecursionSchemeError of recursion_scheme_error
let make_prod_dep dep env = if dep then prod_name env else mkProd
let mkLambda_string s t c = mkLambda (Name (id_of_string s), t, c)
@@ -42,18 +49,18 @@ let mkLambda_string s t c = mkLambda (Name (id_of_string s), t, c)
lifter les paramètres globaux *)
let mis_make_case_com depopt env sigma (ind,mib,mip) kind =
- let lnamespar = mip.mind_params_ctxt in
+ let lnamespar = mib.mind_params_ctxt in
let dep = match depopt with
| None -> mip.mind_sort <> (Prop Null)
| Some d -> d
in
if not (List.exists ((=) kind) mip.mind_kelim) then
raise
- (InductiveError
+ (RecursionSchemeError
(NotAllowedCaseAnalysis
(dep,(new_sort_in_family kind),ind)));
- let nbargsprod = mip.mind_nrealargs + 1 in
+ let ndepar = mip.mind_nrealargs + 1 in
(* Pas génant car env ne sert pas à typer mais juste à renommer les Anonym *)
(* mais pas très joli ... (mais manque get_sort_of à ce niveau) *)
@@ -65,22 +72,28 @@ let mis_make_case_com depopt env sigma (ind,mib,mip) kind =
let rec add_branch env k =
if k = Array.length mip.mind_consnames then
let nbprod = k+1 in
- let indf = make_ind_family(ind,extended_rel_list nbprod lnamespar) in
- let lnamesar,_ = get_arity env indf in
+
+ let indf' = lift_inductive_family nbprod indf in
+ let arsign,_ = get_arity env indf' in
+ let depind = build_dependent_inductive env indf' in
+ let deparsign = (Anonymous,None,depind)::arsign in
+
let ci = make_default_case_info env RegularStyle ind in
- let depind = build_dependent_inductive env indf in
- let deparsign = (Anonymous,None,depind)::lnamesar in
- let p =
- it_mkLambda_or_LetIn_name env'
- (appvect
- (mkRel ((if dep then nbargsprod else mip.mind_nrealargs) + nbprod),
- if dep then extended_rel_vect 0 deparsign
- else extended_rel_vect 0 lnamesar))
- (if dep then deparsign else lnamesar) in
+ let pbody =
+ appvect
+ (mkRel (ndepar + nbprod),
+ if dep then extended_rel_vect 0 deparsign
+ else extended_rel_vect 1 arsign) in
+ let p =
+ it_mkLambda_or_LetIn_name env'
+ ((if dep then mkLambda_name env' else mkLambda)
+ (Anonymous,depind,pbody))
+ arsign
+ in
it_mkLambda_or_LetIn_name env'
- (mkCase (ci, lift nbargsprod p,
+ (mkCase (ci, lift ndepar p,
mkRel 1,
- rel_vect nbargsprod k))
+ rel_vect ndepar k))
deparsign
else
let cs = lift_constructor (k+1) constrs.(k) in
@@ -186,7 +199,7 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs =
let c = it_mkProd_or_LetIn base cs.cs_args in
process_constr env 0 c recargs nhyps []
-let make_rec_branch_arg env sigma (nparams,fvect,decF) f cstr recargs =
+let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs =
let process_pos env fk =
let rec prec env i hyps p =
let p',largs = whd_betadeltaiota_nolet_stack env sigma p in
@@ -198,7 +211,7 @@ let make_rec_branch_arg env sigma (nparams,fvect,decF) f cstr recargs =
let d = (n,Some b,t) in
mkLetIn (n,b,t,prec (push_rel d env) (i+1) (d::hyps) c)
| Ind _ ->
- let realargs = list_skipn nparams largs
+ let realargs = list_skipn nparrec largs
and arg = appvect (mkRel (i+1),extended_rel_vect 0 hyps) in
applist(lift i fk,realargs@[arg])
| _ -> assert false
@@ -239,10 +252,24 @@ let make_rec_branch_arg env sigma (nparams,fvect,decF) f cstr recargs =
in
process_constr env 0 f (List.rev cstr.cs_args, recargs)
+
+(* Cut a context ctx in 2 parts (ctx1,ctx2) with ctx1 containing k
+ variables *)
+let context_chop k ctx =
+ let rec chop_aux acc = function
+ | (0, l2) -> (List.rev acc, l2)
+ | (n, ((_,Some _,_ as h)::t)) -> chop_aux (h::acc) (n, t)
+ | (n, (h::t)) -> chop_aux (h::acc) (pred n, t)
+ | (_, []) -> failwith "context_chop"
+ in chop_aux [] (k,ctx)
+
+
(* Main function *)
-let mis_make_indrec env sigma listdepkind (ind,mib,mip) =
- let nparams = mip.mind_nparams in
- let lnamespar = mip.mind_params_ctxt in
+let mis_make_indrec env sigma listdepkind mib =
+ let nparams = mib.mind_nparams in
+ let nparrec = mib. mind_nparams_rec in
+ let lnonparrec,lnamesparrec =
+ context_chop (nparams-nparrec) mib.mind_params_ctxt in
let nrec = List.length listdepkind in
let depPvec =
Array.create mib.mind_ntypes (None : (bool * constr) option) in
@@ -257,6 +284,11 @@ let mis_make_indrec env sigma listdepkind (ind,mib,mip) =
assign nrec listdepkind in
let recargsvec =
Array.map (fun mip -> mip.mind_recargs) mib.mind_packets in
+ (* recarg information for non recursive parameters *)
+ let rec recargparn l n =
+ if n = 0 then l else recargparn (mk_norec::l) (n-1)
+ in
+ let recargpar = recargparn [] (nparams-nparrec) in
let make_one_rec p =
let makefix nbconstruct =
let rec mrec i ln ltyp ldef = function
@@ -267,59 +299,86 @@ let mis_make_indrec env sigma listdepkind (ind,mib,mip) =
(* arity in the context of the fixpoint, i.e.
P1..P_nrec f1..f_nbconstruct *)
- let args = extended_rel_list (nrec+nbconstruct) lnamespar in
+ let args = extended_rel_list (nrec+nbconstruct) lnamesparrec in
let indf = make_ind_family(indi,args) in
- let lnames,_ = get_arity env indf in
- let nar = mipi.mind_nrealargs in
- let dect = nar+nrec+nbconstruct in
+ let arsign,_ = get_arity env indf in
+ let depind = build_dependent_inductive env indf in
+ let deparsign = (Anonymous,None,depind)::arsign in
+
+ let nonrecpar = rel_context_length lnonparrec in
+ let larsign = rel_context_length deparsign in
+ let ndepar = larsign - nonrecpar in
+ let dect = larsign+nrec+nbconstruct in
- let branches =
(* constructors in context of the Cases expr, i.e.
- P1..P_nrec f1..f_nbconstruct F_1..F_nrec a_1..a_nar x:I *)
- let args' = extended_rel_list (dect+nrec+1) lnamespar in
- let indf' = make_ind_family(indi,args') in
+ P1..P_nrec f1..f_nbconstruct F_1..F_nrec a_1..a_nar x:I *)
+ let args' = extended_rel_list (dect+nrec) lnamesparrec in
+ let args'' = extended_rel_list ndepar lnonparrec in
+ let indf' = make_ind_family(indi,args'@args'') in
+
+ let branches =
let constrs = get_constructors env indf' in
- let vecfi = rel_vect (dect+1-i-nctyi) nctyi in
+ let fi = rel_vect (dect-i-nctyi) nctyi in
+ let vecfi = Array.map
+ (fun f -> appvect (f,extended_rel_vect ndepar lnonparrec))
+ fi
+ in
array_map3
- (make_rec_branch_arg env sigma (nparams,depPvec,nar+1))
- vecfi constrs (dest_subterms recargsvec.(tyi)) in
+ (make_rec_branch_arg env sigma
+ (nparrec,depPvec,larsign))
+ vecfi constrs (dest_subterms recargsvec.(tyi))
+ in
+
let j = (match depPvec.(tyi) with
| Some (_,c) when isRel c -> destRel c
- | _ -> assert false) in
+ | _ -> assert false)
+ in
+
+ (* Predicate in the context of the case *)
+
+ let depind' = build_dependent_inductive env indf' in
+ let arsign',_ = get_arity env indf' in
+ let deparsign' = (Anonymous,None,depind')::arsign' in
+
+ let pargs =
+ let nrpar = extended_rel_list (2*ndepar) lnonparrec
+ and nrar = if dep then extended_rel_list 0 deparsign'
+ else extended_rel_list 1 arsign'
+ in nrpar@nrar
+
+ in
+
+ (* body of i-th component of the mutual fixpoint *)
let deftyi =
let ci = make_default_case_info env RegularStyle indi in
- let indf' = lift_inductive_family nrec indf in
- let depind = build_dependent_inductive env indf' in
- let lnames' = Termops.lift_rel_context nrec lnames in
- let p =
- let arsign =
- if dep then (Anonymous,None,depind)::lnames' else lnames' in
- it_mkLambda_or_LetIn_name env
- (appvect
- (mkRel ((if dep then 1 else 0) + dect + j),
- extended_rel_vect 0 arsign)) arsign
+ let concl = applist (mkRel (dect+j+ndepar),pargs) in
+ let pred =
+ it_mkLambda_or_LetIn_name env
+ ((if dep then mkLambda_name env else mkLambda)
+ (Anonymous,depind',concl))
+ arsign'
in
it_mkLambda_or_LetIn_name env
- (lambda_create env
- (depind,mkCase (ci, lift (nar+1) p, mkRel 1, branches)))
- lnames'
+ (mkCase (ci, pred,
+ mkRel 1,
+ branches))
+ (lift_rel_context nrec deparsign)
in
- let typtyi =
- let ind = build_dependent_inductive env indf in
- it_mkProd_or_LetIn_name env
- (prod_create env
- (ind,
- (if dep then
- let ext_lnames = (Anonymous,None,ind)::lnames in
- let args = extended_rel_list 0 ext_lnames in
- applist (mkRel (nbconstruct+nar+j+1), args)
- else
- let args = extended_rel_list 1 lnames in
- applist (mkRel (nbconstruct+nar+j+1), args))))
- lnames
- in
- mrec (i+nctyi) (nar::ln) (typtyi::ltyp) (deftyi::ldef) rest
+
+ (* type of i-th component of the mutual fixpoint *)
+
+ let typtyi =
+ let concl =
+ let pargs = if dep then extended_rel_vect 0 deparsign
+ else extended_rel_vect 1 arsign
+ in appvect (mkRel (nbconstruct+ndepar+nonrecpar+j),pargs)
+ in it_mkProd_or_LetIn_name env
+ concl
+ deparsign
+ in
+ mrec (i+nctyi) (rel_context_nhyps arsign ::ln) (typtyi::ltyp)
+ (deftyi::ldef) rest
| [] ->
let fixn = Array.of_list (List.rev ln) in
let fixtyi = Array.of_list (List.rev ltyp) in
@@ -327,7 +386,7 @@ let mis_make_indrec env sigma listdepkind (ind,mib,mip) =
let names = Array.create nrec (Name(id_of_string "F")) in
mkFix ((fixn,p),(names,fixtyi,fixdef))
in
- mrec 0 [] [] []
+ mrec 0 [] [] []
in
let rec make_branch env i = function
| (indi,mibi,mipi,dep,_)::rest ->
@@ -338,8 +397,8 @@ let mis_make_indrec env sigma listdepkind (ind,mib,mip) =
make_branch env (i+j) rest
else
let recarg = (dest_subterms recargsvec.(tyi)).(j) in
- let vargs = extended_rel_list (nrec+i+j) lnamespar in
- let indf = (indi, vargs) in
+ let recarg = recargpar@recarg in
+ let vargs = extended_rel_list (nrec+i+j) lnamesparrec in
let cs = get_constructor (indi,mibi,mipi,vargs) (j+1) in
let p_0 =
type_rec_branch
@@ -353,23 +412,28 @@ let mis_make_indrec env sigma listdepkind (ind,mib,mip) =
in
let rec put_arity env i = function
| (indi,_,_,dep,kinds)::rest ->
- let indf = make_ind_family (indi,extended_rel_list i lnamespar) in
+ let indf = make_ind_family (indi,extended_rel_list i lnamesparrec) in
let typP = make_arity env dep indf (new_sort_in_family kinds) in
mkLambda_string "P" typP
(put_arity (push_rel (Anonymous,None,typP) env) (i+1) rest)
| [] ->
make_branch env 0 listdepkind
in
+
+ (* Body on make_one_rec *)
let (indi,mibi,mipi,dep,kind) = List.nth listdepkind p in
- let env' = push_rel_context lnamespar env in
+
if mis_is_recursive_subset
(List.map (fun (indi,_,_,_,_) -> snd indi) listdepkind)
mipi.mind_recargs
then
- it_mkLambda_or_LetIn_name env (put_arity env' 0 listdepkind) lnamespar
+ let env' = push_rel_context lnamesparrec env in
+ it_mkLambda_or_LetIn_name env (put_arity env' 0 listdepkind)
+ lnamesparrec
else
mis_make_case_com (Some dep) env sigma (indi,mibi,mipi) kind
in
+ (* Body of mis_make_indrec *)
list_tabulate make_one_rec nrec
(**********************************************************************)
@@ -385,20 +449,21 @@ let make_case_gen env = make_case_com None env
(**********************************************************************)
-(* [instanciate_indrec_scheme s rec] replace the sort of the scheme
+(* [instantiate_indrec_scheme s rec] replace the sort of the scheme
[rec] by [s] *)
let change_sort_arity sort =
let rec drec a = match kind_of_term a with
- | Cast (c,t) -> drec c
+ | Cast (c,_,_) -> drec c
| Prod (n,t,c) -> mkProd (n, t, drec c)
+ | LetIn (n,b,t,c) -> mkLetIn (n,b, t, drec c)
| Sort _ -> mkSort sort
| _ -> assert false
in
drec
(* [npar] is the number of expected arguments (then excluding letin's) *)
-let instanciate_indrec_scheme sort =
+let instantiate_indrec_scheme sort =
let rec drec npar elim =
match kind_of_term elim with
| Lambda (n,t,c) ->
@@ -407,13 +472,13 @@ let instanciate_indrec_scheme sort =
else
mkLambda (n, t, drec (npar-1) c)
| LetIn (n,b,t,c) -> mkLetIn (n,b,t,drec npar c)
- | _ -> anomaly "instanciate_indrec_scheme: wrong elimination type"
+ | _ -> anomaly "instantiate_indrec_scheme: wrong elimination type"
in
drec
(* Change the sort in the type of an inductive definition, builds the
corresponding eta-expanded term *)
-let instanciate_type_indrec_scheme sort npars term =
+let instantiate_type_indrec_scheme sort npars term =
let rec drec np elim =
match kind_of_term elim with
| Prod (n,t,c) ->
@@ -426,22 +491,27 @@ let instanciate_type_indrec_scheme sort npars term =
mkProd (n, t, c'), mkLambda (n, t, term')
| LetIn (n,b,t,c) -> let c',term' = drec np c in
mkLetIn (n,b,t,c'), mkLetIn (n,b,t,term')
- | _ -> anomaly "instanciate_type_indrec_scheme: wrong elimination type"
+ | _ -> anomaly "instantiate_type_indrec_scheme: wrong elimination type"
in
drec npars
(**********************************************************************)
(* Interface to build complex Scheme *)
+(* Check inductive types only occurs once
+(otherwise we obtain a meaning less scheme) *)
let check_arities listdepkind =
- List.iter
- (function (indi,mibi,mipi,dep,kind) ->
+ let _ = List.fold_left
+ (fun ln ((_,ni),mibi,mipi,dep,kind) ->
let id = mipi.mind_typename in
let kelim = mipi.mind_kelim in
- if not (List.exists ((=) kind) kelim) then
- raise
- (InductiveError (BadInduction (dep, id, new_sort_in_family kind))))
- listdepkind
+ if not (List.exists ((=) kind) kelim) then raise
+ (RecursionSchemeError (BadInduction (dep,id,new_sort_in_family kind)))
+ else if List.mem ni ln then raise
+ (RecursionSchemeError NotMutualInScheme)
+ else ni::ln)
+ [] listdepkind
+ in true
let build_mutual_indrec env sigma = function
| (mind,mib,mip,dep,s)::lrecspec ->
@@ -455,18 +525,18 @@ let build_mutual_indrec env sigma = function
let (mibi',mipi') = lookup_mind_specif env mind' in
(mind',mibi',mipi',dep',s')
else
- raise (InductiveError NotMutualInScheme))
+ raise (RecursionSchemeError NotMutualInScheme))
lrecspec)
in
let _ = check_arities listdepkind in
- mis_make_indrec env sigma listdepkind (mind,mib,mip)
+ mis_make_indrec env sigma listdepkind mib
| _ -> anomaly "build_indrec expects a non empty list of inductive types"
let build_indrec env sigma ind =
let (mib,mip) = lookup_mind_specif env ind in
let kind = family_of_sort mip.mind_sort in
let dep = kind <> InProp in
- List.hd (mis_make_indrec env sigma [(ind,mib,mip,dep,kind)] (ind,mib,mip))
+ List.hd (mis_make_indrec env sigma [(ind,mib,mip,dep,kind)] mib)
(**********************************************************************)
(* To handle old Case/Match syntax in Pretyping *)
@@ -483,7 +553,6 @@ let type_rec_branches recursive env sigma indt p c =
let tyi = snd ind in
let init_depPvec i = if i = tyi then Some(true,p) else None in
let depPvec = Array.init mib.mind_ntypes init_depPvec in
- let vargs = Array.of_list params in
let constructors = get_constructors env indf in
let lft =
array_map2
@@ -513,14 +582,14 @@ let lookup_eliminator ind_sp s =
let id = add_suffix ind_id (elimination_suffix s) in
(* Try first to get an eliminator defined in the same section as the *)
(* inductive type *)
- let ref = ConstRef (make_kn mp dp (label_of_id id)) in
+ let ref = ConstRef (make_con mp dp (label_of_id id)) in
try
let _ = sp_of_global ref in
- constr_of_reference ref
+ constr_of_global ref
with Not_found ->
(* Then try to get a user-defined eliminator in some other places *)
(* using short name (e.g. for "eq_rec") *)
- try constr_of_reference (Nametab.locate (make_short_qualid id))
+ try constr_of_global (Nametab.locate (make_short_qualid id))
with Not_found ->
errorlabstrm "default_elim"
(str "Cannot find the elimination combinator " ++
@@ -541,7 +610,7 @@ let lookup_eliminator ind_sp s =
with Not_found ->
(* Then try to get a user-defined eliminator in some other places *)
(* using short name (e.g. for "eq_rec") *)
- try constr_of_reference (Nametab.locate (make_short_qualid id))
+ try constr_of_global (Nametab.locate (make_short_qualid id))
with Not_found ->
errorlabstrm "default_elim"
(str "Cannot find the elimination combinator " ++
diff --git a/pretyping/indrec.mli b/pretyping/indrec.mli
index f6f76706..e5eb07f5 100644
--- a/pretyping/indrec.mli
+++ b/pretyping/indrec.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: indrec.mli,v 1.6.2.1 2004/07/16 19:30:45 herbelin Exp $ i*)
+(*i $Id: indrec.mli 7660 2005-12-17 21:13:48Z herbelin $ i*)
(*i*)
open Names
@@ -17,7 +17,16 @@ open Environ
open Evd
(*i*)
-(* Eliminations. *)
+(* Errors related to recursors building *)
+
+type recursion_scheme_error =
+ | NotAllowedCaseAnalysis of bool * sorts * inductive
+ | BadInduction of bool * identifier * sorts
+ | NotMutualInScheme
+
+exception RecursionSchemeError of recursion_scheme_error
+
+(** Eliminations *)
(* These functions build elimination predicate for Case tactic *)
@@ -29,11 +38,11 @@ val make_case_gen : env -> evar_map -> inductive -> sorts_family -> constr
of the inductive) *)
val build_indrec : env -> evar_map -> inductive -> constr
-val instanciate_indrec_scheme : sorts -> int -> constr -> constr
-val instanciate_type_indrec_scheme : sorts -> int -> constr -> types ->
+val instantiate_indrec_scheme : sorts -> int -> constr -> constr
+val instantiate_type_indrec_scheme : sorts -> int -> constr -> types ->
constr * types
-(* This builds complex [Scheme] *)
+(** Complex recursion schemes [Scheme] *)
val build_mutual_indrec :
env -> evar_map ->
@@ -41,7 +50,7 @@ val build_mutual_indrec :
* bool * sorts_family) list
-> constr list
-(* These are for old Case/Match typing *)
+(** Old Case/Match typing *)
val type_rec_branches : bool -> env -> evar_map -> inductive_type
-> constr -> constr -> constr array * constr
@@ -50,7 +59,11 @@ val make_rec_branch_arg :
int * ('b * constr) option array * int ->
constr -> constructor_summary -> wf_paths list -> constr
-(* *)
+(** Recursor names utilities *)
+
val lookup_eliminator : inductive -> sorts_family -> constr
val elimination_suffix : sorts_family -> string
val make_elimination_ident : identifier -> sorts_family -> identifier
+
+
+
diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml
index c33a261b..57d966f1 100644
--- a/pretyping/inductiveops.ml
+++ b/pretyping/inductiveops.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: inductiveops.ml,v 1.14.2.2 2004/12/29 12:15:00 herbelin Exp $ *)
+(* $Id: inductiveops.ml 8653 2006-03-22 09:41:17Z herbelin $ *)
open Util
open Names
@@ -18,6 +18,24 @@ open Declarations
open Environ
open Reductionops
+(* The following three functions are similar to the ones defined in
+ Inductive, but they expect an env *)
+
+let type_of_inductive env ind =
+ let specif = Inductive.lookup_mind_specif env ind in
+ Inductive.type_of_inductive specif
+
+(* Return type as quoted by the user *)
+let type_of_constructor env cstr =
+ let specif =
+ Inductive.lookup_mind_specif env (inductive_of_constructor cstr) in
+ Inductive.type_of_constructor cstr specif
+
+(* Return constructor types in normal form *)
+let arities_of_constructors env ind =
+ let specif = Inductive.lookup_mind_specif env ind in
+ Inductive.arities_of_constructors ind specif
+
(* [inductive_family] = [inductive_instance] applied to global parameters *)
type inductive_family = inductive * constr list
@@ -73,6 +91,7 @@ let mis_nf_constructor_type (ind,mib,mip) j =
substl (list_tabulate make_Ik ntypes) specif.(j-1)
(* Arity of constructors excluding parameters and local defs *)
+
let mis_constr_nargs indsp =
let (mib,mip) = Global.lookup_inductive indsp in
let recargs = dest_subterms mip.mind_recargs in
@@ -87,7 +106,21 @@ let mis_constr_nargs_env env (kn,i) =
let mis_constructor_nargs_env env ((kn,i),j) =
let mib = Environ.lookup_mind kn env in
let mip = mib.mind_packets.(i) in
- recarg_length mip.mind_recargs j + mip.mind_nparams
+ recarg_length mip.mind_recargs j + mib.mind_nparams
+
+let constructor_nrealargs env (ind,j) =
+ let (_,mip) = Inductive.lookup_mind_specif env ind in
+ recarg_length mip.mind_recargs j
+
+let constructor_nrealhyps env (ind,j) =
+ let (mib,mip) = Inductive.lookup_mind_specif env ind in
+ mip.mind_consnrealdecls.(j-1)
+
+(* Length of arity (w/o local defs) *)
+
+let inductive_nargs env ind =
+ let (mib,mip) = Inductive.lookup_mind_specif env ind in
+ mip.mind_nrealargs + rel_context_nhyps mib.mind_params_ctxt
(* Annotation for cases *)
let make_case_info env ind style pats_source =
@@ -97,7 +130,8 @@ let make_case_info env ind style pats_source =
style = style;
source = pats_source } in
{ ci_ind = ind;
- ci_npar = mip.mind_nparams;
+ ci_npar = mib.mind_nparams;
+ ci_cstr_nargs = mip.mind_consnrealdecls;
ci_pp_info = print_info }
let make_default_case_info env style ind =
@@ -122,6 +156,7 @@ let lift_constructor n cs = {
cs_args = lift_rel_context n cs.cs_args;
cs_concl_realargs = Array.map (liftn n (cs.cs_nargs+1)) cs.cs_concl_realargs
}
+(* Accept less parameters than in the signature *)
let instantiate_params t args sign =
let rec inst s t = function
@@ -133,17 +168,17 @@ let instantiate_params t args sign =
(match kind_of_term t with
| LetIn(_,_,_,t) -> inst ((substl s b)::s) t (ctxt,args)
| _ -> anomaly"instantiate_params: type, ctxt and args mismatch")
- | [], [] -> substl s t
+ | _, [] -> substl s t
| _ -> anomaly"instantiate_params: type, ctxt and args mismatch"
in inst [] t (List.rev sign,args)
let get_constructor (ind,mib,mip,params) j =
assert (j <= Array.length mip.mind_consnames);
let typi = mis_nf_constructor_type (ind,mib,mip) j in
- let typi = instantiate_params typi params mip.mind_params_ctxt in
+ let typi = instantiate_params typi params mib.mind_params_ctxt in
let (args,ccl) = decompose_prod_assum typi in
let (_,allargs) = decompose_app ccl in
- let vargs = list_skipn mip.mind_nparams allargs in
+ let vargs = list_skipn (List.length params) allargs in
{ cs_cstr = ith_constructor_of_inductive ind j;
cs_params = params;
cs_nargs = rel_context_length args;
@@ -175,8 +210,7 @@ let build_dependent_constructor cs =
let build_dependent_inductive env ((ind, params) as indf) =
let arsign,_ = get_arity env indf in
- let (mib,mip) = Inductive.lookup_mind_specif env ind in
- let nrealargs = mip.mind_nrealargs in
+ let nrealargs = List.length arsign in
applist
(mkInd ind,
(List.map (lift nrealargs) params)@(extended_rel_list 0 arsign))
@@ -189,7 +223,7 @@ let make_arity_signature env dep indf =
(* We need names everywhere *)
name_context env
((Anonymous,None,build_dependent_inductive env indf)::arsign)
- (* Costly: would be better to name one for all at definition time *)
+ (* Costly: would be better to name once for all at definition time *)
else
(* No need to enforce names *)
arsign
@@ -225,7 +259,7 @@ let find_rectype env sigma c =
match kind_of_term t with
| Ind ind ->
let (mib,mip) = Inductive.lookup_mind_specif env ind in
- let (par,rargs) = list_chop mip.mind_nparams l in
+ let (par,rargs) = list_chop mib.mind_nparams l in
IndType((ind, par),rargs)
| _ -> raise Not_found
@@ -247,59 +281,60 @@ let find_coinductive env sigma c =
(***********************************************)
-(* find appropriate names for pattern variables. Useful in the
- Case tactic. *)
+(* find appropriate names for pattern variables. Useful in the Case
+ and Inversion (case_then_using et case_nodep_then_using) tactics. *)
-let is_dep_predicate env kelim pred nodep_ar =
- let rec srec env pval pt nodep_ar =
- let pt' = whd_betadeltaiota env Evd.empty pt in
+let is_predicate_explicitly_dep env pred nodep_ar =
+ let rec srec env pval nodep_ar =
let pv' = whd_betadeltaiota env Evd.empty pval in
- match kind_of_term pv', kind_of_term pt', kind_of_term nodep_ar with
- | Lambda (na,t,b), Prod (_,_,a), Prod (_,_,a') ->
- srec (push_rel_assum (na,t) env) b a a'
- | _, Prod (na,t,a), Prod (_,_,a') ->
- srec (push_rel_assum (na,t) env) (lift 1 pv') a a'
- | Lambda (_,_,b), Prod (_,_,_), _ -> (*dependent (mkRel 1) b*) true
- | _, Prod (_,_,_), _ -> true
- | _ -> false in
- srec env pred.uj_val pred.uj_type nodep_ar
-
-let is_dependent_elimination_predicate env pred indf =
- let (ind,params) = indf in
- let (_,mip) = Inductive.lookup_mind_specif env ind in
- let kelim = mip.mind_kelim in
- let arsign,s = get_arity env indf in
- let glob_t = it_mkProd_or_LetIn (mkSort s) arsign in
- is_dep_predicate env kelim pred glob_t
-
-let is_dep_arity env kelim predty nodep_ar =
- let rec srec pt nodep_ar =
- let pt' = whd_betadeltaiota env Evd.empty pt in
- match kind_of_term pt', kind_of_term nodep_ar with
- | Prod (_,a1,a2), Prod (_,a1',a2') -> srec a2 a2'
- | Prod (_,a1,a2), _ -> true
- | _ -> false in
- srec predty nodep_ar
-
-let is_dependent_elimination env predty indf =
- let (ind,params) = indf in
- let (_,mip) = Inductive.lookup_mind_specif env ind in
- let kelim = mip.mind_kelim in
+ match kind_of_term pv', kind_of_term nodep_ar with
+ | Lambda (na,t,b), Prod (_,_,a') ->
+ srec (push_rel_assum (na,t) env) b a'
+ | Lambda (na,_,_), _ ->
+
+ (* The following code has impact on the introduction names
+ given by the tactics "case" and "inversion": when the
+ elimination is not dependent, "case" uses Anonymous for
+ inductive types in Prop and names created by mkProd_name for
+ inductive types in Set/Type while "inversion" uses anonymous
+ for inductive types both in Prop and Set/Type !!
+
+ Previously, whether names were created or not relied on
+ whether the predicate created in Indrec.make_case_com had a
+ dependent arity or not. To avoid different predicates
+ printed the same in v8, all predicates built in indrec.ml
+ got a dependent arity (Aug 2004). The new way to decide
+ whether names have to be created or not is to use an
+ Anonymous or Named variable to enforce the expected
+ dependency status (of course, Anonymous implies non
+ dependent, but not conversely).
+
+ At the end, this is only to preserve the compatibility: a
+ check whether the predicate is actually dependent or not
+ would indeed be more natural! *)
+
+ na <> Anonymous
+
+ | _ -> anomaly "Non eta-expanded dep-expanded \"match\" predicate"
+ in
+ srec env pred nodep_ar
+
+let is_elim_predicate_explicitly_dependent env pred indf =
let arsign,s = get_arity env indf in
let glob_t = it_mkProd_or_LetIn (mkSort s) arsign in
- is_dep_arity env kelim predty glob_t
+ is_predicate_explicitly_dep env pred glob_t
let set_names env n brty =
let (ctxt,cl) = decompose_prod_n_assum n brty in
it_mkProd_or_LetIn_name env cl ctxt
let set_pattern_names env ind brv =
- let (_,mip) = Inductive.lookup_mind_specif env ind in
+ let (mib,mip) = Inductive.lookup_mind_specif env ind in
let arities =
Array.map
(fun c ->
rel_context_length (fst (decompose_prod_assum c)) -
- mip.mind_nparams)
+ mib.mind_nparams)
mip.mind_nf_lc in
array_map2 (set_names env) arities brv
@@ -308,8 +343,8 @@ let type_case_branches_with_names env indspec pj c =
let (ind,args) = indspec in
let (lbrty,conclty,_) = Inductive.type_case_branches env indspec pj c in
let (mib,mip) = Inductive.lookup_mind_specif env ind in
- let params = list_firstn mip.mind_nparams args in
- if is_dependent_elimination_predicate env pj (ind,params) then
+ let params = list_firstn mib.mind_nparams args in
+ if is_elim_predicate_explicitly_dependent env pj.uj_val (ind,params) then
(set_pattern_names env ind lbrty, conclty)
else (lbrty, conclty)
@@ -342,11 +377,15 @@ let control_only_guard env =
Array.iter control_rec tys;
Array.iter control_rec bds;
| Case(_,p,c,b) -> control_rec p;control_rec c;Array.iter control_rec b
- | Evar (_,cl) -> Array.iter control_rec cl
+ | Evar (_,cl) -> Array.iter control_rec cl
| App (c,cl) -> control_rec c; Array.iter control_rec cl
- | Cast (c1,c2) -> control_rec c1; control_rec c2
+ | Cast (c1,_, c2) -> control_rec c1; control_rec c2
| Prod (_,c1,c2) -> control_rec c1; control_rec c2
| Lambda (_,c1,c2) -> control_rec c1; control_rec c2
| LetIn (_,c1,c2,c3) -> control_rec c1; control_rec c2; control_rec c3
in
control_rec
+
+let subst_inductive subst (kn,i as ind) =
+ let kn' = Mod_subst.subst_kn subst kn in
+ if kn == kn' then ind else (kn',i)
diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli
index 8cfa9b3c..2993eed3 100644
--- a/pretyping/inductiveops.mli
+++ b/pretyping/inductiveops.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: inductiveops.mli,v 1.10.2.3 2005/01/21 17:19:37 herbelin Exp $ i*)
+(*i $Id: inductiveops.mli 7955 2006-01-30 22:56:15Z herbelin $ i*)
open Names
open Term
@@ -14,6 +14,17 @@ open Declarations
open Environ
open Evd
+(* The following three functions are similar to the ones defined in
+ Inductive, but they expect an env *)
+
+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
+
(* An inductive type with its parameters *)
type inductive_family
val make_ind_family : inductive * constr list -> inductive_family
@@ -46,6 +57,11 @@ val mis_constr_nargs_env : env -> inductive -> int array
val mis_constructor_nargs_env : env -> constructor -> int
+val constructor_nrealargs : env -> constructor -> int
+val constructor_nrealhyps : env -> constructor -> int
+
+val inductive_nargs : env -> inductive -> int
+
type constructor_summary = {
cs_cstr : constructor;
cs_params : constr list;
@@ -74,9 +90,6 @@ val find_inductive : env -> evar_map -> constr -> inductive * constr list
val find_coinductive : env -> evar_map -> constr -> inductive * constr list
(********************)
-(* Determines if a case predicate type corresponds to dependent elimination *)
-val is_dependent_elimination :
- env -> types -> inductive_family -> bool
(* Builds the case predicate arity (dependent or not) *)
val arity_of_case_predicate :
@@ -91,3 +104,5 @@ val make_default_case_info : env -> case_style -> inductive -> case_info
(********************)
val control_only_guard : env -> types -> unit
+
+val subst_inductive : Mod_subst.substitution -> inductive -> inductive
diff --git a/pretyping/instantiate.ml b/pretyping/instantiate.ml
deleted file mode 100644
index 702cdfea..00000000
--- a/pretyping/instantiate.ml
+++ /dev/null
@@ -1,68 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-(* $Id: instantiate.ml,v 1.3.2.1 2004/07/16 19:30:45 herbelin Exp $ *)
-
-open Pp
-open Util
-open Names
-open Term
-open Sign
-open Evd
-open Declarations
-open Environ
-
-let is_id_inst inst =
- let is_id (id,c) = match kind_of_term c with
- | Var id' -> id = id'
- | _ -> false
- in
- List.for_all is_id inst
-
-(* Vérifier que les instances des let-in sont compatibles ?? *)
-let instantiate_sign_including_let sign args =
- let rec instrec = function
- | ((id,b,_) :: sign, c::args) -> (id,c) :: (instrec (sign,args))
- | ([],[]) -> []
- | ([],_) | (_,[]) ->
- anomaly "Signature and its instance do not match"
- in
- instrec (sign,args)
-
-let instantiate_evar sign c args =
- let inst = instantiate_sign_including_let sign args in
- if is_id_inst inst then
- c
- else
- replace_vars inst c
-
-(* Existentials. *)
-
-let existential_type sigma (n,args) =
- let info =
- try Evd.map sigma n
- with Not_found ->
- anomaly ("Evar "^(string_of_existential n)^" was not declared") in
- let hyps = info.evar_hyps in
- instantiate_evar hyps info.evar_concl (Array.to_list args)
-
-exception NotInstantiatedEvar
-
-let existential_value sigma (n,args) =
- let info = Evd.map sigma n in
- let hyps = info.evar_hyps in
- match evar_body info with
- | Evar_defined c ->
- instantiate_evar hyps c (Array.to_list args)
- | Evar_empty ->
- raise NotInstantiatedEvar
-
-let existential_opt_value sigma ev =
- try Some (existential_value sigma ev)
- with NotInstantiatedEvar -> None
-
diff --git a/pretyping/instantiate.mli b/pretyping/instantiate.mli
deleted file mode 100644
index 44c4d579..00000000
--- a/pretyping/instantiate.mli
+++ /dev/null
@@ -1,25 +0,0 @@
-(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
-(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
-(************************************************************************)
-
-(*i $Id: instantiate.mli,v 1.2.14.1 2004/07/16 19:30:45 herbelin Exp $ i*)
-
-(*i*)
-open Names
-open Term
-open Evd
-open Sign
-open Environ
-(*i*)
-
-(*s [existential_value sigma ev] raises [NotInstantiatedEvar] if [ev] has
-no body and [Not_found] if it does not exist in [sigma] *)
-
-exception NotInstantiatedEvar
-val existential_value : evar_map -> existential -> constr
-val existential_type : evar_map -> existential -> types
-val existential_opt_value : evar_map -> existential -> constr option
diff --git a/pretyping/matching.ml b/pretyping/matching.ml
index bdab3b5b..5ee245b5 100644
--- a/pretyping/matching.ml
+++ b/pretyping/matching.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: matching.ml,v 1.3.2.1 2004/07/16 19:30:45 herbelin Exp $ *)
+(* $Id: matching.ml 7970 2006-02-01 15:09:07Z herbelin $ *)
(*i*)
open Util
@@ -89,11 +89,15 @@ let matches_core convert allow_partial_app pat c =
| PMeta (Some n), m ->
let depth = List.length stk in
- let frels = Intset.elements (free_rels cT) in
- if List.for_all (fun i -> i > depth) frels then
- constrain (n,lift (-depth) cT) sigma
- else
- raise PatternMatchingFailure
+ if depth = 0 then
+ (* Optimisation *)
+ constrain (n,cT) sigma
+ else
+ let frels = Intset.elements (free_rels cT) in
+ if List.for_all (fun i -> i > depth) frels then
+ constrain (n,lift (-depth) cT) sigma
+ else
+ raise PatternMatchingFailure
| PMeta None, m -> sigma
@@ -101,7 +105,7 @@ let matches_core convert allow_partial_app pat c =
| PVar v1, Var v2 when v1 = v2 -> sigma
- | PRef ref, _ when constr_of_reference ref = cT -> sigma
+ | PRef ref, _ when constr_of_global ref = cT -> sigma
| PRel n1, Rel n2 when n1 = n2 -> sigma
@@ -109,6 +113,9 @@ let matches_core convert allow_partial_app pat c =
| PSort (RType _), Sort (Type _) -> sigma
+ | PApp (PApp (h, a1), a2), _ ->
+ sorec stk sigma (PApp(h,Array.append a1 a2)) t
+
| PApp (PMeta (Some n),args1), App (c2,args2) when allow_partial_app ->
let p = Array.length args2 - Array.length args1 in
if p>=0 then
@@ -139,7 +146,7 @@ let matches_core convert allow_partial_app pat c =
| PRef (ConstRef _ as ref), _ when convert <> None ->
let (env,evars) = out_some convert in
- let c = constr_of_reference ref in
+ let c = constr_of_global ref in
if is_conv env evars c cT then sigma
else raise PatternMatchingFailure
@@ -176,15 +183,15 @@ let special_meta = (-1)
(* Tries to match a subterm of [c] with [pat] *)
let rec sub_match nocc pat c =
match kind_of_term c with
- | Cast (c1,c2) ->
+ | Cast (c1,k,c2) ->
(try authorized_occ nocc ((matches pat c), mkMeta special_meta) with
| PatternMatchingFailure ->
let (lm,lc) = try_sub_match nocc pat [c1] in
- (lm,mkCast (List.hd lc, c2))
+ (lm,mkCast (List.hd lc, k,c2))
| NextOccurrence nocc ->
let (lm,lc) = try_sub_match (nocc - 1) pat [c1] in
- (lm,mkCast (List.hd lc, c2)))
- | Lambda (x,c1,c2) ->
+ (lm,mkCast (List.hd lc, k,c2)))
+ | Lambda (x,c1,c2) ->
(try authorized_occ nocc ((matches pat c), mkMeta special_meta) with
| PatternMatchingFailure ->
let (lm,lc) = try_sub_match nocc pat [c1;c2] in
@@ -242,6 +249,10 @@ and try_sub_match nocc pat lc =
| NextOccurrence nocc -> try_sub_match_rec nocc pat (lacc@[c]) tl) in
try_sub_match_rec nocc pat [] lc
+let match_subterm nocc pat c =
+ try sub_match nocc pat c
+ with NextOccurrence _ -> raise PatternMatchingFailure
+
let is_matching pat n =
try let _ = matches pat n in true
with PatternMatchingFailure -> false
diff --git a/pretyping/matching.mli b/pretyping/matching.mli
index 2f666880..e6065c68 100644
--- a/pretyping/matching.mli
+++ b/pretyping/matching.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: matching.mli,v 1.3.2.2 2005/01/21 16:42:37 herbelin Exp $ i*)
+(*i $Id: matching.mli 6616 2005-01-21 17:18:23Z herbelin $ i*)
(*i*)
open Names
@@ -39,11 +39,10 @@ val is_matching : constr_pattern -> constr -> bool
val matches_conv :env -> Evd.evar_map -> constr_pattern -> constr -> patvar_map
-(* To skip to the next occurrence *)
-exception NextOccurrence of int
-
-(* Tries to match a **closed** subterm of [c] with [pat] *)
-val sub_match : int -> constr_pattern -> constr -> patvar_map * constr
+(* [match_subterm n pat c] returns the substitution and the context
+ corresponding to the [n+1]th **closed** subterm of [c] matching [pat];
+ It raises PatternMatchingFailure if no such matching exists *)
+val match_subterm : int -> constr_pattern -> constr -> patvar_map * constr
(* [is_matching_conv env sigma pat c] tells if [c] matches against [pat]
up to conversion for constants in patterns *)
diff --git a/pretyping/pattern.ml b/pretyping/pattern.ml
index f58a12c6..390b884c 100644
--- a/pretyping/pattern.ml
+++ b/pretyping/pattern.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: pattern.ml,v 1.24.2.2 2004/11/26 17:51:52 herbelin Exp $ *)
+(* $Id: pattern.ml 7732 2005-12-26 13:51:24Z herbelin $ *)
open Util
open Names
@@ -17,18 +17,13 @@ open Rawterm
open Environ
open Nametab
open Pp
+open Mod_subst
(* Metavariables *)
type patvar_map = (patvar * constr) list
-let patvar_of_int n =
- let p = if !Options.v7 & not (Options.do_translate ()) then "?" else "X"
- in
- Names.id_of_string (p ^ string_of_int n)
let pr_patvar = pr_id
-let patvar_of_int_v7 n = Names.id_of_string ("?" ^ string_of_int n)
-
(* Patterns *)
type constr_pattern =
@@ -62,57 +57,6 @@ let rec occur_meta_pattern = function
| PMeta _ | PSoApp _ -> true
| PEvar _ | PVar _ | PRef _ | PRel _ | PSort _ | PFix _ | PCoFix _ -> false
-let rec subst_pattern subst pat = match pat with
- | PRef ref ->
- let ref' = subst_global subst ref in
- if ref' == ref then pat else
- PRef ref'
- | PVar _
- | PEvar _
- | PRel _ -> pat
- | PApp (f,args) ->
- let f' = subst_pattern subst f in
- let args' = array_smartmap (subst_pattern subst) args in
- if f' == f && args' == args then pat else
- PApp (f',args')
- | PSoApp (i,args) ->
- let args' = list_smartmap (subst_pattern subst) args in
- if args' == args then pat else
- PSoApp (i,args')
- | PLambda (name,c1,c2) ->
- let c1' = subst_pattern subst c1 in
- let c2' = subst_pattern subst c2 in
- if c1' == c1 && c2' == c2 then pat else
- PLambda (name,c1',c2')
- | PProd (name,c1,c2) ->
- let c1' = subst_pattern subst c1 in
- let c2' = subst_pattern subst c2 in
- if c1' == c1 && c2' == c2 then pat else
- PProd (name,c1',c2')
- | PLetIn (name,c1,c2) ->
- let c1' = subst_pattern subst c1 in
- let c2' = subst_pattern subst c2 in
- if c1' == c1 && c2' == c2 then pat else
- PLetIn (name,c1',c2')
- | PSort _
- | PMeta _ -> pat
- | PCase (cs,typ, c, branches) ->
- let typ' = option_smartmap (subst_pattern subst) typ in
- let c' = subst_pattern subst c in
- let branches' = array_smartmap (subst_pattern subst) branches in
- if typ' == typ && c' == c && branches' == branches then pat else
- PCase(cs,typ', c', branches')
- | PFix fixpoint ->
- let cstr = mkFix fixpoint in
- let fixpoint' = destFix (subst_mps subst cstr) in
- if fixpoint' == fixpoint then pat else
- PFix fixpoint'
- | PCoFix cofixpoint ->
- let cstr = mkCoFix cofixpoint in
- let cofixpoint' = destCoFix (subst_mps subst cstr) in
- if cofixpoint' == cofixpoint then pat else
- PCoFix cofixpoint'
-
type constr_label =
| ConstNode of constant
| IndNode of inductive
@@ -121,33 +65,14 @@ type constr_label =
exception BoundPattern;;
-let label_of_ref = function
- | ConstRef sp -> ConstNode sp
- | IndRef sp -> IndNode sp
- | ConstructRef sp -> CstrNode sp
- | VarRef id -> VarNode id
-
-let ref_of_label = function
- | ConstNode sp -> ConstRef sp
- | IndNode sp -> IndRef sp
- | CstrNode sp -> ConstructRef sp
- | VarNode id -> VarRef id
-
-let subst_label subst cstl =
- let ref = ref_of_label cstl in
- let ref' = subst_global subst ref in
- if ref' == ref then cstl else
- label_of_ref ref'
-
-
let rec head_pattern_bound t =
match t with
| PProd (_,_,b) -> head_pattern_bound b
| PLetIn (_,_,b) -> head_pattern_bound b
| PApp (c,args) -> head_pattern_bound c
| PCase (_,p,c,br) -> head_pattern_bound c
- | PRef r -> label_of_ref r
- | PVar id -> VarNode id
+ | PRef r -> r
+ | PVar id -> VarRef id
| PEvar _ | PRel _ | PMeta _ | PSoApp _ | PSort _ | PFix _
-> raise BoundPattern
(* Perhaps they were arguments, but we don't beta-reduce *)
@@ -155,10 +80,10 @@ let rec head_pattern_bound t =
| PCoFix _ -> anomaly "head_pattern_bound: not a type"
let head_of_constr_reference c = match kind_of_term c with
- | Const sp -> ConstNode sp
- | Construct sp -> CstrNode sp
- | Ind sp -> IndNode sp
- | Var id -> VarNode id
+ | Const sp -> ConstRef sp
+ | Construct sp -> ConstructRef sp
+ | Ind sp -> IndRef sp
+ | Var id -> VarRef id
| _ -> anomaly "Not a rigid reference"
let rec pattern_of_constr t =
@@ -168,7 +93,7 @@ let rec pattern_of_constr t =
| Var id -> PVar id
| Sort (Prop c) -> PSort (RProp c)
| Sort (Type _) -> PSort (RType None)
- | Cast (c,_) -> pattern_of_constr c
+ | Cast (c,_,_) -> pattern_of_constr c
| LetIn (na,c,_,b) -> PLetIn (na,pattern_of_constr c,pattern_of_constr b)
| Prod (na,c,b) -> PProd (na,pattern_of_constr c,pattern_of_constr b)
| Lambda (na,c,b) -> PLambda (na,pattern_of_constr c,pattern_of_constr b)
@@ -198,9 +123,61 @@ let rec inst lvar = function
(* Non recursive *)
| (PEvar _ | PRel _ | PRef _ | PSort _ | PMeta _ as x) -> x
(* Bound to terms *)
- | (PFix _ | PCoFix _ as r) ->
+ | (PFix _ | PCoFix _) ->
error ("Not instantiable pattern")
+let rec subst_pattern subst pat = match pat with
+ | PRef ref ->
+ let ref',t = subst_global subst ref in
+ if ref' == ref then pat else
+ pattern_of_constr t
+ | PVar _
+ | PEvar _
+ | PRel _ -> pat
+ | PApp (f,args) ->
+ let f' = subst_pattern subst f in
+ let args' = array_smartmap (subst_pattern subst) args in
+ if f' == f && args' == args then pat else
+ PApp (f',args')
+ | PSoApp (i,args) ->
+ let args' = list_smartmap (subst_pattern subst) args in
+ if args' == args then pat else
+ PSoApp (i,args')
+ | PLambda (name,c1,c2) ->
+ let c1' = subst_pattern subst c1 in
+ let c2' = subst_pattern subst c2 in
+ if c1' == c1 && c2' == c2 then pat else
+ PLambda (name,c1',c2')
+ | PProd (name,c1,c2) ->
+ let c1' = subst_pattern subst c1 in
+ let c2' = subst_pattern subst c2 in
+ if c1' == c1 && c2' == c2 then pat else
+ PProd (name,c1',c2')
+ | PLetIn (name,c1,c2) ->
+ let c1' = subst_pattern subst c1 in
+ let c2' = subst_pattern subst c2 in
+ if c1' == c1 && c2' == c2 then pat else
+ PLetIn (name,c1',c2')
+ | PSort _
+ | PMeta _ -> pat
+ | PCase (cs,typ, c, branches) ->
+ let typ' = option_smartmap (subst_pattern subst) typ in
+ let c' = subst_pattern subst c in
+ let branches' = array_smartmap (subst_pattern subst) branches in
+ if typ' == typ && c' == c && branches' == branches then pat else
+ PCase(cs,typ', c', branches')
+ | PFix fixpoint ->
+ let cstr = mkFix fixpoint in
+ let fixpoint' = destFix (subst_mps subst cstr) in
+ if fixpoint' == fixpoint then pat else
+ PFix fixpoint'
+ | PCoFix cofixpoint ->
+ let cstr = mkCoFix cofixpoint in
+ let cofixpoint' = destCoFix (subst_mps subst cstr) in
+ if cofixpoint' == cofixpoint then pat else
+ PCoFix cofixpoint'
+
+
let instantiate_pattern = inst
let rec pat_of_raw metas vars = function
@@ -230,30 +207,25 @@ let rec pat_of_raw metas vars = function
PSort s
| RHole _ ->
PMeta None
- | RCast (_,c,t) ->
+ | RCast (_,c,_,t) ->
Options.if_verbose
Pp.warning "Cast not taken into account in constr pattern";
pat_of_raw metas vars c
- | ROrderedCase (_,st,po,c,br,_) ->
- PCase ((None,st),option_app (pat_of_raw metas vars) po,
- pat_of_raw metas vars c,
- Array.map (pat_of_raw metas vars) br)
| RIf (_,c,(_,None),b1,b2) ->
PCase ((None,IfStyle),None, pat_of_raw metas vars c,
[|pat_of_raw metas vars b1; pat_of_raw metas vars b2|])
- | RCases (loc,(po,_),[c,_],brs) ->
+ | RCases (loc,None,[c,_],brs) ->
let sp =
match brs with
| (_,_,[PatCstr(_,(ind,_),_,_)],_)::_ -> Some ind
| _ -> None in
- (* When po disappears: switch to rtn type *)
- PCase ((sp,Term.RegularStyle),option_app (pat_of_raw metas vars) po,
+ PCase ((sp,Term.RegularStyle),None,
pat_of_raw metas vars c,
Array.init (List.length brs)
(pat_of_raw_branch loc metas vars sp brs))
| r ->
let loc = loc_of_rawconstr r in
- user_err_loc (loc,"pattern_of_rawconstr", Pp.str "Not supported pattern")
+ user_err_loc (loc,"pattern_of_rawconstr", Pp.str "Pattern not supported")
and pat_of_raw_branch loc metas vars ind brs i =
let bri = List.filter
diff --git a/pretyping/pattern.mli b/pretyping/pattern.mli
index cf0d4528..25a57ed2 100644
--- a/pretyping/pattern.mli
+++ b/pretyping/pattern.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: pattern.mli,v 1.17.2.1 2004/07/16 19:30:45 herbelin Exp $ i*)
+(*i $Id: pattern.mli 7732 2005-12-26 13:51:24Z herbelin $ i*)
(*i*)
open Pp
@@ -17,6 +17,7 @@ open Environ
open Libnames
open Nametab
open Rawterm
+open Mod_subst
(*i*)
(* Pattern variables *)
@@ -24,10 +25,6 @@ open Rawterm
type patvar_map = (patvar * constr) list
val pr_patvar : patvar -> std_ppcmds
-(* Only for v7 parsing/printing *)
-val patvar_of_int : int -> patvar
-val patvar_of_int_v7 : int -> patvar
-
(* Patterns *)
type constr_pattern =
@@ -51,28 +48,18 @@ val occur_meta_pattern : constr_pattern -> bool
val subst_pattern : substitution -> constr_pattern -> constr_pattern
-type constr_label =
- | ConstNode of constant
- | IndNode of inductive
- | CstrNode of constructor
- | VarNode of identifier
-
-val label_of_ref : global_reference -> constr_label
-
-val subst_label : substitution -> constr_label -> constr_label
-
exception BoundPattern
(* [head_pattern_bound t] extracts the head variable/constant of the
type [t] or raises [BoundPattern] (even if a sort); it raises an anomaly
if [t] is an abstraction *)
-val head_pattern_bound : constr_pattern -> constr_label
+val head_pattern_bound : constr_pattern -> global_reference
(* [head_of_constr_reference c] assumes [r] denotes a reference and
returns its label; raises an anomaly otherwise *)
-val head_of_constr_reference : Term.constr -> constr_label
+val head_of_constr_reference : Term.constr -> global_reference
(* [pattern_of_constr c] translates a term [c] with metavariables into
a pattern; currently, no destructor (Cases, Fix, Cofix) and no
diff --git a/pretyping/pretype_errors.ml b/pretyping/pretype_errors.ml
index fee1522f..48295c92 100644
--- a/pretyping/pretype_errors.ml
+++ b/pretyping/pretype_errors.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: pretype_errors.ml,v 1.25.2.2 2004/07/16 19:30:45 herbelin Exp $ *)
+(* $Id: pretype_errors.ml 8688 2006-04-07 15:08:12Z msozeau $ *)
open Util
open Stdpp
@@ -24,8 +24,12 @@ type pretype_error =
| CantFindCaseType of constr
(* Unification *)
| OccurCheck of existential_key * constr
- | NotClean of existential_key * constr * hole_kind
- | UnsolvableImplicit of hole_kind
+ | NotClean of existential_key * constr * Evd.hole_kind
+ | UnsolvableImplicit of Evd.hole_kind
+ | CannotUnify of constr * constr
+ | CannotUnifyBindingType of constr * constr
+ | CannotGeneralize of constr
+ | NoOccurrenceFound of constr
(* Pretyping *)
| VarNotFound of identifier
| UnexpectedType of constr * constr
@@ -33,6 +37,12 @@ type pretype_error =
exception PretypeError of env * pretype_error
+let precatchable_exception = function
+ | Util.UserError _ | TypeError _ | PretypeError _
+ | Stdpp.Exc_located(_,(Util.UserError _ | TypeError _ |
+ Nametab.GlobalizationError _ | PretypeError _)) -> true
+ | _ -> false
+
let nf_evar = Reductionops.nf_evar
let j_nf_evar sigma j =
{ uj_val = nf_evar sigma j.uj_val;
@@ -43,7 +53,7 @@ let tj_nf_evar sigma {utj_val=v;utj_type=t} =
{utj_val=type_app (nf_evar sigma) v;utj_type=t}
let env_ise sigma env =
- let sign = named_context env in
+ let sign = named_context_val env in
let ctxt = rel_context env in
let env0 = reset_with_named_context sign env in
Sign.fold_rel_context
@@ -126,6 +136,9 @@ let error_ill_typed_rec_body_loc loc env sigma i na jl tys =
IllTypedRecBody (i,na,jv_nf_evar sigma jl,
Array.map (nf_evar sigma) tys))
+let error_not_a_type_loc loc env sigma j =
+ raise_located_type_error (loc, env, sigma, NotAType (j_nf_evar sigma j))
+
(*s Implicit arguments synthesis errors. It is hard to find
a precise location. *)
@@ -141,6 +154,12 @@ let error_not_clean env sigma ev c (loc,k) =
let error_unsolvable_implicit loc env sigma e =
raise_with_loc loc (PretypeError (env_ise sigma env, UnsolvableImplicit e))
+let error_cannot_unify env sigma (m,n) =
+ raise (PretypeError (env_ise sigma env,CannotUnify (m,n)))
+
+let error_cannot_coerce env sigma (m,n) =
+ raise (PretypeError (env_ise sigma env,CannotUnify (m,n)))
+
(*s Ml Case errors *)
let error_cant_find_case_type_loc loc env sigma expr =
diff --git a/pretyping/pretype_errors.mli b/pretyping/pretype_errors.mli
index ebeff99d..3c78d48d 100644
--- a/pretyping/pretype_errors.mli
+++ b/pretyping/pretype_errors.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: pretype_errors.mli,v 1.25.2.3 2004/07/16 19:30:45 herbelin Exp $ i*)
+(*i $Id: pretype_errors.mli 8688 2006-04-07 15:08:12Z msozeau $ i*)
(*i*)
open Pp
@@ -26,8 +26,12 @@ type pretype_error =
| CantFindCaseType of constr
(* Unification *)
| OccurCheck of existential_key * constr
- | NotClean of existential_key * constr * hole_kind
- | UnsolvableImplicit of hole_kind
+ | NotClean of existential_key * constr * Evd.hole_kind
+ | UnsolvableImplicit of Evd.hole_kind
+ | CannotUnify of constr * constr
+ | CannotUnifyBindingType of constr * constr
+ | CannotGeneralize of constr
+ | NoOccurrenceFound of constr
(* Pretyping *)
| VarNotFound of identifier
| UnexpectedType of constr * constr
@@ -35,6 +39,8 @@ type pretype_error =
exception PretypeError of env * pretype_error
+val precatchable_exception : exn -> bool
+
(* Presenting terms without solved evars *)
val nf_evar : Evd.evar_map -> constr -> constr
val j_nf_evar : Evd.evar_map -> unsafe_judgment -> unsafe_judgment
@@ -73,14 +79,22 @@ val error_ill_typed_rec_body_loc :
loc -> env -> Evd.evar_map ->
int -> name array -> unsafe_judgment array -> types array -> 'b
+val error_not_a_type_loc :
+ loc -> env -> Evd.evar_map -> unsafe_judgment -> 'b
+
+val error_cannot_coerce : env -> Evd.evar_map -> constr * constr -> 'b
+
(*s Implicit arguments synthesis errors *)
val error_occur_check : env -> Evd.evar_map -> existential_key -> constr -> 'b
val error_not_clean :
- env -> Evd.evar_map -> existential_key -> constr -> loc * hole_kind -> 'b
+ env -> Evd.evar_map -> existential_key -> constr -> loc * Evd.hole_kind -> 'b
+
+val error_unsolvable_implicit :
+ loc -> env -> Evd.evar_map -> Evd.hole_kind -> 'b
-val error_unsolvable_implicit : loc -> env -> Evd.evar_map -> hole_kind -> 'b
+val error_cannot_unify : env -> Evd.evar_map -> constr * constr -> 'b
(*s Ml Case errors *)
diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml
index bb0e74bb..2d1e297f 100644
--- a/pretyping/pretyping.ml
+++ b/pretyping/pretyping.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: pretyping.ml,v 1.123.2.5 2005/11/29 21:40:52 letouzey Exp $ *)
+(* $Id: pretyping.ml 8695 2006-04-10 16:33:52Z msozeau $ *)
open Pp
open Util
@@ -20,6 +20,7 @@ open Environ
open Type_errors
open Typeops
open Libnames
+open Nameops
open Classops
open List
open Recordops
@@ -27,86 +28,18 @@ open Evarutil
open Pretype_errors
open Rawterm
open Evarconv
-open Coercion
open Pattern
open Dyn
+type typing_constraint = OfType of types option | IsType
+type var_map = (identifier * unsafe_judgment) list
+type unbound_ltac_var_map = (identifier * identifier option) list
(************************************************************************)
(* This concerns Cases *)
open Declarations
open Inductive
open Inductiveops
-open Instantiate
-
-let lift_context n l =
- let k = List.length l in
- list_map_i (fun i (name,c) -> (name,liftn n (k-i) c)) 0 l
-
-let transform_rec loc env sigma (pj,c,lf) indt =
- let p = pj.uj_val in
- let (indf,realargs) = dest_ind_type indt in
- let (ind,params) = dest_ind_family indf in
- let (mib,mip) = lookup_mind_specif env ind in
- let recargs = mip.mind_recargs in
- let mI = mkInd ind in
- let ci = make_default_case_info env (if Options.do_translate() then RegularStyle else MatchStyle) ind in
- let nconstr = Array.length mip.mind_consnames in
- if Array.length lf <> nconstr then
- (let cj = {uj_val=c; uj_type=mkAppliedInd indt} in
- error_number_branches_loc loc env sigma cj nconstr);
- let tyi = snd ind in
- if mis_is_recursive_subset [tyi] recargs then
- let dep =
- is_dependent_elimination env (nf_evar sigma pj.uj_type) indf in
- let init_depFvec i = if i = tyi then Some(dep,mkRel 1) else None in
- let depFvec = Array.init mib.mind_ntypes init_depFvec in
- (* build now the fixpoint *)
- let lnames,_ = get_arity env indf in
- let nar = List.length lnames in
- let nparams = mip.mind_nparams in
- let constrs = get_constructors env (lift_inductive_family (nar+2) indf) in
- let branches =
- array_map3
- (fun f t reca ->
- whd_beta
- (Indrec.make_rec_branch_arg env sigma
- (nparams,depFvec,nar+1)
- f t reca))
- (Array.map (lift (nar+2)) lf) constrs (dest_subterms recargs)
- in
- let deffix =
- it_mkLambda_or_LetIn_name env
- (lambda_create env
- (applist (mI,List.append (List.map (lift (nar+1)) params)
- (extended_rel_list 0 lnames)),
- mkCase (ci, lift (nar+2) p, mkRel 1, branches)))
- (lift_rel_context 1 lnames)
- in
- if noccurn 1 deffix then
- whd_beta (applist (pop deffix,realargs@[c]))
- else
- let ind = applist (mI,(List.append
- (List.map (lift nar) params)
- (extended_rel_list 0 lnames))) in
- let typPfix =
- it_mkProd_or_LetIn_name env
- (prod_create env
- (ind,
- (if dep then
- let ext_lnames = (Anonymous,None,ind)::lnames in
- let args = extended_rel_list 0 ext_lnames in
- whd_beta (applist (lift (nar+1) p, args))
- else
- let args = extended_rel_list 1 lnames in
- whd_beta (applist (lift (nar+1) p, args)))))
- lnames in
- let fix =
- mkFix (([|nar|],0),
- ([|Name(id_of_string "F")|],[|typPfix|],[|deffix|])) in
- applist (fix,realargs@[c])
- else
- mkCase (ci, p, c, lf)
(************************************************************************)
@@ -114,909 +47,667 @@ let transform_rec loc env sigma (pj,c,lf) indt =
let ((constr_in : constr -> Dyn.t),
(constr_out : Dyn.t -> constr)) = create "constr"
-let mt_evd = Evd.empty
-
-let vect_lift_type = Array.mapi (fun i t -> type_app (lift i) t)
-
-(* Utilisé pour inférer le prédicat des Cases *)
-(* Semble exagérement fort *)
-(* Faudra préférer une unification entre les types de toutes les clauses *)
-(* et autoriser des ? à rester dans le résultat de l'unification *)
-
-let evar_type_fixpoint loc env isevars lna lar vdefj =
- let lt = Array.length vdefj in
- if Array.length lar = lt then
- for i = 0 to lt-1 do
- if not (the_conv_x_leq env isevars
- (vdefj.(i)).uj_type
- (lift lt lar.(i))) then
- error_ill_typed_rec_body_loc loc env (evars_of isevars)
- i lna vdefj lar
- done
-
-let check_branches_message loc env isevars c (explft,lft) =
- for i = 0 to Array.length explft - 1 do
- if not (the_conv_x_leq env isevars lft.(i) explft.(i)) then
- let sigma = evars_of isevars in
- error_ill_formed_branch_loc loc env sigma c i lft.(i) explft.(i)
- done
-
-(* coerce to tycon if any *)
-let inh_conv_coerce_to_tycon loc env isevars j = function
- | None -> j
- | Some typ -> inh_conv_coerce_to loc env isevars j typ
-
-let push_rels vars env = List.fold_right push_rel vars env
-
-(*
-let evar_type_case isevars env ct pt lft p c =
- let (mind,bty,rslty) = type_case_branches env (evars_of isevars) ct pt p c
- in check_branches_message isevars env (c,ct) (bty,lft); (mind,rslty)
-*)
-
-let strip_meta id = (* For Grammar v7 compatibility *)
- let s = string_of_id id in
- if s.[0]='$' then id_of_string (String.sub s 1 (String.length s - 1))
- else id
-
-let pretype_id loc env (lvar,unbndltacvars) id =
- let id = strip_meta id in (* May happen in tactics defined by Grammar *)
- try
- let (n,typ) = lookup_rel_id id (rel_context env) in
- { uj_val = mkRel n; uj_type = type_app (lift n) typ }
- with Not_found ->
- try
- List.assoc id lvar
- with Not_found ->
- try
- let (_,_,typ) = lookup_named id env in
- { uj_val = mkVar id; uj_type = typ }
- with Not_found ->
- try (* To build a nicer ltac error message *)
- match List.assoc id unbndltacvars with
- | None -> user_err_loc (loc,"",
- str (string_of_id id ^ " ist not bound to a term"))
- | Some id0 -> Pretype_errors.error_var_not_found_loc loc id0
- with Not_found ->
- error_var_not_found_loc loc id
-
-(* make a dependent predicate from an undependent one *)
-
-let make_dep_of_undep env (IndType (indf,realargs)) pj =
- let n = List.length realargs in
- let rec decomp n p =
- if n=0 then p else
- match kind_of_term p with
- | Lambda (_,_,c) -> decomp (n-1) c
- | _ -> decomp (n-1) (applist (lift 1 p, [mkRel 1]))
- in
- let sign,s = decompose_prod_n n pj.uj_type in
- let ind = build_dependent_inductive env indf in
- let s' = mkProd (Anonymous, ind, s) in
- let ccl = lift 1 (decomp n pj.uj_val) in
- let ccl' = mkLambda (Anonymous, ind, ccl) in
- {uj_val=lam_it ccl' sign; uj_type=prod_it s' sign}
-
-(*************************************************************************)
-(* Main pretyping function *)
-
-let pretype_ref isevars env ref =
- let c = constr_of_reference ref in
- make_judge c (Retyping.get_type_of env Evd.empty c)
-
-let pretype_sort = function
- | RProp c -> judge_of_prop_contents c
- | RType _ -> judge_of_new_Type ()
-
-(* [pretype tycon env isevars lvar lmeta cstr] attempts to type [cstr] *)
-(* in environment [env], with existential variables [(evars_of isevars)] and *)
-(* the type constraint tycon *)
-let rec pretype tycon env isevars lvar = function
-
- | RRef (loc,ref) ->
- inh_conv_coerce_to_tycon loc env isevars
- (pretype_ref isevars env ref)
- tycon
-
- | RVar (loc, id) ->
- inh_conv_coerce_to_tycon loc env isevars
- (pretype_id loc env lvar id)
- tycon
-
- | REvar (loc, ev, instopt) ->
- (* Ne faudrait-il pas s'assurer que hyps est bien un
- sous-contexte du contexte courant, et qu'il n'y a pas de Rel "caché" *)
- let hyps = (Evd.map (evars_of isevars) ev).evar_hyps in
- let args = match instopt with
- | None -> instance_from_named_context hyps
- | Some inst -> failwith "Evar subtitutions not implemented" in
- let c = mkEvar (ev, args) in
- let j = (Retyping.get_judgment_of env (evars_of isevars) c) in
- inh_conv_coerce_to_tycon loc env isevars j tycon
-
- | RPatVar (loc,(someta,n)) ->
- anomaly "Found a pattern variable in a rawterm to type"
-
- | RHole (loc,k) ->
- (match tycon with
- | Some ty ->
- { uj_val = new_isevar isevars env (loc,k) ty; uj_type = ty }
- | None -> error_unsolvable_implicit loc env (evars_of isevars) k)
-
- | RRec (loc,fixkind,names,bl,lar,vdef) ->
- let rec type_bl env ctxt = function
- [] -> ctxt
- | (na,None,ty)::bl ->
- let ty' = pretype_type empty_valcon env isevars lvar ty in
- let dcl = (na,None,ty'.utj_val) in
- type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl
- | (na,Some bd,ty)::bl ->
- let ty' = pretype_type empty_valcon env isevars lvar ty in
- let bd' = pretype (mk_tycon ty'.utj_val) env isevars lvar ty in
- let dcl = (na,Some bd'.uj_val,ty'.utj_val) in
- type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl in
- let ctxtv = Array.map (type_bl env empty_rel_context) bl in
- let larj =
- array_map2
- (fun e ar ->
- pretype_type empty_valcon (push_rel_context e env) isevars lvar ar)
- ctxtv lar in
- let lara = Array.map (fun a -> a.utj_val) larj in
- let ftys = array_map2 (fun e a -> it_mkProd_or_LetIn a e) ctxtv lara in
- let nbfix = Array.length lar in
- let names = Array.map (fun id -> Name id) names in
- (* Note: bodies are not used by push_rec_types, so [||] is safe *)
- let newenv = push_rec_types (names,ftys,[||]) env in
- let vdefj =
- array_map2_i
- (fun i ctxt def ->
- (* we lift nbfix times the type in tycon, because of
- * the nbfix variables pushed to newenv *)
- let (ctxt,ty) =
- decompose_prod_n_assum (rel_context_length ctxt)
- (lift nbfix ftys.(i)) in
- let nenv = push_rel_context ctxt newenv in
- let j = pretype (mk_tycon ty) nenv isevars lvar def in
- { uj_val = it_mkLambda_or_LetIn j.uj_val ctxt;
- uj_type = it_mkProd_or_LetIn j.uj_type ctxt })
- ctxtv vdef in
- evar_type_fixpoint loc env isevars names ftys vdefj;
- let fixj =
- match fixkind with
- | RFix (vn,i as vni) ->
- let fix = (vni,(names,ftys,Array.map j_val vdefj)) in
- (try check_fix env fix with e -> Stdpp.raise_with_loc loc e);
- make_judge (mkFix fix) ftys.(i)
- | RCoFix i ->
- let cofix = (i,(names,ftys,Array.map j_val vdefj)) in
- (try check_cofix env cofix with e -> Stdpp.raise_with_loc loc e);
- make_judge (mkCoFix cofix) ftys.(i) in
- inh_conv_coerce_to_tycon loc env isevars fixj tycon
-
- | RSort (loc,s) ->
- inh_conv_coerce_to_tycon loc env isevars (pretype_sort s) tycon
-
- | RApp (loc,f,args) ->
- let fj = pretype empty_tycon env isevars lvar f in
- let floc = loc_of_rawconstr f in
- let rec apply_rec env n resj = function
- | [] -> resj
- | c::rest ->
- let argloc = loc_of_rawconstr c in
- let resj = inh_app_fun env isevars resj in
- let resty =
- whd_betadeltaiota env (evars_of isevars) resj.uj_type in
- match kind_of_term resty with
- | Prod (na,c1,c2) ->
- let hj = pretype (mk_tycon c1) env isevars lvar c in
- let newresj =
- { uj_val = applist (j_val resj, [j_val hj]);
- uj_type = subst1 hj.uj_val c2 } in
- apply_rec env (n+1) newresj rest
-
- | _ ->
- let hj = pretype empty_tycon env isevars lvar c in
- error_cant_apply_not_functional_loc
- (join_loc floc argloc) env (evars_of isevars)
- resj [hj]
-
- in let resj = apply_rec env 1 fj args in
- (*
- let apply_one_arg (floc,tycon,jl) c =
- let (dom,rng) = split_tycon floc env isevars tycon in
- let cj = pretype dom env isevars lvar c in
- let rng_tycon = option_app (subst1 cj.uj_val) rng in
- let argloc = loc_of_rawconstr c in
- (join_loc floc argloc,rng_tycon,(argloc,cj)::jl) in
- let _,_,jl =
- List.fold_left apply_one_arg (floc,mk_tycon j.uj_type,[]) args in
- let jl = List.rev jl in
- let resj = inh_apply_rel_list loc env isevars jl (floc,j) tycon in
- *)
- inh_conv_coerce_to_tycon loc env isevars resj tycon
-
- | RLambda(loc,name,c1,c2) ->
- let (name',dom,rng) = split_tycon loc env isevars tycon in
- let dom_valcon = valcon_of_tycon dom in
- let j = pretype_type dom_valcon env isevars lvar c1 in
- let var = (name,None,j.utj_val) in
- let j' = pretype rng (push_rel var env) isevars lvar c2 in
- judge_of_abstraction env name j j'
-
- | RProd(loc,name,c1,c2) ->
- let j = pretype_type empty_valcon env isevars lvar c1 in
- let var = (name,j.utj_val) in
- let env' = push_rel_assum var env in
- let j' = pretype_type empty_valcon env' isevars lvar c2 in
- let resj =
- try judge_of_product env name j j'
- with TypeError _ as e -> Stdpp.raise_with_loc loc e in
- inh_conv_coerce_to_tycon loc env isevars resj tycon
-
- | RLetIn(loc,name,c1,c2) ->
- let j = pretype empty_tycon env isevars lvar c1 in
- let t = Evarutil.refresh_universes j.uj_type in
- let var = (name,Some j.uj_val,t) in
- let tycon = option_app (lift 1) tycon in
- let j' = pretype tycon (push_rel var env) isevars lvar c2 in
- { uj_val = mkLetIn (name, j.uj_val, t, j'.uj_val) ;
- uj_type = type_app (subst1 j.uj_val) j'.uj_type }
-
- | RLetTuple (loc,nal,(na,po),c,d) ->
- let cj = pretype empty_tycon env isevars lvar c in
- let (IndType (indf,realargs) as indt) =
- try find_rectype env (evars_of isevars) cj.uj_type
- with Not_found ->
- let cloc = loc_of_rawconstr c in
- error_case_not_inductive_loc cloc env (evars_of isevars) cj
- in
- let cstrs = get_constructors env indf in
- if Array.length cstrs <> 1 then
- user_err_loc (loc,"",str "Destructing let is only for inductive types with one constructor");
- let cs = cstrs.(0) in
- if List.length nal <> cs.cs_nargs then
- user_err_loc (loc,"", str "Destructing let on this type expects " ++ int cs.cs_nargs ++ str " variables");
- let fsign = List.map2 (fun na (_,c,t) -> (na,c,t))
- (List.rev nal) cs.cs_args in
- let env_f = push_rels fsign env in
- (* Make dependencies from arity signature impossible *)
- let arsgn,_ = get_arity env indf in
- let arsgn = List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn in
- let psign = (na,None,build_dependent_inductive env indf)::arsgn in
- let nar = List.length arsgn in
- (match po with
- | Some p ->
- let env_p = push_rels psign env in
- let pj = pretype_type empty_valcon env_p isevars lvar p in
- let ccl = nf_evar (evars_of isevars) pj.utj_val in
- let psign = make_arity_signature env true indf in (* with names *)
- let p = it_mkLambda_or_LetIn ccl psign in
- let inst =
- (Array.to_list cs.cs_concl_realargs)
- @[build_dependent_constructor cs] in
- let lp = lift cs.cs_nargs p in
- let fty = hnf_lam_applist env (evars_of isevars) lp inst in
- let fj = pretype (mk_tycon fty) env_f isevars lvar d in
- let f = it_mkLambda_or_LetIn fj.uj_val fsign in
- let v =
- let mis,_ = dest_ind_family indf in
- let ci = make_default_case_info env LetStyle mis in
- mkCase (ci, p, cj.uj_val,[|f|]) in
- let cs = build_dependent_constructor cs in
- { uj_val = v; uj_type = substl (realargs@[cj.uj_val]) ccl }
-
- | None ->
- let tycon = option_app (lift cs.cs_nargs) tycon in
- let fj = pretype tycon env_f isevars lvar d in
- let f = it_mkLambda_or_LetIn fj.uj_val fsign in
- let ccl = nf_evar (evars_of isevars) fj.uj_type in
- let ccl =
- if noccur_between 1 cs.cs_nargs ccl then
- lift (- cs.cs_nargs) ccl
- else
- error_cant_find_case_type_loc loc env (evars_of isevars)
- cj.uj_val in
- let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign in
- let v =
- let mis,_ = dest_ind_family indf in
- let ci = make_default_case_info env LetStyle mis in
- mkCase (ci, p, cj.uj_val,[|f|] )
- in
- { uj_val = v; uj_type = ccl })
-
- (* Special Case for let constructions to avoid exponential behavior *)
- | ROrderedCase (loc,st,po,c,[|f|],xx) when st <> MatchStyle ->
- let cj = pretype empty_tycon env isevars lvar c in
- let (IndType (indf,realargs) as indt) =
- try find_rectype env (evars_of isevars) cj.uj_type
- with Not_found ->
- let cloc = loc_of_rawconstr c in
- error_case_not_inductive_loc cloc env (evars_of isevars) cj
- in
- let j = match po with
- | Some p ->
- let pj = pretype empty_tycon env isevars lvar p in
- let dep = is_dependent_elimination env pj.uj_type indf in
- let ar =
- arity_of_case_predicate env indf dep (Type (new_univ())) in
- let _ = the_conv_x_leq env isevars pj.uj_type ar in
- let pj = j_nf_evar (evars_of isevars) pj in
- let pj = if dep then pj else make_dep_of_undep env indt pj in
- let (bty,rsty) =
- Indrec.type_rec_branches
- false env (evars_of isevars) indt pj.uj_val cj.uj_val
- in
- if Array.length bty <> 1 then
- error_number_branches_loc
- loc env (evars_of isevars) cj (Array.length bty);
- let fj =
- let tyc = bty.(0) in
- pretype (mk_tycon tyc) env isevars lvar f
- in
- let fv = j_val fj in
- let ft = fj.uj_type in
- check_branches_message loc env isevars cj.uj_val (bty,[|ft|]);
- let v =
- let mis,_ = dest_ind_family indf in
- let ci = make_default_case_info env st mis in
- mkCase (ci, (nf_betaiota pj.uj_val), cj.uj_val,[|fv|])
- in
- { uj_val = v; uj_type = rsty }
-
- | None ->
- (* get type information from type of branches *)
- let expbr = Cases.branch_scheme env isevars false indf in
- if Array.length expbr <> 1 then
- error_number_branches_loc loc env (evars_of isevars)
- cj (Array.length expbr);
- let expti = expbr.(0) in
- let fj = pretype (mk_tycon expti) env isevars lvar f in
- let use_constraint () =
- (* get type information from constraint *)
- (* warning: if the constraint comes from an evar type, it *)
- (* may be Type while Prop or Set would be expected *)
- match tycon with
- | Some pred ->
- let arsgn = make_arity_signature env true indf in
- let pred = lift (List.length arsgn) pred in
- let pred =
- it_mkLambda_or_LetIn (nf_evar (evars_of isevars) pred)
- arsgn in
- false, pred
- | None ->
- let sigma = evars_of isevars in
- error_cant_find_case_type_loc loc env sigma cj.uj_val
- in
- let ok, p =
- try
- let pred =
- Cases.pred_case_ml
- env (evars_of isevars) false indt (0,fj.uj_type)
- in
- if has_undefined_isevars isevars pred then
- use_constraint ()
- else
- true, pred
- with Cases.NotInferable _ ->
- use_constraint ()
- in
- let p = nf_evar (evars_of isevars) p in
- let (bty,rsty) =
- Indrec.type_rec_branches
- false env (evars_of isevars) indt p cj.uj_val
- in
- let _ = option_app (the_conv_x_leq env isevars rsty) tycon in
- let fj =
- if ok then fj
- else pretype (mk_tycon bty.(0)) env isevars lvar f
- in
- let fv = fj.uj_val in
- let ft = fj.uj_type in
- let v =
- let mis,_ = dest_ind_family indf in
- let ci = make_default_case_info env st mis in
- mkCase (ci, (nf_betaiota p), cj.uj_val,[|fv|] )
- in
- { uj_val = v; uj_type = rsty } in
-
- (* Build the LetTuple form for v8 *)
- let c =
- let (ind,params) = dest_ind_family indf in
- let rtntypopt, indnalopt = match po with
- | None -> None, (Anonymous,None)
- | Some p ->
- let pj = pretype empty_tycon env isevars lvar p in
- let dep = is_dependent_elimination env pj.uj_type indf in
- let rec decomp_lam_force n avoid l p =
- (* avoid is not exhaustive ! *)
- if n = 0 then (List.rev l,p,avoid) else
- match p with
- | RLambda (_,(Name id as na),_,c) ->
- decomp_lam_force (n-1) (id::avoid) (na::l) c
- | RLambda (_,(Anonymous as na),_,c) ->
- decomp_lam_force (n-1) avoid (na::l) c
- | _ ->
- let x = Nameops.next_ident_away (id_of_string "x") avoid in
- decomp_lam_force (n-1) (x::avoid) (Name x :: l)
- (* eta-expansion *)
- (RApp (dummy_loc,p, [RVar (dummy_loc,x)])) in
- let (nal,p,avoid) =
- decomp_lam_force (List.length realargs) [] [] p in
- let na,rtntyp,_ =
- if dep then decomp_lam_force 1 avoid [] p
- else [Anonymous],p,[] in
- let intyp =
- if List.for_all
- (function
- | Anonymous -> true
- | Name id -> not (occur_rawconstr id rtntyp)) nal
- then (* No dependency in realargs *)
- None
- else
- let args = List.map (fun _ -> Anonymous) params @ nal in
- Some (dummy_loc,ind,args) in
- (Some rtntyp,(List.hd na,intyp)) in
- let cs = (get_constructors env indf).(0) in
- match indnalopt with
- | (na,None) -> (* Represented as a let *)
- let rec decomp_lam_force n avoid l p =
- if n = 0 then (List.rev l,p) else
- match p with
- | RLambda (_,(Name id as na),_,c) ->
- decomp_lam_force (n-1) (id::avoid) (na::l) c
- | RLambda (_,(Anonymous as na),_,c) ->
- decomp_lam_force (n-1) avoid (na::l) c
- | _ ->
- let x = Nameops.next_ident_away (id_of_string "x") avoid in
- decomp_lam_force (n-1) (x::avoid) (Name x :: l)
- (* eta-expansion *)
- (let a = RVar (dummy_loc,x) in
- match p with
- | RApp (loc,p,l) -> RApp (loc,p,l@[a])
- | _ -> (RApp (dummy_loc,p,[a]))) in
- let (nal,d) = decomp_lam_force cs.cs_nargs [] [] f in
- RLetTuple (loc,nal,(na,rtntypopt),c,d)
- | _ -> (* Represented as a match *)
- let detype_eqn constr construct_nargs branch =
- let name_cons = function
- | Anonymous -> fun l -> l
- | Name id -> fun l -> id::l in
- let make_pat na avoid b ids =
- PatVar (dummy_loc,na),
- name_cons na avoid,name_cons na ids
- in
- let rec buildrec ids patlist avoid n b =
- if n=0 then
- (dummy_loc, ids,
- [PatCstr(dummy_loc, constr, List.rev patlist,Anonymous)],
- b)
- else
- match b with
- | RLambda (_,x,_,b) ->
- let pat,new_avoid,new_ids = make_pat x avoid b ids in
- buildrec new_ids (pat::patlist) new_avoid (n-1) b
-
- | RLetIn (_,x,_,b) ->
- let pat,new_avoid,new_ids = make_pat x avoid b ids in
- buildrec new_ids (pat::patlist) new_avoid (n-1) b
-
- | RCast (_,c,_) -> (* Oui, il y a parfois des cast *)
- buildrec ids patlist avoid n c
-
- | _ -> (* eta-expansion *)
- (* nommage de la nouvelle variable *)
- let id = Nameops.next_ident_away (id_of_string "x") avoid in
- let new_b = RApp (dummy_loc, b, [RVar(dummy_loc,id)])in
- let pat,new_avoid,new_ids =
- make_pat (Name id) avoid new_b ids in
- buildrec new_ids (pat::patlist) new_avoid (n-1) new_b
-
- in
- buildrec [] [] [] construct_nargs branch in
- let eqn = detype_eqn (ind,1) cs.cs_nargs f in
- RCases (loc,(po,ref rtntypopt),[c,ref indnalopt],[eqn])
- in
- xx := Some c;
- (* End building the v8 syntax *)
- j
+(** Miscellaneous interpretation functions *)
+
+let interp_sort = function
+ | RProp c -> Prop c
+ | RType _ -> new_Type_sort ()
+
+let interp_elimination_sort = function
+ | RProp Null -> InProp
+ | RProp Pos -> InSet
+ | RType _ -> InType
- | RIf (loc,c,(na,po),b1,b2) ->
- let cj = pretype empty_tycon env isevars lvar c in
- let (IndType (indf,realargs) as indt) =
- try find_rectype env (evars_of isevars) cj.uj_type
+module type S =
+sig
+
+ module Cases : Cases.S
+
+ (* Allow references to syntaxically inexistent variables (i.e., if applied on an inductive) *)
+ val allow_anonymous_refs : bool ref
+
+ (* Generic call to the interpreter from rawconstr to open_constr, leaving
+ unresolved holes as evars and returning the typing contexts of
+ these evars. Work as [understand_gen] for the rest. *)
+
+ val understand_tcc :
+ evar_map -> env -> ?expected_type:types -> rawconstr -> open_constr
+
+ val understand_tcc_evars :
+ evar_defs ref -> env -> typing_constraint -> rawconstr -> constr
+
+ (* More general entry point with evars from ltac *)
+
+ (* Generic call to the interpreter from rawconstr to constr, failing
+ unresolved holes in the rawterm cannot be instantiated.
+
+ In [understand_ltac sigma env ltac_env constraint c],
+
+ sigma : initial set of existential variables (typically dependent subgoals)
+ ltac_env : partial substitution of variables (used for the tactic language)
+ constraint : tell if interpreted as a possibly constrained term or a type
+ *)
+
+ val understand_ltac :
+ evar_map -> env -> var_map * unbound_ltac_var_map ->
+ typing_constraint -> rawconstr -> evar_defs * constr
+
+ (* Standard call to get a constr from a rawconstr, resolving implicit args *)
+
+ val understand : evar_map -> env -> ?expected_type:Term.types ->
+ rawconstr -> constr
+
+ (* Idem but the rawconstr is intended to be a type *)
+
+ val understand_type : evar_map -> env -> rawconstr -> constr
+
+ (* A generalization of the two previous case *)
+
+ val understand_gen : typing_constraint -> evar_map -> env ->
+ rawconstr -> constr
+
+ (* Idem but returns the judgment of the understood term *)
+
+ val understand_judgment : evar_map -> env -> rawconstr -> unsafe_judgment
+
+ (* Idem but do not fail on unresolved evars *)
+
+ val understand_judgment_tcc : evar_defs ref -> env -> rawconstr -> unsafe_judgment
+
+ (*i*)
+ (* Internal of Pretyping...
+ * Unused outside, but useful for debugging
+ *)
+ val pretype :
+ type_constraint -> env -> evar_defs ref ->
+ var_map * (identifier * identifier option) list ->
+ rawconstr -> unsafe_judgment
+
+ val pretype_type :
+ val_constraint -> env -> evar_defs ref ->
+ var_map * (identifier * identifier option) list ->
+ rawconstr -> unsafe_type_judgment
+
+ val pretype_gen :
+ evar_defs ref -> env ->
+ var_map * (identifier * identifier option) list ->
+ typing_constraint -> rawconstr -> constr
+
+ (*i*)
+end
+
+module Pretyping_F (Coercion : Coercion.S) = struct
+
+ module Cases = Cases.Cases_F(Coercion)
+
+ (* Allow references to syntaxically inexistent variables (i.e., if applied on an inductive) *)
+ let allow_anonymous_refs = ref false
+
+ let evd_comb0 f isevars =
+ let (evd',x) = f !isevars in
+ isevars := evd';
+ x
+
+ let evd_comb1 f isevars x =
+ let (evd',y) = f !isevars x in
+ isevars := evd';
+ y
+
+ let evd_comb2 f isevars x y =
+ let (evd',z) = f !isevars x y in
+ isevars := evd';
+ z
+
+ let evd_comb3 f isevars x y z =
+ let (evd',t) = f !isevars x y z in
+ isevars := evd';
+ t
+
+ let mt_evd = Evd.empty
+
+ let vect_lift_type = Array.mapi (fun i t -> type_app (lift i) t)
+
+ (* Utilisé pour inférer le prédicat des Cases *)
+ (* Semble exagérement fort *)
+ (* Faudra préférer une unification entre les types de toutes les clauses *)
+ (* et autoriser des ? à rester dans le résultat de l'unification *)
+
+ let evar_type_fixpoint loc env isevars lna lar vdefj =
+ let lt = Array.length vdefj in
+ if Array.length lar = lt then
+ for i = 0 to lt-1 do
+ if not (e_cumul env isevars (vdefj.(i)).uj_type
+ (lift lt lar.(i))) then
+ error_ill_typed_rec_body_loc loc env (evars_of !isevars)
+ i lna vdefj lar
+ done
+
+ let check_branches_message loc env isevars c (explft,lft) =
+ for i = 0 to Array.length explft - 1 do
+ if not (e_cumul env isevars lft.(i) explft.(i)) then
+ let sigma = evars_of !isevars in
+ error_ill_formed_branch_loc loc env sigma c i lft.(i) explft.(i)
+ done
+
+ (* coerce to tycon if any *)
+ let inh_conv_coerce_to_tycon loc env isevars j = function
+ | None -> j
+ | Some t -> evd_comb2 (Coercion.inh_conv_coerce_to loc env) isevars j t
+
+ let push_rels vars env = List.fold_right push_rel vars env
+
+ (*
+ let evar_type_case isevars env ct pt lft p c =
+ let (mind,bty,rslty) = type_case_branches env (evars_of isevars) ct pt p c
+ in check_branches_message isevars env (c,ct) (bty,lft); (mind,rslty)
+ *)
+
+ let strip_meta id = (* For Grammar v7 compatibility *)
+ let s = string_of_id id in
+ if s.[0]='$' then id_of_string (String.sub s 1 (String.length s - 1))
+ else id
+
+ let pretype_id loc env (lvar,unbndltacvars) id =
+ let id = strip_meta id in (* May happen in tactics defined by Grammar *)
+ try
+ let (n,typ) = lookup_rel_id id (rel_context env) in
+ { uj_val = mkRel n; uj_type = type_app (lift n) typ }
+ with Not_found ->
+ try
+ List.assoc id lvar
with Not_found ->
- let cloc = loc_of_rawconstr c in
- error_case_not_inductive_loc cloc env (evars_of isevars) cj in
- let cstrs = get_constructors env indf in
- if Array.length cstrs <> 2 then
- user_err_loc (loc,"",
- str "If is only for inductive types with two constructors");
-
- (* Make dependencies from arity signature impossible *)
- let arsgn,_ = get_arity env indf in
- let arsgn = List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn in
- let nar = List.length arsgn in
- let psign = (na,None,build_dependent_inductive env indf)::arsgn in
- let pred,p = match po with
- | Some p ->
- let env_p = push_rels psign env in
- let pj = pretype_type empty_valcon env_p isevars lvar p in
- let ccl = nf_evar (evars_of isevars) pj.utj_val in
- let pred = it_mkLambda_or_LetIn ccl psign in
- pred, lift (- nar) (beta_applist (pred,[cj.uj_val]))
- | None ->
- let p = match tycon with
- | Some ty -> ty
- | None -> new_isevar isevars env (loc,InternalHole) (new_Type ())
+ try
+ let (_,_,typ) = lookup_named id env in
+ { uj_val = mkVar id; uj_type = typ }
+ with Not_found ->
+ try (* To build a nicer ltac error message *)
+ match List.assoc id unbndltacvars with
+ | None -> user_err_loc (loc,"",
+ str "variable " ++ pr_id id ++ str " should be bound to a term")
+ | Some id0 -> Pretype_errors.error_var_not_found_loc loc id0
+ with Not_found ->
+ error_var_not_found_loc loc id
+
+ (* make a dependent predicate from an undependent one *)
+
+ let make_dep_of_undep env (IndType (indf,realargs)) pj =
+ let n = List.length realargs in
+ let rec decomp n p =
+ if n=0 then p else
+ match kind_of_term p with
+ | Lambda (_,_,c) -> decomp (n-1) c
+ | _ -> decomp (n-1) (applist (lift 1 p, [mkRel 1]))
+ in
+ let sign,s = decompose_prod_n n pj.uj_type in
+ let ind = build_dependent_inductive env indf in
+ let s' = mkProd (Anonymous, ind, s) in
+ let ccl = lift 1 (decomp n pj.uj_val) in
+ let ccl' = mkLambda (Anonymous, ind, ccl) in
+ {uj_val=lam_it ccl' sign; uj_type=prod_it s' sign}
+
+ (*************************************************************************)
+ (* Main pretyping function *)
+
+ let pretype_ref isevars env ref =
+ let c = constr_of_global ref in
+ make_judge c (Retyping.get_type_of env Evd.empty c)
+
+ let pretype_sort = function
+ | RProp c -> judge_of_prop_contents c
+ | RType _ -> judge_of_new_Type ()
+
+ (* [pretype tycon env isevars lvar lmeta cstr] attempts to type [cstr] *)
+ (* in environment [env], with existential variables [(evars_of isevars)] and *)
+ (* the type constraint tycon *)
+ let rec pretype (tycon : type_constraint) env isevars lvar = function
+ | RRef (loc,ref) ->
+ inh_conv_coerce_to_tycon loc env isevars
+ (pretype_ref isevars env ref)
+ tycon
+
+ | RVar (loc, id) ->
+ inh_conv_coerce_to_tycon loc env isevars
+ (pretype_id loc env lvar id)
+ tycon
+
+ | REvar (loc, ev, instopt) ->
+ (* Ne faudrait-il pas s'assurer que hyps est bien un
+ sous-contexte du contexte courant, et qu'il n'y a pas de Rel "caché" *)
+ let hyps = evar_context (Evd.map (evars_of !isevars) ev) in
+ let args = match instopt with
+ | None -> instance_from_named_context hyps
+ | Some inst -> failwith "Evar subtitutions not implemented" in
+ let c = mkEvar (ev, args) in
+ let j = (Retyping.get_judgment_of env (evars_of !isevars) c) in
+ inh_conv_coerce_to_tycon loc env isevars j tycon
+
+ | RPatVar (loc,(someta,n)) ->
+ anomaly "Found a pattern variable in a rawterm to type"
+
+ | RHole (loc,k) ->
+ let ty =
+ match tycon with
+ | Some (None, ty) -> ty
+ | None | Some _ ->
+ e_new_evar isevars env ~src:(loc,InternalHole) (new_Type ()) in
+ { uj_val = e_new_evar isevars env ~src:(loc,k) ty; uj_type = ty }
+
+ | RRec (loc,fixkind,names,bl,lar,vdef) ->
+ let rec type_bl env ctxt = function
+ [] -> ctxt
+ | (na,None,ty)::bl ->
+ let ty' = pretype_type empty_valcon env isevars lvar ty in
+ let dcl = (na,None,ty'.utj_val) in
+ type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl
+ | (na,Some bd,ty)::bl ->
+ let ty' = pretype_type empty_valcon env isevars lvar ty in
+ let bd' = pretype (mk_tycon ty'.utj_val) env isevars lvar ty in
+ let dcl = (na,Some bd'.uj_val,ty'.utj_val) in
+ type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl in
+ let ctxtv = Array.map (type_bl env empty_rel_context) bl in
+ let larj =
+ array_map2
+ (fun e ar ->
+ pretype_type empty_valcon (push_rel_context e env) isevars lvar ar)
+ ctxtv lar in
+ let lara = Array.map (fun a -> a.utj_val) larj in
+ let ftys = array_map2 (fun e a -> it_mkProd_or_LetIn a e) ctxtv lara in
+ let nbfix = Array.length lar in
+ let names = Array.map (fun id -> Name id) names in
+ (* Note: bodies are not used by push_rec_types, so [||] is safe *)
+ let newenv = push_rec_types (names,ftys,[||]) env in
+ let vdefj =
+ array_map2_i
+ (fun i ctxt def ->
+ (* we lift nbfix times the type in tycon, because of
+ * the nbfix variables pushed to newenv *)
+ let (ctxt,ty) =
+ decompose_prod_n_assum (rel_context_length ctxt)
+ (lift nbfix ftys.(i)) in
+ let nenv = push_rel_context ctxt newenv in
+ let j = pretype (mk_tycon ty) nenv isevars lvar def in
+ { uj_val = it_mkLambda_or_LetIn j.uj_val ctxt;
+ uj_type = it_mkProd_or_LetIn j.uj_type ctxt })
+ ctxtv vdef in
+ evar_type_fixpoint loc env isevars names ftys vdefj;
+ let fixj =
+ match fixkind with
+ | RFix (vn,i) ->
+ let fix = ((Array.map fst vn, i),(names,ftys,Array.map j_val vdefj)) in
+ (try check_fix env fix with e -> Stdpp.raise_with_loc loc e);
+ make_judge (mkFix fix) ftys.(i)
+ | RCoFix i ->
+ let cofix = (i,(names,ftys,Array.map j_val vdefj)) in
+ (try check_cofix env cofix with e -> Stdpp.raise_with_loc loc e);
+ make_judge (mkCoFix cofix) ftys.(i) in
+ inh_conv_coerce_to_tycon loc env isevars fixj tycon
+
+ | RSort (loc,s) ->
+ inh_conv_coerce_to_tycon loc env isevars (pretype_sort s) tycon
+
+ | RApp (loc,f,args) ->
+ let length = List.length args in
+ let ftycon =
+ match tycon with
+ None -> None
+ | Some (None, ty) -> mk_abstr_tycon length ty
+ | Some (Some (init, cur), ty) ->
+ Some (Some (length + init, length + cur), ty)
+ in
+ let fj = pretype empty_tycon env isevars lvar f in
+ let floc = loc_of_rawconstr f in
+ let rec apply_rec env n resj tycon = function
+ | [] -> resj
+ | c::rest ->
+ let argloc = loc_of_rawconstr c in
+ let resj = evd_comb1 (Coercion.inh_app_fun env) isevars resj in
+ let resty = whd_betadeltaiota env (evars_of !isevars) resj.uj_type in
+ match kind_of_term resty with
+ | Prod (na,c1,c2) ->
+ let hj = pretype (mk_tycon c1) env isevars lvar c in
+ let value, typ = applist (j_val resj, [j_val hj]), subst1 hj.uj_val c2 in
+ let typ' = nf_isevar !isevars typ in
+ let tycon =
+ option_app
+ (fun (abs, ty) ->
+ match abs with
+ None ->
+ isevars := Coercion.inh_conv_coerces_to loc env !isevars typ'
+ (abs, ty);
+ (abs, ty)
+ | Some (init, cur) ->
+ isevars := Coercion.inh_conv_coerces_to loc env !isevars typ'
+ (abs, ty);
+ (Some (init, pred cur), ty))
+ tycon
+ in
+ apply_rec env (n+1)
+ { uj_val = nf_isevar !isevars value;
+ uj_type = nf_isevar !isevars typ' }
+ (option_app (fun (abs, c) -> abs, nf_isevar !isevars c) tycon) rest
+
+ | _ ->
+ let hj = pretype empty_tycon env isevars lvar c in
+ error_cant_apply_not_functional_loc
+ (join_loc floc argloc) env (evars_of !isevars)
+ resj [hj]
+ in
+ let ftycon = option_app (lift_abstr_tycon_type (-1)) ftycon in
+ let resj = j_nf_evar (evars_of !isevars) (apply_rec env 1 fj ftycon args) in
+ let resj =
+ match kind_of_term resj.uj_val with
+ | App (f,args) when isInd f ->
+ let sigma = evars_of !isevars in
+ let t = Retyping.type_of_applied_inductive env sigma (destInd f) args in
+ let s = snd (splay_arity env sigma t) in
+ on_judgment_type (set_inductive_level env s) resj
+ (* Rem: no need to send sigma: no head evar, it's an arity *)
+ | _ -> resj in
+ inh_conv_coerce_to_tycon loc env isevars resj tycon
+
+ | RLambda(loc,name,c1,c2) ->
+ let (name',dom,rng) = evd_comb1 (split_tycon loc env) isevars tycon in
+ let dom_valcon = valcon_of_tycon dom in
+ let j = pretype_type dom_valcon env isevars lvar c1 in
+ let var = (name,None,j.utj_val) in
+ let j' = pretype rng (push_rel var env) isevars lvar c2 in
+ judge_of_abstraction env name j j'
+
+ | RProd(loc,name,c1,c2) ->
+ let j = pretype_type empty_valcon env isevars lvar c1 in
+ let var = (name,j.utj_val) in
+ let env' = push_rel_assum var env in
+ let j' = pretype_type empty_valcon env' isevars lvar c2 in
+ let resj =
+ try judge_of_product env name j j'
+ with TypeError _ as e -> Stdpp.raise_with_loc loc e in
+ inh_conv_coerce_to_tycon loc env isevars resj tycon
+
+ | RLetIn(loc,name,c1,c2) ->
+ let j = pretype empty_tycon env isevars lvar c1 in
+ let t = refresh_universes j.uj_type in
+ let var = (name,Some j.uj_val,t) in
+ let tycon = lift_tycon 1 tycon in
+ let j' = pretype tycon (push_rel var env) isevars lvar c2 in
+ { uj_val = mkLetIn (name, j.uj_val, t, j'.uj_val) ;
+ uj_type = subst1 j.uj_val j'.uj_type }
+
+ | RLetTuple (loc,nal,(na,po),c,d) ->
+ let cj = pretype empty_tycon env isevars lvar c in
+ let (IndType (indf,realargs)) =
+ try find_rectype env (evars_of !isevars) cj.uj_type
+ with Not_found ->
+ let cloc = loc_of_rawconstr c in
+ error_case_not_inductive_loc cloc env (evars_of !isevars) cj
+ in
+ let cstrs = get_constructors env indf in
+ if Array.length cstrs <> 1 then
+ user_err_loc (loc,"",str "Destructing let is only for inductive types with one constructor");
+ let cs = cstrs.(0) in
+ if List.length nal <> cs.cs_nargs then
+ user_err_loc (loc,"", str "Destructing let on this type expects " ++ int cs.cs_nargs ++ str " variables");
+ let fsign = List.map2 (fun na (_,c,t) -> (na,c,t))
+ (List.rev nal) cs.cs_args in
+ let env_f = push_rels fsign env in
+ (* Make dependencies from arity signature impossible *)
+ let arsgn =
+ let arsgn,_ = get_arity env indf in
+ if not !allow_anonymous_refs then
+ List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn
+ else arsgn
in
- it_mkLambda_or_LetIn (lift (nar+1) p) psign, p in
- let f cs b =
- let n = rel_context_length cs.cs_args in
- let pi = liftn n 2 pred in
- let pi = beta_applist (pi, [build_dependent_constructor cs]) in
- let csgn = List.map (fun (_,b,t) -> (Anonymous,b,t)) cs.cs_args in
- let env_c = push_rels csgn env in
- let bj = pretype (Some pi) env_c isevars lvar b in
- it_mkLambda_or_LetIn bj.uj_val cs.cs_args in
- let b1 = f cstrs.(0) b1 in
- let b2 = f cstrs.(1) b2 in
- let pred = nf_evar (evars_of isevars) pred in
- let p = nf_evar (evars_of isevars) p in
- let v =
- let mis,_ = dest_ind_family indf in
- let ci = make_default_case_info env IfStyle mis in
- mkCase (ci, pred, cj.uj_val, [|b1;b2|])
- in
- { uj_val = v; uj_type = p }
-
- | ROrderedCase (loc,st,po,c,lf,x) ->
- let isrec = (st = MatchStyle) in
- let cj = pretype empty_tycon env isevars lvar c in
- let (IndType (indf,realargs) as indt) =
- try find_rectype env (evars_of isevars) cj.uj_type
- with Not_found ->
- let cloc = loc_of_rawconstr c in
- error_case_not_inductive_loc cloc env (evars_of isevars) cj in
- let (dep,pj) = match po with
- | Some p ->
- let pj = pretype empty_tycon env isevars lvar p in
- let dep = is_dependent_elimination env pj.uj_type indf in
- let ar =
- arity_of_case_predicate env indf dep (Type (new_univ())) in
- let _ = the_conv_x_leq env isevars pj.uj_type ar in
- (dep, pj)
- | None ->
- (* get type information from type of branches *)
- let expbr = Cases.branch_scheme env isevars isrec indf in
- let rec findtype i =
- if i >= Array.length lf
- then
- (* get type information from constraint *)
- (* warning: if the constraint comes from an evar type, it *)
- (* may be Type while Prop or Set would be expected *)
- match tycon with
- | Some pred ->
- let arsgn = make_arity_signature env true indf in
- let pred = lift (List.length arsgn) pred in
- let pred =
- it_mkLambda_or_LetIn (nf_evar (evars_of isevars) pred)
- arsgn in
- (true,
- Retyping.get_judgment_of env (evars_of isevars) pred)
- | None ->
- let sigma = evars_of isevars in
- error_cant_find_case_type_loc loc env sigma cj.uj_val
- else
- try
- let expti = expbr.(i) in
- let fj =
- pretype (mk_tycon expti) env isevars lvar lf.(i) in
- let pred =
- Cases.pred_case_ml (* eta-expanse *)
- env (evars_of isevars) isrec indt (i,fj.uj_type) in
- if has_undefined_isevars isevars pred then findtype (i+1)
- else
- let pty =
- Retyping.get_type_of env (evars_of isevars) pred in
- let pj = { uj_val = pred; uj_type = pty } in
-(*
- let _ = option_app (the_conv_x_leq env isevars pred) tycon
- in
-*)
- (true,pj)
- with Cases.NotInferable _ -> findtype (i+1) in
- findtype 0
- in
- let pj = j_nf_evar (evars_of isevars) pj in
- let pj = if dep then pj else make_dep_of_undep env indt pj in
- let (bty,rsty) =
- Indrec.type_rec_branches
- isrec env (evars_of isevars) indt pj.uj_val cj.uj_val in
- let _ = option_app (the_conv_x_leq env isevars rsty) tycon in
- if Array.length bty <> Array.length lf then
- error_number_branches_loc loc env (evars_of isevars)
- cj (Array.length bty)
- else
- let lfj =
- array_map2
- (fun tyc f -> pretype (mk_tycon tyc) env isevars lvar f) bty
- lf in
- let lfv = Array.map j_val lfj in
- let lft = Array.map (fun j -> j.uj_type) lfj in
- check_branches_message loc env isevars cj.uj_val (bty,lft);
- let v =
- if isrec
- then
- transform_rec loc env (evars_of isevars)(pj,cj.uj_val,lfv) indt
- else
+ let psign = (na,None,build_dependent_inductive env indf)::arsgn in
+ let nar = List.length arsgn in
+ (match po with
+ | Some p ->
+ let env_p = push_rels psign env in
+ let pj = pretype_type empty_valcon env_p isevars lvar p in
+ let ccl = nf_evar (evars_of !isevars) pj.utj_val in
+ let psign = make_arity_signature env true indf in (* with names *)
+ let p = it_mkLambda_or_LetIn ccl psign in
+ let inst =
+ (Array.to_list cs.cs_concl_realargs)
+ @[build_dependent_constructor cs] in
+ let lp = lift cs.cs_nargs p in
+ let fty = hnf_lam_applist env (evars_of !isevars) lp inst in
+ let fj = pretype (mk_tycon fty) env_f isevars lvar d in
+ let f = it_mkLambda_or_LetIn fj.uj_val fsign in
+ let v =
+ let mis,_ = dest_ind_family indf in
+ let ci = make_default_case_info env LetStyle mis in
+ mkCase (ci, p, cj.uj_val,[|f|]) in
+ { uj_val = v; uj_type = substl (realargs@[cj.uj_val]) ccl }
+
+ | None ->
+ let tycon = lift_tycon cs.cs_nargs tycon in
+ let fj = pretype tycon env_f isevars lvar d in
+ let f = it_mkLambda_or_LetIn fj.uj_val fsign in
+ let ccl = nf_evar (evars_of !isevars) fj.uj_type in
+ let ccl =
+ if noccur_between 1 cs.cs_nargs ccl then
+ lift (- cs.cs_nargs) ccl
+ else
+ error_cant_find_case_type_loc loc env (evars_of !isevars)
+ cj.uj_val in
+ let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign in
+ let v =
+ let mis,_ = dest_ind_family indf in
+ let ci = make_default_case_info env LetStyle mis in
+ mkCase (ci, p, cj.uj_val,[|f|] )
+ in
+ { uj_val = v; uj_type = ccl })
+
+ | RIf (loc,c,(na,po),b1,b2) ->
+ let cj = pretype empty_tycon env isevars lvar c in
+ let (IndType (indf,realargs)) =
+ try find_rectype env (evars_of !isevars) cj.uj_type
+ with Not_found ->
+ let cloc = loc_of_rawconstr c in
+ error_case_not_inductive_loc cloc env (evars_of !isevars) cj in
+ let cstrs = get_constructors env indf in
+ if Array.length cstrs <> 2 then
+ user_err_loc (loc,"",
+ str "If is only for inductive types with two constructors");
+
+ let arsgn =
+ let arsgn,_ = get_arity env indf in
+ if not !allow_anonymous_refs then
+ (* Make dependencies from arity signature impossible *)
+ List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn
+ else arsgn
+ in
+ let nar = List.length arsgn in
+ let psign = (na,None,build_dependent_inductive env indf)::arsgn in
+ let pred,p = match po with
+ | Some p ->
+ let env_p = push_rels psign env in
+ let pj = pretype_type empty_valcon env_p isevars lvar p in
+ let ccl = nf_evar (evars_of !isevars) pj.utj_val in
+ let pred = it_mkLambda_or_LetIn ccl psign in
+ let typ = lift (- nar) (beta_applist (pred,[cj.uj_val])) in
+ let jtyp = inh_conv_coerce_to_tycon loc env isevars {uj_val = pred;
+ uj_type = typ} tycon
+ in
+ jtyp.uj_val, jtyp.uj_type
+ | None ->
+ let p = match tycon with
+ | Some (None, ty) -> ty
+ | None | Some _ ->
+ e_new_evar isevars env ~src:(loc,InternalHole) (new_Type ())
+ in
+ it_mkLambda_or_LetIn (lift (nar+1) p) psign, p in
+ let pred = nf_evar (evars_of !isevars) pred in
+ let p = nf_evar (evars_of !isevars) p in
+ (* msgnl (str "Pred is: " ++ Termops.print_constr_env env pred);*)
+ let f cs b =
+ let n = rel_context_length cs.cs_args in
+ let pi = lift n pred in (* liftn n 2 pred ? *)
+ let pi = beta_applist (pi, [build_dependent_constructor cs]) in
+ let csgn =
+ if not !allow_anonymous_refs then
+ List.map (fun (_,b,t) -> (Anonymous,b,t)) cs.cs_args
+ else
+ List.map
+ (fun (n, b, t) ->
+ match n with
+ Name _ -> (n, b, t)
+ | Anonymous -> (Name (id_of_string "H"), b, t))
+ cs.cs_args
+ in
+ let env_c = push_rels csgn env in
+(* msgnl (str "Pi is: " ++ Termops.print_constr_env env_c pi); *)
+ let bj = pretype (mk_tycon pi) env_c isevars lvar b in
+ it_mkLambda_or_LetIn bj.uj_val cs.cs_args in
+ let b1 = f cstrs.(0) b1 in
+ let b2 = f cstrs.(1) b2 in
+ let v =
let mis,_ = dest_ind_family indf in
- let ci = make_default_case_info env st mis in
- mkCase (ci, (nf_betaiota pj.uj_val), cj.uj_val,
- Array.map (fun j-> j.uj_val) lfj)
- in
- (* Build the Cases form for v8 *)
- let c =
- let (ind,params) = dest_ind_family indf in
- let (mib,mip) = lookup_mind_specif env ind in
- let recargs = mip.mind_recargs in
- let mI = mkInd ind in
- let nconstr = Array.length mip.mind_consnames in
- let tyi = snd ind in
- if isrec && mis_is_recursive_subset [tyi] recargs then
- Some (Detyping.detype (false,env)
- (ids_of_context env) (names_of_rel_context env)
- (nf_evar (evars_of isevars) v))
- else
- (* Translate into a "match ... with" *)
- let rtntypopt, indnalopt = match po with
- | None -> None, (Anonymous,None)
- | Some p ->
- let rec decomp_lam_force n avoid l p =
- (* avoid is not exhaustive ! *)
- if n = 0 then (List.rev l,p,avoid) else
- match p with
- | RLambda (_,(Name id as na),_,c) ->
- decomp_lam_force (n-1) (id::avoid) (na::l) c
- | RLambda (_,(Anonymous as na),_,c) ->
- decomp_lam_force (n-1) avoid (na::l) c
- | _ ->
- let x = Nameops.next_ident_away (id_of_string "x") avoid in
- decomp_lam_force (n-1) (x::avoid) (Name x :: l)
- (* eta-expansion *)
- (RApp (dummy_loc,p, [RVar (dummy_loc,x)])) in
- let (nal,p,avoid) =
- decomp_lam_force (List.length realargs) [] [] p in
- let na,rtntyopt,_ =
- if dep then decomp_lam_force 1 avoid [] p
- else [Anonymous],p,[] in
- let intyp =
- if nal=[] then None else
- let args = List.map (fun _ -> Anonymous) params @ nal in
- Some (dummy_loc,ind,args) in
- (Some rtntyopt,(List.hd na,intyp)) in
- let rawbranches =
- array_map3 (fun bj b cstr ->
- let rec strip n r = if n=0 then r else
- match r with
- | RLambda (_,_,_,t) -> strip (n-1) t
- | RLetIn (_,_,_,t) -> strip (n-1) t
- | _ -> assert false in
- let n = rel_context_length cstr.cs_args in
- try
- let _,ccl = decompose_lam_n_assum n bj.uj_val in
- if noccur_between 1 n ccl then Some (strip n b) else None
- with _ -> (* Not eta-expanded or not reduced *) None)
- lfj lf (get_constructors env indf) in
- if st = IfStyle & snd indnalopt = None
- & rawbranches.(0) <> None && rawbranches.(1) <> None then
- (* Translate into a "if ... then ... else" *)
- (* TODO: translate into a "if" even if po is dependent *)
- Some (RIf (loc,c,(fst indnalopt,rtntypopt),
- out_some rawbranches.(0),out_some rawbranches.(1)))
- else
- let detype_eqn constr construct_nargs branch =
- let name_cons = function
- | Anonymous -> fun l -> l
- | Name id -> fun l -> id::l in
- let make_pat na avoid b ids =
- PatVar (dummy_loc,na),
- name_cons na avoid,name_cons na ids
- in
- let rec buildrec ids patlist avoid n b =
- if n=0 then
- (dummy_loc, ids,
- [PatCstr(dummy_loc, constr, List.rev patlist,Anonymous)],
- b)
- else
- match b with
- | RLambda (_,x,_,b) ->
- let pat,new_avoid,new_ids = make_pat x avoid b ids in
- buildrec new_ids (pat::patlist) new_avoid (n-1) b
-
- | RLetIn (_,x,_,b) ->
- let pat,new_avoid,new_ids = make_pat x avoid b ids in
- buildrec new_ids (pat::patlist) new_avoid (n-1) b
-
- | RCast (_,c,_) -> (* Oui, il y a parfois des cast *)
- buildrec ids patlist avoid n c
-
- | _ -> (* eta-expansion *)
- (* nommage de la nouvelle variable *)
- let id = Nameops.next_ident_away (id_of_string "x") avoid in
- let new_b = RApp (dummy_loc, b, [RVar(dummy_loc,id)])in
- let pat,new_avoid,new_ids =
- make_pat (Name id) avoid new_b ids in
- buildrec new_ids (pat::patlist) new_avoid (n-1) new_b
-
- in
- buildrec [] [] [] construct_nargs branch in
- let (mib,mip) = Inductive.lookup_mind_specif (Global.env()) ind in
- let get_consnarg j =
- let typi = mis_nf_constructor_type (ind,mib,mip) (j+1) in
- let _,t = decompose_prod_n_assum mip.mind_nparams typi in
- List.rev (fst (decompose_prod_assum t)) in
- let consnargs = Array.init (Array.length mip.mind_consnames) get_consnarg in
- let consnargsl = Array.map List.length consnargs in
- let constructs = Array.init (Array.length lf) (fun i -> (ind,i+1)) in
- let eqns = array_map3 detype_eqn constructs consnargsl lf in
- Some (RCases (loc,(po,ref rtntypopt),[c,ref indnalopt],Array.to_list eqns)) in
- x := c;
- (* End build the Cases form for v8 *)
- { uj_val = v;
- uj_type = rsty }
-
- | RCases (loc,po,tml,eqns) ->
- Cases.compile_cases loc
- ((fun vtyc env -> pretype vtyc env isevars lvar),isevars)
- tycon env (* loc *) (po,tml,eqns)
-
- | RCast(loc,c,t) ->
- let tj = pretype_type empty_tycon env isevars lvar t in
- let cj = pretype (mk_tycon tj.utj_val) env isevars lvar c in
- (* User Casts are for helping pretyping, experimentally not to be kept*)
- (* ... except for Correctness *)
- let v = mkCast (cj.uj_val, tj.utj_val) in
- let cj = { uj_val = v; uj_type = tj.utj_val } in
- inh_conv_coerce_to_tycon loc env isevars cj tycon
-
- | RDynamic (loc,d) ->
- if (tag d) = "constr" then
- let c = constr_out d in
- let j = (Retyping.get_judgment_of env (evars_of isevars) c) in
+ let ci = make_default_case_info env IfStyle mis in
+ mkCase (ci, pred, cj.uj_val, [|b1;b2|])
+ in
+ { uj_val = v; uj_type = p }
+
+ | RCases (loc,po,tml,eqns) ->
+ Cases.compile_cases loc
+ ((fun vtyc env -> pretype vtyc env isevars lvar),isevars)
+ tycon env (* loc *) (po,tml,eqns)
+
+ | RCast(loc,c,k,t) ->
+ let tj = pretype_type empty_valcon env isevars lvar t in
+ let cj = pretype (mk_tycon tj.utj_val) env isevars lvar c in
+ (* User Casts are for helping pretyping, experimentally not to be kept*)
+ (* ... except for Correctness *)
+ let v = mkCast (cj.uj_val, k, tj.utj_val) in
+ let cj = { uj_val = v; uj_type = tj.utj_val } in
+ inh_conv_coerce_to_tycon loc env isevars cj tycon
+
+ | RDynamic (loc,d) ->
+ if (tag d) = "constr" then
+ let c = constr_out d in
+ let j = (Retyping.get_judgment_of env (evars_of !isevars) c) in
+ j
+ (*inh_conv_coerce_to_tycon loc env isevars j tycon*)
+ else
+ user_err_loc (loc,"pretype",(str "Not a constr tagged Dynamic"))
+
+ (* [pretype_type valcon env isevars lvar c] coerces [c] into a type *)
+ and pretype_type valcon env isevars lvar = function
+ | RHole loc ->
+ (match valcon with
+ | Some v ->
+ let s =
+ let sigma = evars_of !isevars in
+ let t = Retyping.get_type_of env sigma v in
+ match kind_of_term (whd_betadeltaiota env sigma t) with
+ | Sort s -> s
+ | Evar v when is_Type (existential_type sigma v) ->
+ evd_comb1 (define_evar_as_sort) isevars v
+ | _ -> anomaly "Found a type constraint which is not a type"
+ in
+ { utj_val = v;
+ utj_type = s }
+ | None ->
+ let s = new_Type_sort () in
+ { utj_val = e_new_evar isevars env ~src:loc (mkSort s);
+ utj_type = s})
+ | c ->
+ let j = pretype empty_tycon env isevars lvar c in
+ let loc = loc_of_rawconstr c in
+ let tj = evd_comb1 (Coercion.inh_coerce_to_sort loc env) isevars j in
+ match valcon with
+ | None -> tj
+ | Some v ->
+ if e_cumul env isevars v tj.utj_val then tj
+ else
+ error_unexpected_type_loc
+ (loc_of_rawconstr c) env (evars_of !isevars) tj.utj_val v
+
+ let pretype_gen isevars env lvar kind c =
+ let c' = match kind with
+ | OfType exptyp ->
+ let tycon = match exptyp with None -> empty_tycon | Some t -> mk_tycon t in
+ (pretype tycon env isevars lvar c).uj_val
+ | IsType ->
+ (pretype_type empty_valcon env isevars lvar c).utj_val in
+ nf_evar (evars_of !isevars) c'
+
+ (* [check_evars] fails if some unresolved evar remains *)
+ (* it assumes that the defined existentials have already been substituted
+ (should be done in unsafe_infer and unsafe_infer_type) *)
+
+ let check_evars env initial_sigma isevars c =
+ let sigma = evars_of !isevars in
+ let rec proc_rec c =
+ match kind_of_term c with
+ | Evar (ev,args) ->
+ assert (Evd.in_dom sigma ev);
+ if not (Evd.in_dom initial_sigma ev) then
+ let (loc,k) = evar_source ev !isevars in
+ error_unsolvable_implicit loc env sigma k
+ | _ -> iter_constr proc_rec c
+ in
+ proc_rec c(*;
+ let (_,pbs) = get_conv_pbs !isevars (fun _ -> true) in
+ if pbs <> [] then begin
+ pperrnl
+ (str"TYPING OF "++Termops.print_constr_env env c++fnl()++
+ prlist_with_sep fnl
+ (fun (pb,c1,c2) ->
+ Termops.print_constr c1 ++
+ (if pb=Reduction.CUMUL then str " <="++ spc()
+ else str" =="++spc()) ++
+ Termops.print_constr c2)
+ pbs ++ fnl())
+ end*)
+
+ (* TODO: comment faire remonter l'information si le typage a resolu des
+ variables du sigma original. il faudrait que la fonction de typage
+ retourne aussi le nouveau sigma...
+ *)
+
+ let understand_judgment sigma env c =
+ let isevars = ref (create_evar_defs sigma) in
+ let j = pretype empty_tycon env isevars ([],[]) c in
+ let j = j_nf_evar (evars_of !isevars) j in
+ check_evars env sigma isevars (mkCast(j.uj_val,DEFAULTcast, j.uj_type));
j
- (*inh_conv_coerce_to_tycon loc env isevars j tycon*)
- else
- user_err_loc (loc,"pretype",(str "Not a constr tagged Dynamic"))
-
-(* [pretype_type valcon env isevars lvar c] coerces [c] into a type *)
-and pretype_type valcon env isevars lvar = function
- | RHole loc ->
- (match valcon with
- | Some v ->
- let s =
- let sigma = evars_of isevars in
- let t = Retyping.get_type_of env sigma v in
- match kind_of_term (whd_betadeltaiota env sigma t) with
- | Sort s -> s
- | Evar v when is_Type (existential_type sigma v) ->
- define_evar_as_sort isevars v
- | _ -> anomaly "Found a type constraint which is not a type"
- in
- { utj_val = v;
- utj_type = s }
- | None ->
- let s = new_Type_sort () in
- { utj_val = new_isevar isevars env loc (mkSort s);
- utj_type = s})
- | c ->
- let j = pretype empty_tycon env isevars lvar c in
- let tj = inh_coerce_to_sort env isevars j in
- match valcon with
- | None -> tj
- | Some v ->
- if the_conv_x_leq env isevars v tj.utj_val then tj
- else
- error_unexpected_type_loc
- (loc_of_rawconstr c) env (evars_of isevars) tj.utj_val v
-
-
-let unsafe_infer tycon isevars env lvar constr =
- let j = pretype tycon env isevars lvar constr in
- j_nf_evar (evars_of isevars) j
-
-let unsafe_infer_type valcon isevars env lvar constr =
- let tj = pretype_type valcon env isevars lvar constr in
- tj_nf_evar (evars_of isevars) tj
-
-(* If fail_evar is false, [process_evars] builds a meta_map with the
- unresolved Evar that were not in initial sigma; otherwise it fail
- on the first unresolved Evar not already in the initial sigma. *)
-(* [fail_evar] says how to process unresolved evars:
- * true -> raise an error message
- * false -> convert them into new Metas (casted with their type)
- *)
-(* assumes the defined existentials have been replaced in c (should be
- done in unsafe_infer and unsafe_infer_type) *)
-let check_evars fail_evar env initial_sigma isevars c =
- let sigma = evars_of isevars in
- let rec proc_rec c =
- match kind_of_term c with
- | Evar (ev,args as k) ->
- assert (Evd.in_dom sigma ev);
- if not (Evd.in_dom initial_sigma ev) then
- (if fail_evar then
- let (loc,k) = evar_source ev isevars in
- error_unsolvable_implicit loc env sigma k)
- | _ -> iter_constr proc_rec c
- in
- proc_rec c
-
-(* TODO: comment faire remonter l'information si le typage a resolu des
- variables du sigma original. il faudrait que la fonction de typage
- retourne aussi le nouveau sigma...
-*)
-
-(* constr with holes *)
-type open_constr = evar_map * constr
-
-let ise_resolve_casted_gen fail_evar sigma env lvar typ c =
- let isevars = create_evar_defs sigma in
- let j = unsafe_infer (mk_tycon typ) isevars env lvar c in
- check_evars fail_evar env sigma isevars (mkCast(j.uj_val,j.uj_type));
- (evars_of isevars, j)
-
-let ise_resolve_casted sigma env typ c =
- ise_resolve_casted_gen true sigma env ([],[]) typ c
-
-(* Raw calls to the unsafe inference machine: boolean says if we must fail
- on unresolved evars, or replace them by Metas; the unsafe_judgment list
- allows us to extend env with some bindings *)
-let ise_infer_gen fail_evar sigma env lvar exptyp c =
- let tycon = match exptyp with None -> empty_tycon | Some t -> mk_tycon t in
- let isevars = create_evar_defs sigma in
- let j = unsafe_infer tycon isevars env lvar c in
- check_evars fail_evar env sigma isevars (mkCast(j.uj_val,j.uj_type));
- (evars_of isevars, j)
-
-let ise_infer_type_gen fail_evar sigma env lvar c =
- let isevars = create_evar_defs sigma in
- let tj = unsafe_infer_type empty_valcon isevars env lvar c in
- check_evars fail_evar env sigma isevars tj.utj_val;
- (evars_of isevars, tj)
-type var_map = (identifier * unsafe_judgment) list
+ let understand_judgment_tcc isevars env c =
+ let j = pretype empty_tycon env isevars ([],[]) c in
+ let sigma = evars_of !isevars in
+ let j = j_nf_evar sigma j in
+ j
-let understand_judgment sigma env c =
- snd (ise_infer_gen true sigma env ([],[]) None c)
+ (* Raw calls to the unsafe inference machine: boolean says if we must
+ fail on unresolved evars; the unsafe_judgment list allows us to
+ extend env with some bindings *)
-let understand_type_judgment sigma env c =
- snd (ise_infer_type_gen true sigma env ([],[]) c)
+ let ise_pretype_gen fail_evar sigma env lvar kind c =
+ let isevars = ref (Evd.create_evar_defs sigma) in
+ let c = pretype_gen isevars env lvar kind c in
+ if fail_evar then check_evars env sigma isevars c;
+ !isevars, c
-let understand sigma env c =
- let _, c = ise_infer_gen true sigma env ([],[]) None c in
- c.uj_val
+ (** Entry points of the high-level type synthesis algorithm *)
-let understand_type sigma env c =
- let _,c = ise_infer_type_gen true sigma env ([],[]) c in
- c.utj_val
+ let understand_gen kind sigma env c =
+ snd (ise_pretype_gen true sigma env ([],[]) kind c)
-let understand_gen_ltac sigma env lvar ~expected_type:exptyp c =
- let _, c = ise_infer_gen true sigma env lvar exptyp c in
- c.uj_val
+ let understand sigma env ?expected_type:exptyp c =
+ snd (ise_pretype_gen true sigma env ([],[]) (OfType exptyp) c)
-let understand_gen sigma env lvar ~expected_type:exptyp c =
- let _, c = ise_infer_gen true sigma env (lvar,[]) exptyp c in
- c.uj_val
+ let understand_type sigma env c =
+ snd (ise_pretype_gen true sigma env ([],[]) IsType c)
-let understand_gen_tcc sigma env lvar exptyp c =
- let metamap, c = ise_infer_gen false sigma env (lvar,[]) exptyp c in
- metamap, c.uj_val
+ let understand_ltac sigma env lvar kind c =
+ ise_pretype_gen false sigma env lvar kind c
+
+ let understand_tcc_evars isevars env kind c =
+ pretype_gen isevars env ([],[]) kind c
-let interp_sort = function
- | RProp c -> Prop c
- | RType _ -> new_Type_sort ()
+ let understand_tcc sigma env ?expected_type:exptyp c =
+ let ev, t = ise_pretype_gen false sigma env ([],[]) (OfType exptyp) c in
+ Evd.evars_of ev, t
+end
-let interp_elimination_sort = function
- | RProp Null -> InProp
- | RProp Pos -> InSet
- | RType _ -> InType
+module Default : S = Pretyping_F(Coercion.Default)
diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli
index 4357e504..7bb8c374 100644
--- a/pretyping/pretyping.mli
+++ b/pretyping/pretyping.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: pretyping.mli,v 1.28.2.1 2004/07/16 19:30:46 herbelin Exp $ i*)
+(*i $Id: pretyping.mli 8688 2006-04-07 15:08:12Z msozeau $ i*)
(*i*)
open Names
@@ -18,69 +18,97 @@ open Rawterm
open Evarutil
(*i*)
-type var_map = (identifier * unsafe_judgment) list
-
-(* constr with holes *)
-type open_constr = evar_map * constr
-
-
-(* Generic call to the interpreter from rawconstr to constr, failing
- unresolved holes in the rawterm cannot be instantiated.
-
- In [understand_gen sigma env varmap typopt raw],
-
- sigma : initial set of existential variables (typically dependent subgoals)
- varmap : partial subtitution of variables (used for the tactic language)
- metamap : partial subtitution of meta (used for the tactic language)
- typopt : is not None, this is the expected type for raw (used to define evars)
-*)
-val understand_gen :
- evar_map -> env -> var_map
- -> expected_type:(constr option) -> rawconstr -> constr
+type typing_constraint = OfType of types option | IsType
-val understand_gen_ltac :
- evar_map -> env -> var_map * (identifier * identifier option) list
- -> expected_type:(constr option) -> rawconstr -> constr
-
-(* Generic call to the interpreter from rawconstr to constr, turning
- unresolved holes into metas. Returns also the typing context of
- these metas. Work as [understand_gen] for the rest. *)
-val understand_gen_tcc :
- evar_map -> env -> var_map
- -> constr option -> rawconstr -> open_constr
-
-(* Standard call to get a constr from a rawconstr, resolving implicit args *)
-val understand : evar_map -> env -> rawconstr -> constr
+type var_map = (identifier * unsafe_judgment) list
+type unbound_ltac_var_map = (identifier * identifier option) list
+
+module type S =
+sig
+
+ module Cases : Cases.S
+
+ (* Allow references to syntaxically inexistent variables (i.e., if applied on an inductive) *)
+ val allow_anonymous_refs : bool ref
+
+ (* Generic call to the interpreter from rawconstr to open_constr, leaving
+ unresolved holes as evars and returning the typing contexts of
+ these evars. Work as [understand_gen] for the rest. *)
+
+ val understand_tcc :
+ evar_map -> env -> ?expected_type:types -> rawconstr -> open_constr
+
+ val understand_tcc_evars :
+ evar_defs ref -> env -> typing_constraint -> rawconstr -> constr
+
+ (* More general entry point with evars from ltac *)
+
+ (* Generic call to the interpreter from rawconstr to constr, failing
+ unresolved holes in the rawterm cannot be instantiated.
+
+ In [understand_ltac sigma env ltac_env constraint c],
+
+ sigma : initial set of existential variables (typically dependent subgoals)
+ ltac_env : partial substitution of variables (used for the tactic language)
+ constraint : tell if interpreted as a possibly constrained term or a type
+ *)
+
+ val understand_ltac :
+ evar_map -> env -> var_map * unbound_ltac_var_map ->
+ typing_constraint -> rawconstr -> evar_defs * constr
+
+ (* Standard call to get a constr from a rawconstr, resolving implicit args *)
+
+ val understand : evar_map -> env -> ?expected_type:Term.types ->
+ rawconstr -> constr
+
+ (* Idem but the rawconstr is intended to be a type *)
+
+ val understand_type : evar_map -> env -> rawconstr -> constr
+
+ (* A generalization of the two previous case *)
+
+ val understand_gen : typing_constraint -> evar_map -> env ->
+ rawconstr -> constr
+
+ (* Idem but returns the judgment of the understood term *)
+
+ val understand_judgment : evar_map -> env -> rawconstr -> unsafe_judgment
+
+ (* Idem but do not fail on unresolved evars *)
+ val understand_judgment_tcc : evar_defs ref -> env -> rawconstr -> unsafe_judgment
+
+
+ (*i*)
+ (* Internal of Pretyping...
+ *)
+ val pretype :
+ type_constraint -> env -> evar_defs ref ->
+ var_map * (identifier * identifier option) list ->
+ rawconstr -> unsafe_judgment
+
+ val pretype_type :
+ val_constraint -> env -> evar_defs ref ->
+ var_map * (identifier * identifier option) list ->
+ rawconstr -> unsafe_type_judgment
-(* Idem but the rawconstr is intended to be a type *)
-val understand_type : evar_map -> env -> rawconstr -> constr
+ val pretype_gen :
+ evar_defs ref -> env ->
+ var_map * (identifier * identifier option) list ->
+ typing_constraint -> rawconstr -> constr
-(* Idem but returns the judgment of the understood term *)
-val understand_judgment : evar_map -> env -> rawconstr -> unsafe_judgment
+ (*i*)
+
+end
-(* Idem but returns the judgment of the understood type *)
-val understand_type_judgment : evar_map -> env -> rawconstr
- -> unsafe_type_judgment
+module Pretyping_F (C : Coercion.S) : S
+module Default : S
(* To embed constr in rawconstr *)
+
val constr_in : constr -> Dyn.t
val constr_out : Dyn.t -> constr
-(*i*)
-(* Internal of Pretyping...
- * Unused outside, but useful for debugging
- *)
-val pretype :
- type_constraint -> env -> evar_defs ->
- var_map * (identifier * identifier option) list ->
- rawconstr -> unsafe_judgment
-
-val pretype_type :
- val_constraint -> env -> evar_defs ->
- var_map * (identifier * identifier option) list ->
- rawconstr -> unsafe_type_judgment
-(*i*)
-
-val interp_sort : rawsort -> sorts
-
+val interp_sort : rawsort -> sorts
val interp_elimination_sort : rawsort -> sorts_family
+
diff --git a/pretyping/rawterm.ml b/pretyping/rawterm.ml
index ef4a4670..5d177326 100644
--- a/pretyping/rawterm.ml
+++ b/pretyping/rawterm.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: rawterm.ml,v 1.43.2.4 2004/12/29 10:17:10 herbelin Exp $ *)
+(* $Id: rawterm.ml 8624 2006-03-13 17:38:17Z msozeau $ *)
(*i*)
open Util
@@ -15,6 +15,7 @@ open Sign
open Term
open Libnames
open Nametab
+open Evd
(*i*)
(* Untyped intermediate terms, after ASTs and before constr. *)
@@ -33,8 +34,6 @@ type patvar = identifier
type rawsort = RProp of Term.contents | RType of Univ.universe option
-type fix_kind = RFix of (int array * int) | RCoFix of int
-
type binder_kind = BProd | BLambda | BLetIn
type quantified_hypothesis = AnonHyp of int | NamedHyp of identifier
@@ -48,14 +47,6 @@ type 'a bindings =
type 'a with_bindings = 'a * 'a bindings
-type hole_kind =
- | ImplicitArg of global_reference * (int * identifier option)
- | BinderType of name
- | QuestionMark
- | CasesType
- | InternalHole
- | TomatchTypeParameter of inductive * int
-
type rawconstr =
| RRef of (loc * global_reference)
| RVar of (loc * identifier)
@@ -65,11 +56,9 @@ type rawconstr =
| RLambda of loc * name * rawconstr * rawconstr
| RProd of loc * name * rawconstr * rawconstr
| RLetIn of loc * name * rawconstr * rawconstr
- | RCases of loc * (rawconstr option * rawconstr option ref) *
- (rawconstr * (name * (loc * inductive * name list) option) ref) list *
+ | RCases of loc * rawconstr option *
+ (rawconstr * (name * (loc * inductive * name list) option)) list *
(loc * identifier list * cases_pattern list * rawconstr) list
- | ROrderedCase of loc * case_style * rawconstr option * rawconstr *
- rawconstr array * rawconstr option ref
| RLetTuple of loc * name list * (name * rawconstr option) *
rawconstr * rawconstr
| RIf of loc * rawconstr * (name * rawconstr option) * rawconstr * rawconstr
@@ -77,15 +66,19 @@ type rawconstr =
rawconstr array * rawconstr array
| RSort of loc * rawsort
| RHole of (loc * hole_kind)
- | RCast of loc * rawconstr * rawconstr
+ | RCast of loc * rawconstr * cast_kind * rawconstr
| RDynamic of loc * Dyn.t
and rawdecl = name * rawconstr option * rawconstr
+and fix_recursion_order = RStructRec | RWfRec of rawconstr
+
+and fix_kind = RFix of ((int * fix_recursion_order) array * int) | RCoFix of int
+
let cases_predicate_names tml =
List.flatten (List.map (function
- | (tm,{contents=(na,None)}) -> [na]
- | (tm,{contents=(na,Some (_,_,nal))}) -> na::nal) tml)
+ | (tm,(na,None)) -> [na]
+ | (tm,(na,Some (_,_,nal))) -> na::nal) tml)
(*i - if PRec (_, names, arities, bodies) is in env then arities are
typed in env too and bodies are typed in env enriched by the
@@ -104,12 +97,10 @@ let map_rawconstr f = function
| RLambda (loc,na,ty,c) -> RLambda (loc,na,f ty,f c)
| RProd (loc,na,ty,c) -> RProd (loc,na,f ty,f c)
| RLetIn (loc,na,b,c) -> RLetIn (loc,na,f b,f c)
- | RCases (loc,(tyopt,rtntypopt),tml,pl) ->
- RCases (loc,(option_app f tyopt,ref (option_app f !rtntypopt)),
+ | RCases (loc,rtntypopt,tml,pl) ->
+ RCases (loc,option_app f rtntypopt,
List.map (fun (tm,x) -> (f tm,x)) tml,
List.map (fun (loc,idl,p,c) -> (loc,idl,p,f c)) pl)
- | ROrderedCase (loc,b,tyopt,tm,bv,x) ->
- ROrderedCase (loc,b,option_app f tyopt,f tm, Array.map f bv,ref (option_app f !x))
| RLetTuple (loc,nal,(na,po),b,c) ->
RLetTuple (loc,nal,(na,option_app f po),f b,f c)
| RIf (loc,c,(na,po),b1,b2) ->
@@ -117,7 +108,7 @@ let map_rawconstr f = function
| RRec (loc,fk,idl,bl,tyl,bv) ->
RRec (loc,fk,idl,Array.map (List.map (map_rawdecl f)) bl,
Array.map f tyl,Array.map f bv)
- | RCast (loc,c,t) -> RCast (loc,f c,f t)
+ | RCast (loc,c,k,t) -> RCast (loc,f c,k,f t)
| (RSort _ | RHole _ | RRef _ | REvar _ | RPatVar _ | RDynamic _) as x -> x
@@ -147,8 +138,6 @@ let map_rawconstr_with_binders_loc loc g f e = function
let h (_,idl,p,c) = (loc,idl,p,f (List.fold_right g' idl e) c) in
RCases
(loc,option_app (f e) tyopt,List.map (f e) tml, List.map h pl)
- | ROrderedCase (_,b,tyopt,tm,bv) ->
- ROrderedCase (loc,b,option_app (f e) tyopt,f e tm,Array.map (f e) bv)
| RRec (_,fk,idl,tyl,bv) ->
let idl',e' = fold_ident g idl e in
RRec (loc,fk,idl',Array.map (f e) tyl,Array.map (f e') bv)
@@ -168,12 +157,10 @@ let occur_rawconstr id =
| RLambda (loc,na,ty,c) -> (occur ty) or ((na <> Name id) & (occur c))
| RProd (loc,na,ty,c) -> (occur ty) or ((na <> Name id) & (occur c))
| RLetIn (loc,na,b,c) -> (occur b) or ((na <> Name id) & (occur c))
- | RCases (loc,(tyopt,rtntypopt),tml,pl) ->
- (occur_option tyopt) or (occur_option !rtntypopt)
+ | RCases (loc,rtntypopt,tml,pl) ->
+ (occur_option rtntypopt)
or (List.exists (fun (tm,_) -> occur tm) tml)
or (List.exists occur_pattern pl)
- | ROrderedCase (loc,b,tyopt,tm,bv,_) ->
- (occur_option tyopt) or (occur tm) or (array_exists occur bv)
| RLetTuple (loc,nal,rtntyp,b,c) ->
occur_return_type rtntyp id
or (occur b) or (not (List.mem (Name id) nal) & (occur c))
@@ -191,7 +178,7 @@ let occur_rawconstr id =
(na=Name id or not(occur_fix bl)) in
occur_fix bl)
idl bl tyl bv)
- | RCast (loc,c,t) -> (occur c) or (occur t)
+ | RCast (loc,c,_,t) -> (occur c) or (occur t)
| (RSort _ | RHole _ | RRef _ | REvar _ | RPatVar _ | RDynamic _) -> false
and occur_pattern (loc,idl,p,c) = not (List.mem id idl) & (occur c)
@@ -202,119 +189,6 @@ let occur_rawconstr id =
in occur
-let rec subst_pat subst pat =
- match pat with
- | PatVar _ -> pat
- | PatCstr (loc,((kn,i),j),cpl,n) ->
- let kn' = subst_kn subst kn
- and cpl' = list_smartmap (subst_pat subst) cpl in
- if kn' == kn && cpl' == cpl then pat else
- PatCstr (loc,((kn',i),j),cpl',n)
-
-let rec subst_raw subst raw =
- match raw with
- | RRef (loc,ref) ->
- let ref' = subst_global subst ref in
- if ref' == ref then raw else
- RRef (loc,ref')
-
- | RVar _ -> raw
- | REvar _ -> raw
- | RPatVar _ -> raw
-
- | RApp (loc,r,rl) ->
- let r' = subst_raw subst r
- and rl' = list_smartmap (subst_raw subst) rl in
- if r' == r && rl' == rl then raw else
- RApp(loc,r',rl')
-
- | RLambda (loc,n,r1,r2) ->
- let r1' = subst_raw subst r1 and r2' = subst_raw subst r2 in
- if r1' == r1 && r2' == r2 then raw else
- RLambda (loc,n,r1',r2')
-
- | RProd (loc,n,r1,r2) ->
- let r1' = subst_raw subst r1 and r2' = subst_raw subst r2 in
- if r1' == r1 && r2' == r2 then raw else
- RProd (loc,n,r1',r2')
-
- | RLetIn (loc,n,r1,r2) ->
- let r1' = subst_raw subst r1 and r2' = subst_raw subst r2 in
- if r1' == r1 && r2' == r2 then raw else
- RLetIn (loc,n,r1',r2')
-
- | RCases (loc,(ro,rtno),rl,branches) ->
- let ro' = option_smartmap (subst_raw subst) ro
- and rtno' = ref (option_smartmap (subst_raw subst) !rtno)
- and rl' = list_smartmap (fun (a,x as y) ->
- let a' = subst_raw subst a in
- let (n,topt) = !x in
- let topt' = option_smartmap
- (fun (loc,(sp,i),x as t) ->
- let sp' = subst_kn subst sp in
- if sp == sp' then t else (loc,(sp',i),x)) topt in
- if a == a' && topt == topt' then y else (a',ref (n,topt'))) rl
- and branches' = list_smartmap
- (fun (loc,idl,cpl,r as branch) ->
- let cpl' = list_smartmap (subst_pat subst) cpl
- and r' = subst_raw subst r in
- if cpl' == cpl && r' == r then branch else
- (loc,idl,cpl',r'))
- branches
- in
- if ro' == ro && rl' == rl && branches' == branches then raw else
- RCases (loc,(ro',rtno'),rl',branches')
-
- | ROrderedCase (loc,b,ro,r,ra,x) ->
- let ro' = option_smartmap (subst_raw subst) ro
- and r' = subst_raw subst r
- and ra' = array_smartmap (subst_raw subst) ra in
- if ro' == ro && r' == r && ra' == ra then raw else
- ROrderedCase (loc,b,ro',r',ra',x)
-
- | RLetTuple (loc,nal,(na,po),b,c) ->
- let po' = option_smartmap (subst_raw subst) po
- and b' = subst_raw subst b
- and c' = subst_raw subst c in
- if po' == po && b' == b && c' == c then raw else
- RLetTuple (loc,nal,(na,po'),b',c')
-
- | RIf (loc,c,(na,po),b1,b2) ->
- let po' = option_smartmap (subst_raw subst) po
- and b1' = subst_raw subst b1
- and b2' = subst_raw subst b2
- and c' = subst_raw subst c in
- if c' == c & po' == po && b1' == b1 && b2' == b2 then raw else
- RIf (loc,c',(na,po'),b1',b2')
-
- | RRec (loc,fix,ida,bl,ra1,ra2) ->
- let ra1' = array_smartmap (subst_raw subst) ra1
- and ra2' = array_smartmap (subst_raw subst) ra2 in
- let bl' = array_smartmap
- (list_smartmap (fun (na,obd,ty as dcl) ->
- let ty' = subst_raw subst ty in
- let obd' = option_smartmap (subst_raw subst) obd in
- if ty'==ty & obd'==obd then dcl else (na,obd',ty')))
- bl in
- if ra1' == ra1 && ra2' == ra2 && bl'==bl then raw else
- RRec (loc,fix,ida,bl',ra1',ra2')
-
- | RSort _ -> raw
-
- | RHole (loc,ImplicitArg (ref,i)) ->
- let ref' = subst_global subst ref in
- if ref' == ref then raw else
- RHole (loc,ImplicitArg (ref',i))
- | RHole (loc, (BinderType _ | QuestionMark | CasesType |
- InternalHole | TomatchTypeParameter _)) -> raw
-
- | RCast (loc,r1,r2) ->
- let r1' = subst_raw subst r1 and r2' = subst_raw subst r2 in
- if r1' == r1 && r2' == r2 then raw else
- RCast (loc,r1',r2')
-
- | RDynamic _ -> raw
-
let loc_of_rawconstr = function
| RRef (loc,_) -> loc
| RVar (loc,_) -> loc
@@ -325,15 +199,47 @@ let loc_of_rawconstr = function
| RProd (loc,_,_,_) -> loc
| RLetIn (loc,_,_,_) -> loc
| RCases (loc,_,_,_) -> loc
- | ROrderedCase (loc,_,_,_,_,_) -> loc
| RLetTuple (loc,_,_,_,_) -> loc
| RIf (loc,_,_,_,_) -> loc
| RRec (loc,_,_,_,_,_) -> loc
| RSort (loc,_) -> loc
| RHole (loc,_) -> loc
- | RCast (loc,_,_) -> loc
+ | RCast (loc,_,_,_) -> loc
| RDynamic (loc,_) -> loc
+(**********************************************************************)
+(* Conversion from rawconstr to cases pattern, if possible *)
+
+let rec cases_pattern_of_rawconstr na = function
+ | RVar (loc,id) when na<>Anonymous ->
+ (* Unable to manage the presence of both an alias and a variable *)
+ raise Not_found
+ | RVar (loc,id) -> PatVar (loc,Name id)
+ | RHole (loc,_) -> PatVar (loc,na)
+ | RRef (loc,ConstructRef cstr) ->
+ PatCstr (loc,cstr,[],na)
+ | RApp (loc,RRef (_,ConstructRef cstr),l) ->
+ PatCstr (loc,cstr,List.map (cases_pattern_of_rawconstr Anonymous) l,na)
+ | _ -> raise Not_found
+
+(* Turn a closed cases pattern into a rawconstr *)
+let rec rawconstr_of_closed_cases_pattern_aux = function
+ | PatCstr (loc,cstr,[],Anonymous) ->
+ RRef (loc,ConstructRef cstr)
+ | PatCstr (loc,cstr,l,Anonymous) ->
+ let ref = RRef (loc,ConstructRef cstr) in
+ RApp (loc,ref, List.map rawconstr_of_closed_cases_pattern_aux l)
+ | _ -> raise Not_found
+
+let rawconstr_of_closed_cases_pattern = function
+ | PatCstr (loc,cstr,l,na) ->
+ na,rawconstr_of_closed_cases_pattern_aux (PatCstr (loc,cstr,l,Anonymous))
+ | _ ->
+ raise Not_found
+
+(**********************************************************************)
+(* Reduction expressions *)
+
type 'a raw_red_flag = {
rBeta : bool;
rIota : bool;
@@ -357,6 +263,7 @@ type ('a,'b) red_expr_gen =
| Fold of 'a list
| Pattern of 'a occurrences list
| ExtraRedExpr of string
+ | CbvVm
type ('a,'b) may_eval =
| ConstrTerm of 'a
diff --git a/pretyping/rawterm.mli b/pretyping/rawterm.mli
index 97e11af6..22317b5f 100644
--- a/pretyping/rawterm.mli
+++ b/pretyping/rawterm.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: rawterm.mli,v 1.47.2.5 2005/01/21 16:42:37 herbelin Exp $ i*)
+(*i $Id: rawterm.mli 8624 2006-03-13 17:38:17Z msozeau $ i*)
(*i*)
open Util
@@ -31,8 +31,6 @@ type patvar = identifier
type rawsort = RProp of Term.contents | RType of Univ.universe option
-type fix_kind = RFix of (int array * int) | RCoFix of int
-
type binder_kind = BProd | BLambda | BLetIn
type quantified_hypothesis = AnonHyp of int | NamedHyp of identifier
@@ -46,14 +44,6 @@ type 'a bindings =
type 'a with_bindings = 'a * 'a bindings
-type hole_kind =
- | ImplicitArg of global_reference * (int * identifier option)
- | BinderType of name
- | QuestionMark
- | CasesType
- | InternalHole
- | TomatchTypeParameter of inductive * int
-
type rawconstr =
| RRef of (loc * global_reference)
| RVar of (loc * identifier)
@@ -63,26 +53,27 @@ type rawconstr =
| RLambda of loc * name * rawconstr * rawconstr
| RProd of loc * name * rawconstr * rawconstr
| RLetIn of loc * name * rawconstr * rawconstr
- | RCases of loc * (rawconstr option * rawconstr option ref) *
- (rawconstr * (name * (loc * inductive * name list) option) ref) list *
+ | RCases of loc * rawconstr option *
+ (rawconstr * (name * (loc * inductive * name list) option)) list *
(loc * identifier list * cases_pattern list * rawconstr) list
- | ROrderedCase of loc * case_style * rawconstr option * rawconstr *
- rawconstr array * rawconstr option ref
| RLetTuple of loc * name list * (name * rawconstr option) *
rawconstr * rawconstr
| RIf of loc * rawconstr * (name * rawconstr option) * rawconstr * rawconstr
| RRec of loc * fix_kind * identifier array * rawdecl list array *
rawconstr array * rawconstr array
| RSort of loc * rawsort
- | RHole of (loc * hole_kind)
- | RCast of loc * rawconstr * rawconstr
+ | RHole of (loc * Evd.hole_kind)
+ | RCast of loc * rawconstr * cast_kind * rawconstr
| RDynamic of loc * Dyn.t
and rawdecl = name * rawconstr option * rawconstr
+and fix_recursion_order = RStructRec | RWfRec of rawconstr
+
+and fix_kind = RFix of ((int * fix_recursion_order) array * int) | RCoFix of int
+
val cases_predicate_names :
- (rawconstr * (name * (loc * inductive * name list) option) ref) list ->
- name list
+ (rawconstr * (name * (loc * inductive * name list) option)) list -> name list
(*i - if PRec (_, names, arities, bodies) is in env then arities are
typed in env too and bodies are typed in env enriched by the
@@ -107,7 +98,18 @@ val occur_rawconstr : identifier -> rawconstr -> bool
val loc_of_rawconstr : rawconstr -> loc
-val subst_raw : Names.substitution -> rawconstr -> rawconstr
+(**********************************************************************)
+(* Conversion from rawconstr to cases pattern, if possible *)
+
+(* Take the current alias as parameter, raise Not_found if *)
+(* translation is impossible *)
+
+val cases_pattern_of_rawconstr : name -> rawconstr -> cases_pattern
+
+val rawconstr_of_closed_cases_pattern : cases_pattern -> name * rawconstr
+
+(**********************************************************************)
+(* Reduction expressions *)
type 'a raw_red_flag = {
rBeta : bool;
@@ -131,6 +133,7 @@ type ('a,'b) red_expr_gen =
| Fold of 'a list
| Pattern of 'a occurrences list
| ExtraRedExpr of string
+ | CbvVm
type ('a,'b) may_eval =
| ConstrTerm of 'a
diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml
index 3e73cfee..87997d99 100755..100644
--- a/pretyping/recordops.ml
+++ b/pretyping/recordops.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: recordops.ml,v 1.26.2.2 2005/11/29 21:40:52 letouzey Exp $ *)
+(* $Id: recordops.ml 8642 2006-03-17 10:09:02Z notin $ *)
open Util
open Pp
@@ -19,133 +19,199 @@ open Typeops
open Libobject
open Library
open Classops
+open Mod_subst
-(*s Une structure S est un type inductif non récursif à un seul
- constructeur (de nom par défaut Build_S) *)
+(*s A structure S is a non recursive inductive type with a single
+ constructor (the name of which defaults to Build_S) *)
(* Table des structures: le nom de la structure (un [inductive]) donne
le nom du constructeur, le nombre de paramètres et pour chaque
- argument réels du constructeur, le noms de la projection
- correspondante, si valide *)
+ argument réel du constructeur, le nom de la projection
+ correspondante, si valide, et un booléen disant si c'est une vraie
+ projection ou bien une fonction constante (associée à un LetIn) *)
type struc_typ = {
s_CONST : identifier;
s_PARAM : int;
+ s_PROJKIND : bool list;
s_PROJ : constant option list }
let structure_table = ref (Indmap.empty : struc_typ Indmap.t)
-let projection_table = ref KNmap.empty
+let projection_table = ref Cmap.empty
let option_fold_right f p e = match p with Some a -> f a e | None -> e
-let cache_structure (_,(ind,struc)) =
+let load_structure i (_,(ind,id,kl,projs)) =
+ let n = (fst (Global.lookup_inductive ind)).Declarations.mind_nparams in
+ let struc =
+ { s_CONST = id; s_PARAM = n; s_PROJ = projs; s_PROJKIND = kl } in
structure_table := Indmap.add ind struc !structure_table;
projection_table :=
- List.fold_right (option_fold_right (fun proj -> KNmap.add proj struc))
- struc.s_PROJ !projection_table
+ List.fold_right (option_fold_right (fun proj -> Cmap.add proj struc))
+ projs !projection_table
-let subst_structure (_,subst,((kn,i),struc as obj)) =
+let cache_structure o =
+ load_structure 1 o
+
+let subst_structure (_,subst,((kn,i),id,kl,projs as obj)) =
let kn' = subst_kn subst kn in
- let proj' = list_smartmap
- (option_smartmap (subst_kn subst))
- struc.s_PROJ
+ let projs' =
+ (* invariant: struc.s_PROJ is an evaluable reference. Thus we can take *)
+ (* the first component of subst_con. *)
+ list_smartmap
+ (option_smartmap (fun kn -> fst (subst_con subst kn)))
+ projs
in
- if proj' == struc.s_PROJ && kn' == kn then obj else
- (kn',i),{struc with s_PROJ = proj'}
+ if projs' == projs && kn' == kn then obj else
+ ((kn',i),id,kl,projs')
+
+let discharge_structure (_,(ind,id,kl,projs)) =
+ Some (Lib.discharge_inductive ind, id, kl,
+ List.map (option_app Lib.discharge_con) projs)
let (inStruc,outStruc) =
declare_object {(default_object "STRUCTURE") with
- cache_function = cache_structure;
- load_function = (fun _ o -> cache_structure o);
- subst_function = subst_structure;
- classify_function = (fun (_,x) -> Substitute x);
- export_function = (function x -> Some x) }
+ cache_function = cache_structure;
+ load_function = load_structure;
+ subst_function = subst_structure;
+ classify_function = (fun (_,x) -> Substitute x);
+ discharge_function = discharge_structure;
+ export_function = (function x -> Some x) }
-let add_new_struc (s,c,n,l) =
- Lib.add_anonymous_leaf (inStruc (s,{s_CONST=c;s_PARAM=n;s_PROJ=l}))
+let declare_structure (s,c,_,kl,pl) =
+ Lib.add_anonymous_leaf (inStruc (s,c,kl,pl))
-let find_structure indsp = Indmap.find indsp !structure_table
+let lookup_structure indsp = Indmap.find indsp !structure_table
let find_projection_nparams = function
- | ConstRef cst -> (KNmap.find cst !projection_table).s_PARAM
+ | ConstRef cst -> (Cmap.find cst !projection_table).s_PARAM
| _ -> raise Not_found
-(*s Un "object" est une fonction construisant une instance d'une structure *)
+
+(************************************************************************)
+(*s A canonical structure declares "canonical" conversion hints between *)
+(* the effective components of a structure and the projections of the *)
+(* structure *)
(* Table des definitions "object" : pour chaque object c,
c := [x1:B1]...[xk:Bk](Build_R a1...am t1...t_n)
- avec ti = (ci ui1...uir)
+ If ti has the form (ci ui1...uir) where ci is a global reference and
+if the corresponding projection Li of the structure R is defined, one
+declare a "conversion" between ci and Li
+
+ x1:B1..xk:Bk |- (Li a1..am (c x1..xk)) =_conv (ci ui1...uir)
- Pour tout ci, et Li, la ième projection de la structure R (si
- définie), on déclare une "coercion"
+that maps the pair (Li,ci) to the following data
o_DEF = c
o_TABS = B1...Bk
o_PARAMS = a1...am
o_TCOMP = ui1...uir
+
*)
type obj_typ = {
o_DEF : constr;
- o_TABS : constr list; (* dans l'ordre *)
- o_TPARAMS : constr list; (* dans l'ordre *)
- o_TCOMPS : constr list } (* dans l'ordre *)
-
-let subst_obj subst obj =
- let o_DEF' = subst_mps subst obj.o_DEF in
- let o_TABS' = list_smartmap (subst_mps subst) obj.o_TABS in
- let o_TPARAMS' = list_smartmap (subst_mps subst) obj.o_TPARAMS in
- let o_TCOMPS' = list_smartmap (subst_mps subst) obj.o_TCOMPS in
- if o_DEF' == obj.o_DEF
- && o_TABS' == obj.o_TABS
- && o_TPARAMS' == obj.o_TPARAMS
- && o_TCOMPS' == obj.o_TCOMPS
- then
- obj
- else
- { o_DEF = o_DEF' ;
- o_TABS = o_TABS' ;
- o_TPARAMS = o_TPARAMS' ;
- o_TCOMPS = o_TCOMPS' }
+ o_TABS : constr list; (* ordered *)
+ o_TPARAMS : constr list; (* ordered *)
+ o_TCOMPS : constr list } (* ordered *)
let object_table =
(ref [] : ((global_reference * global_reference) * obj_typ) list ref)
-let cache_object (_,x) = object_table := x :: (!object_table)
-
-let subst_object (_,subst,((r1,r2),o as obj)) =
- let r1' = subst_global subst r1 in
- let r2' = subst_global subst r2 in
- let o' = subst_obj subst o in
- if r1' == r1 && r2' == r2 && o' == o then obj else
- (r1',r2'),o'
-
-let (inObjDef,outObjDef) =
- declare_object {(default_object "OBJDEF") with
- open_function = (fun i o -> if i=1 then cache_object o);
- cache_function = cache_object;
- subst_function = subst_object;
- classify_function = (fun (_,x) -> Substitute x);
- export_function = (function x -> Some x) }
-
-let add_new_objdef (o,c,la,lp,l) =
- try
- let _ = List.assoc o !object_table in ()
- with Not_found ->
- Lib.add_anonymous_leaf
- (inObjDef (o,{o_DEF=c;o_TABS=la;o_TPARAMS=lp;o_TCOMPS=l}))
-
-let cache_objdef1 (_,sp) = ()
-
-let (inObjDef1,outObjDef1) =
- declare_object {(default_object "OBJDEF1") with
- open_function = (fun i o -> if i=1 then cache_objdef1 o);
- cache_function = cache_objdef1;
- export_function = (function x -> Some x) }
-
-let objdef_info o = List.assoc o !object_table
+let canonical_projections () = !object_table
+
+let keep_true_projections projs kinds =
+ map_succeed (function (p,true) -> p | _ -> failwith "")
+ (List.combine projs kinds)
+
+(* Intended to always success *)
+let compute_canonical_projections (con,ind) =
+ let v = mkConst con in
+ let c = Environ.constant_value (Global.env()) con in
+ let lt,t = Reductionops.splay_lambda (Global.env()) Evd.empty c in
+ let lt = List.rev (List.map snd lt) in
+ let args = snd (decompose_app t) in
+ let { s_PARAM = p; s_PROJ = lpj; s_PROJKIND = kl } = lookup_structure ind in
+ let params, projs = list_chop p args in
+ let lpj = keep_true_projections lpj kl in
+ let lps = List.combine lpj projs in
+ let comp =
+ List.fold_left
+ (fun l (spopt,t) -> (* comp=components *)
+ match spopt with
+ | Some proji_sp ->
+ let c, args = decompose_app t in
+ (try (ConstRef proji_sp, global_of_constr c, args) :: l
+ with Not_found -> l)
+ | _ -> l)
+ [] lps in
+ List.map (fun (refi,c,argj) ->
+ (refi,c),{o_DEF=v; o_TABS=lt; o_TPARAMS=params; o_TCOMPS=argj})
+ comp
+
+let open_canonical_structure i (_,o) =
+ if i=1 then
+ let lo = compute_canonical_projections o in
+ List.iter (fun (o,_ as x) ->
+ if not (List.mem_assoc o !object_table) then
+ object_table := x :: (!object_table)) lo
+
+let cache_canonical_structure o =
+ open_canonical_structure 1 o
+
+let subst_canonical_structure (_,subst,(cst,ind as obj)) =
+ (* invariant: cst is an evaluable reference. Thus we can take *)
+ (* the first component of subst_con. *)
+ let cst' = fst (subst_con subst cst) in
+ let ind' = Inductiveops.subst_inductive subst ind in
+ if cst' == cst & ind' == ind then obj else (cst',ind')
+
+let discharge_canonical_structure (_,(cst,ind)) =
+ Some (Lib.discharge_con cst,Lib.discharge_inductive ind)
+
+let (inCanonStruc,outCanonStruct) =
+ declare_object {(default_object "CANONICAL-STRUCTURE") with
+ open_function = open_canonical_structure;
+ cache_function = cache_canonical_structure;
+ subst_function = subst_canonical_structure;
+ classify_function = (fun (_,x) -> Substitute x);
+ discharge_function = discharge_canonical_structure;
+ export_function = (function x -> Some x) }
+
+let add_canonical_structure x = Lib.add_anonymous_leaf (inCanonStruc x)
+
+(*s High-level declaration of a canonical structure *)
+
+let error_not_structure ref =
+ errorlabstrm "object_declare"
+ (Nameops.pr_id (id_of_global ref) ++ str" is not a structure object")
+
+let check_and_decompose_canonical_structure ref =
+ let sp = match ref with ConstRef sp -> sp | _ -> error_not_structure ref in
+ let env = Global.env () in
+ let vc = match Environ.constant_opt_value env sp with
+ | Some vc -> vc
+ | None -> error_not_structure ref in
+ let f,args = match kind_of_term (snd (decompose_lam vc)) with
+ | App (f,args) -> f,args
+ | _ -> error_not_structure ref in
+ let indsp = match kind_of_term f with
+ | Construct (indsp,1) -> indsp
+ | _ -> error_not_structure ref in
+ let s = try lookup_structure indsp with Not_found -> error_not_structure ref in
+ if s.s_PARAM + List.length s.s_PROJ > Array.length args then
+ error_not_structure ref;
+ (sp,indsp)
+
+let declare_canonical_structure ref =
+ add_canonical_structure (check_and_decompose_canonical_structure ref)
+
+let outCanonicalStructure x = fst (outCanonStruct x)
+
+let lookup_canonical_conversion o = List.assoc o !object_table
let freeze () =
!structure_table, !projection_table, !object_table
@@ -154,7 +220,7 @@ let unfreeze (s,p,o) =
structure_table := s; projection_table := p; object_table := o
let init () =
- structure_table := Indmap.empty; projection_table := KNmap.empty;
+ structure_table := Indmap.empty; projection_table := Cmap.empty;
object_table:=[]
let _ = init()
diff --git a/pretyping/recordops.mli b/pretyping/recordops.mli
index a458b7b3..1e061dc6 100755
--- a/pretyping/recordops.mli
+++ b/pretyping/recordops.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: recordops.mli,v 1.15.2.2 2005/11/29 21:40:52 letouzey Exp $ i*)
+(*i $Id: recordops.mli 6748 2005-02-18 22:17:50Z herbelin $ i*)
(*i*)
open Names
@@ -18,34 +18,36 @@ open Libobject
open Library
(*i*)
+(*s A structure S is a non recursive inductive type with a single
+ constructor (the name of which defaults to Build_S) *)
+
type struc_typ = {
s_CONST : identifier;
s_PARAM : int;
+ s_PROJKIND : bool list;
s_PROJ : constant option list }
-val add_new_struc :
- inductive * identifier * int * constant option list -> unit
+val declare_structure :
+ inductive * identifier * int * bool list * constant option list -> unit
-(* [find_structure isp] returns the infos associated to inductive path
+(* [lookup_structure isp] returns the infos associated to inductive path
[isp] if it corresponds to a structure, otherwise fails with [Not_found] *)
-val find_structure : inductive -> struc_typ
+val lookup_structure : inductive -> struc_typ
(* raise [Not_found] if not a projection *)
val find_projection_nparams : global_reference -> int
+(*s A canonical structure declares "canonical" conversion hints between *)
+(* the effective components of a structure and the projections of the *)
+(* structure *)
+
type obj_typ = {
o_DEF : constr;
- o_TABS : constr list; (* dans l'ordre *)
- o_TPARAMS : constr list; (* dans l'ordre *)
- o_TCOMPS : constr list } (* dans l'ordre *)
+ o_TABS : constr list; (* ordered *)
+ o_TPARAMS : constr list; (* ordered *)
+ o_TCOMPS : constr list } (* ordered *)
-val objdef_info : (global_reference * global_reference) -> obj_typ
-val add_new_objdef :
- (global_reference * global_reference) * Term.constr * Term.constr list *
- Term.constr list * Term.constr list -> unit
-
-
-val inStruc : inductive * struc_typ -> obj
-val outStruc : obj -> inductive * struc_typ
-val inObjDef1 : kernel_name -> obj
-val outObjDef1 : obj -> kernel_name
+val lookup_canonical_conversion : (global_reference * global_reference) -> obj_typ
+val declare_canonical_structure : global_reference -> unit
+val canonical_projections : unit ->
+ ((global_reference * global_reference) * obj_typ) list
diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml
index a030dcf2..b590f743 100644
--- a/pretyping/reductionops.ml
+++ b/pretyping/reductionops.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: reductionops.ml,v 1.6.2.2 2004/07/16 19:30:46 herbelin Exp $ *)
+(* $Id: reductionops.ml 8708 2006-04-14 08:13:02Z jforest $ *)
open Pp
open Util
@@ -17,7 +17,6 @@ open Univ
open Evd
open Declarations
open Environ
-open Instantiate
open Closure
open Esubst
open Reduction
@@ -48,7 +47,7 @@ type local_state_reduction_function = state -> state
let rec whd_state (x, stack as s) =
match kind_of_term x with
| App (f,cl) -> whd_state (f, append_stack cl stack)
- | Cast (c,_) -> whd_state (c, stack)
+ | Cast (c,_,_) -> whd_state (c, stack)
| _ -> s
let appterm_of_stack (f,s) = (f,list_of_stack s)
@@ -189,7 +188,7 @@ let contract_cofix (bodynum,(types,names,bodies as typedbodies)) =
let reduce_mind_case mia =
match kind_of_term mia.mconstr with
- | Construct (ind_sp,i as cstr_sp) ->
+ | Construct (ind_sp,i) ->
(* let ncargs = (fst mia.mci).(i-1) in*)
let real_cargs = list_skipn mia.mci.ci_npar mia.mcargs in
applist (mia.mlf.(i-1),real_cargs)
@@ -255,7 +254,7 @@ let rec whd_state_gen flags env sigma =
| Some body -> whrec (body, stack)
| None -> s)
| LetIn (_,b,_,c) when red_zeta flags -> stacklam whrec [b] c stack
- | Cast (c,_) -> whrec (c, stack)
+ | Cast (c,_,_) -> whrec (c, stack)
| App (f,cl) -> whrec (f, append_stack cl stack)
| Lambda (na,t,c) ->
(match decomp_stack stack with
@@ -300,7 +299,7 @@ let local_whd_state_gen flags =
let rec whrec (x, stack as s) =
match kind_of_term x with
| LetIn (_,b,_,c) when red_zeta flags -> stacklam whrec [b] c stack
- | Cast (c,_) -> whrec (c, stack)
+ | Cast (c,_,_) -> whrec (c, stack)
| App (f,cl) -> whrec (f, append_stack cl stack)
| Lambda (_,_,c) ->
(match decomp_stack stack with
@@ -339,6 +338,7 @@ let local_whd_state_gen flags =
in
whrec
+
(* 1. Beta Reduction Functions *)
let whd_beta_state = local_whd_state_gen beta
@@ -427,12 +427,14 @@ let whd_betadeltaiota_nolet env sigma x =
(* Replacing defined evars for error messages *)
let rec whd_evar sigma c =
match kind_of_term c with
- | Evar (ev,args) when Evd.in_dom sigma ev & Evd.is_defined sigma ev ->
- whd_evar sigma (Instantiate.existential_value sigma (ev,args))
+ | Evar (ev,args)
+ when Evd.in_dom sigma ev & Evd.is_defined sigma ev ->
+ whd_evar sigma (Evd.existential_value sigma (ev,args))
+ | Sort s when is_sort_variable sigma s -> whd_sort_variable sigma c
| _ -> collapse_appl c
-let nf_evar sigma =
- local_strong (whd_evar sigma)
+let nf_evar evd =
+ local_strong (whd_evar evd)
(* lazy reduction functions. The infos must be created for each term *)
let clos_norm_flags flgs env sigma t =
@@ -443,6 +445,120 @@ let nf_betaiota = clos_norm_flags Closure.betaiota empty_env Evd.empty
let nf_betadeltaiota env sigma =
clos_norm_flags Closure.betadeltaiota env sigma
+
+(* Attention reduire un beta-redexe avec un argument qui n'est pas
+ une variable, peut changer enormement le temps de conversion lors
+ du type checking :
+ (fun x => x + x) M
+*)
+let nf_betaiotaevar_preserving_vm_cast env sigma t =
+ let push decl (env,subst) =
+ (Environ.push_rel decl env, Esubst.subs_lift subst) in
+ let cons decl v (env, subst) = (push_rel decl env, Esubst.subs_cons (v,subst)) in
+
+ let app_stack t (f, stack) =
+ let t' = app_stack (f,stack) in
+ match kind_of_term t, kind_of_term t' with
+ | App(f,args), App(f',args') when f == f' && array_for_all2 (==) args args' -> t
+ | _ -> t'
+ in
+ let rec whrec (env, subst as es) (t, stack as s) =
+ match kind_of_term t with
+ | Rel i ->
+ let t' =
+ match Esubst.expand_rel i subst with
+ | Inl (k,e) -> lift k e
+ | Inr (k,None) -> mkRel k
+ | Inr (k, Some p) -> lift (k-p) (mkRel p) (*??????? == mkRel k ! Julien *)
+ (* Est correct ??? *)
+ in
+ if t = t' then s else t', stack
+ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _ -> s
+ | Evar (e,al) ->
+ let al' = Array.map (norm es) al in
+ begin match existential_opt_value sigma (e,al') with
+ | Some body -> whrec (env,Esubst.ESID 0) (body, stack) (**** ????? ****)
+ | None ->
+ if array_for_all2 (==) al al' then s else (mkEvar (e, al'), stack)
+ end
+ | Cast (c,VMcast,t) ->
+ let c' = norm es c in
+ let t' = norm es t in
+ if c == c' && t == t' then s
+ else (mkCast(c',VMcast,t'),stack)
+ | Cast (c,DEFAULTcast,_) ->
+ whrec es (c, stack)
+
+ | Prod (na,t,c) ->
+ let t' = norm es t in
+ let c' = norm (push (na, None, t') es) c in
+ if t==t' && c==c' then s else (mkProd (na, t', c'), stack)
+
+ | Lambda (na,t,c) ->
+ begin match decomp_stack stack with
+ | Some (a,m) ->
+ begin match kind_of_term a with
+ | Rel i when not (evaluable_rel i env) ->
+ whrec (cons (na,None,t) a es) (c, m)
+ | Var id when not (evaluable_named id env)->
+ whrec (cons (na,None,t) a es) (c, m)
+ | _ ->
+ let t' = norm es t in
+ let c' = norm (push (na, None, t') es) c in
+ if t == t' && c == c' then s
+ else mkLambda (na, t', c'), stack
+ end
+ | _ ->
+ let t' = norm es t in
+ let c' = norm (push (na, None, t') es) c in
+ if t == t' && c == c' then s
+ else mkLambda(na,t',c'),stack
+
+ end
+ | LetIn (na,b,t,c) ->
+ let b' = norm es b in
+ let t' = norm es t in
+ let c' = norm (push (na, Some b', t') es) c in
+ if b==b' && t==t' && c==c' then s
+ else mkLetIn (na, b', t', c'), stack
+
+ | App (f,cl) ->
+ let cl' = Array.map (norm es) cl in
+ whrec es (f, append_stack cl' stack)
+
+ | Case (ci,p,d,lf) ->
+ let (c,cargs) = whrec es (d, empty_stack) in
+ if reducible_mind_case c then
+ whrec es (reduce_mind_case
+ {mP=p; mconstr=c; mcargs=list_of_stack cargs;
+ mci=ci; mlf=lf}, stack)
+ else
+ let p' = norm es p in
+ let d' = app_stack d (c,cargs) in
+ let lf' = Array.map (norm es) lf in
+ if p==p' && d==d' && array_for_all2 (==) lf lf' then s
+ else (mkCase (ci, p', d', lf'), stack)
+ | Fix (ln,(lna,tl,bl)) ->
+ let tl' = Array.map (norm es) tl in
+ let es' =
+ array_fold_left2 (fun es na t -> push (na,None,t) es) es lna tl' in
+ let bl' = Array.map (norm es') bl in
+ if array_for_all2 (==) tl tl' && array_for_all2 (==) bl bl'
+ then s
+ else (mkFix (ln,(lna,tl',bl')), stack)
+ | CoFix(ln,(lna,tl,bl)) ->
+ let tl' = Array.map (norm es) tl in
+ let es' =
+ array_fold_left2 (fun es na t -> push (na,None,t) es) es lna tl in
+ let bl' = Array.map (norm es') bl in
+ if array_for_all2 (==) tl tl' && array_for_all2 (==) bl bl'
+ then s
+ else (mkCoFix (ln,(lna,tl',bl')), stack)
+
+ and norm es t = app_stack t (whrec es (t,empty_stack)) in
+ norm (env, Esubst.ESID 0) t
+
+
(* lazy weak head reduction functions *)
let whd_flags flgs env sigma t =
whd_val (create_clos_infos flgs env) (inject (nf_evar sigma t))
@@ -462,10 +578,6 @@ let fhnf_apply info k h a = Profile.profile4 fakey fhnf_apply info k h a;;
type conversion_test = constraints -> constraints
-type conv_pb =
- | CONV
- | CUMUL
-
let pb_is_equal pb = pb = CONV
let pb_equal = function
@@ -515,22 +627,22 @@ let plain_instance s c =
let rec irec u = match kind_of_term u with
| Meta p -> (try List.assoc p s with Not_found -> u)
| App (f,l) when isCast f ->
- let (f,t) = destCast f in
+ let (f,_,t) = destCast f in
let l' = Array.map irec l in
(match kind_of_term f with
- | Meta p ->
- (* Don't flatten application nodes: this is used to extract a
- proof-term from a proof-tree and we want to keep the structure
- of the proof-tree *)
- (try let g = List.assoc p s in
- match kind_of_term g with
- | App _ ->
- let h = id_of_string "H" in
- mkLetIn (Name h,g,t,mkApp(mkRel 1,Array.map (lift 1) l'))
- | _ -> mkApp (g,l')
- with Not_found -> mkApp (f,l'))
- | _ -> mkApp (irec f,l'))
- | Cast (m,_) when isMeta m ->
+ | Meta p ->
+ (* Don't flatten application nodes: this is used to extract a
+ proof-term from a proof-tree and we want to keep the structure
+ of the proof-tree *)
+ (try let g = List.assoc p s in
+ match kind_of_term g with
+ | App _ ->
+ let h = id_of_string "H" in
+ mkLetIn (Name h,g,t,mkApp(mkRel 1,Array.map (lift 1) l'))
+ | _ -> mkApp (g,l')
+ with Not_found -> mkApp (f,l'))
+ | _ -> mkApp (irec f,l'))
+ | Cast (m,_,_) when isMeta m ->
(try List.assoc (destMeta m) s with Not_found -> u)
| _ -> map_constr irec u
in
@@ -580,17 +692,28 @@ let splay_prod env sigma =
in
decrec env []
+let splay_lambda env sigma =
+ let rec decrec env m c =
+ let t = whd_betadeltaiota env sigma c in
+ match kind_of_term t with
+ | Lambda (n,a,c0) ->
+ decrec (push_rel (n,None,a) env)
+ ((n,a)::m) c0
+ | _ -> m,t
+ in
+ decrec env []
+
let splay_prod_assum env sigma =
let rec prodec_rec env l c =
let t = whd_betadeltaiota_nolet env sigma c in
- match kind_of_term c with
+ match kind_of_term t with
| Prod (x,t,c) ->
prodec_rec (push_rel (x,None,t) env)
(Sign.add_rel_decl (x, None, t) l) c
| LetIn (x,b,t,c) ->
prodec_rec (push_rel (x, Some b, t) env)
(Sign.add_rel_decl (x, Some b, t) l) c
- | Cast (c,_) -> prodec_rec env l c
+ | Cast (c,_,_) -> prodec_rec env l c
| _ -> l,t
in
prodec_rec env Sign.empty_rel_context
@@ -613,6 +736,13 @@ let decomp_n_prod env sigma n =
in
decrec env n Sign.empty_rel_context
+exception NotASort
+
+let decomp_sort env sigma t =
+ match kind_of_term (whd_betadeltaiota env sigma t) with
+ | Sort s -> s
+ | _ -> raise NotASort
+
(* One step of approximation *)
let rec apprec env sigma s =
@@ -715,3 +845,27 @@ let is_info_type env sigma t =
(s = Prop Pos) ||
(s <> Prop Null &&
try info_arity env sigma t.utj_val with IsType -> true)
+
+(*************************************)
+(* Metas *)
+
+let meta_value evd mv =
+ let rec valrec mv =
+ try
+ let b = meta_fvalue evd mv in
+ instance
+ (List.map (fun mv' -> (mv',valrec mv')) (Metaset.elements b.freemetas))
+ b.rebus
+ with Anomaly _ | Not_found ->
+ mkMeta mv
+ in
+ valrec mv
+
+let meta_instance env b =
+ let c_sigma =
+ List.map
+ (fun mv -> (mv,meta_value env mv)) (Metaset.elements b.freemetas)
+ in
+ instance c_sigma b.rebus
+
+let nf_meta env c = meta_instance env (mk_freelisted c)
diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli
index 65cdd5cd..ff55cc0e 100644
--- a/pretyping/reductionops.mli
+++ b/pretyping/reductionops.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: reductionops.mli,v 1.8.2.2 2004/07/16 19:30:46 herbelin Exp $ i*)
+(*i $Id: reductionops.mli 8708 2006-04-14 08:13:02Z jforest $ i*)
(*i*)
open Names
@@ -63,6 +63,7 @@ val nf_betaiota : local_reduction_function
val nf_betadeltaiota : reduction_function
val nf_evar : evar_map -> constr -> constr
+val nf_betaiotaevar_preserving_vm_cast : reduction_function
(* Lazy strategy, weak head reduction *)
val whd_evar : evar_map -> constr -> constr
val whd_beta : local_reduction_function
@@ -111,6 +112,10 @@ val whd_betadeltaiotaeta_stack : stack_reduction_function
val whd_betadeltaiotaeta_state : state_reduction_function
val whd_betadeltaiotaeta : reduction_function
+
+
+
+
val beta_applist : constr * constr list -> constr
val hnf_prod_app : env -> evar_map -> constr -> constr -> constr
@@ -121,12 +126,14 @@ val hnf_lam_appvect : env -> evar_map -> constr -> constr array -> constr
val hnf_lam_applist : env -> evar_map -> constr -> constr list -> constr
val splay_prod : env -> evar_map -> constr -> (name * constr) list * constr
+val splay_lambda : env -> evar_map -> constr -> (name * constr) list * constr
val splay_arity : env -> evar_map -> constr -> (name * constr) list * sorts
val sort_of_arity : env -> constr -> sorts
val decomp_n_prod :
env -> evar_map -> int -> constr -> Sign.rel_context * constr
val splay_prod_assum :
env -> evar_map -> constr -> Sign.rel_context * constr
+val decomp_sort : env -> evar_map -> types -> sorts
type 'a miota_args = {
mP : constr; (* the result type *)
@@ -162,10 +169,6 @@ val reduce_fix : local_state_reduction_function -> fixpoint
type conversion_test = constraints -> constraints
-type conv_pb =
- | CONV
- | CUMUL
-
val pb_is_equal : conv_pb -> bool
val pb_equal : conv_pb -> conv_pb
@@ -188,3 +191,7 @@ val instance : (metavariable * constr) list -> constr -> constr
val hnf : env -> 'a evar_map -> constr -> constr * constr list
i*)
val apprec : state_reduction_function
+
+(*s Meta-related reduction functions *)
+val meta_instance : evar_defs -> constr freelisted -> constr
+val nf_meta : evar_defs -> constr -> constr
diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml
index 061382f7..32da4cea 100644
--- a/pretyping/retyping.ml
+++ b/pretyping/retyping.ml
@@ -6,22 +6,17 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: retyping.ml,v 1.43.2.1 2004/07/16 19:30:46 herbelin Exp $ *)
+(* $Id: retyping.ml 8673 2006-03-29 21:21:52Z herbelin $ *)
open Util
open Term
open Inductive
+open Inductiveops
open Names
open Reductionops
open Environ
open Typeops
open Declarations
-open Instantiate
-
-let outsort env sigma t =
- match kind_of_term (whd_betadeltaiota env sigma t) with
- | Sort s -> s
- | _ -> anomaly "Retyping: found a type of type which is not a sort"
let rec subst_type env sigma typ = function
| [] -> typ
@@ -38,9 +33,9 @@ let rec subst_type env sigma typ = function
let sort_of_atomic_type env sigma ft args =
let rec concl_of_arity env ar =
match kind_of_term (whd_betadeltaiota env sigma ar) with
- | Prod (na, t, b) -> concl_of_arity (push_rel (na,None,t) env) b
- | Sort s -> s
- | _ -> outsort env sigma (subst_type env sigma ft (Array.to_list args))
+ | Prod (na, t, b) -> concl_of_arity (push_rel (na,None,t) env) b
+ | Sort s -> s
+ | _ -> decomp_sort env sigma (subst_type env sigma ft (Array.to_list args))
in concl_of_arity env ft
let typeur sigma metamap =
@@ -61,7 +56,7 @@ let typeur sigma metamap =
| Const c ->
let cb = lookup_constant c env in
body_of_type cb.const_type
- | Evar ev -> existential_type sigma ev
+ | Evar ev -> Evd.existential_type sigma ev
| Ind ind -> body_of_type (type_of_inductive env ind)
| Construct cstr -> body_of_type (type_of_constructor env cstr)
| Case (_,p,c,lf) ->
@@ -78,15 +73,18 @@ let typeur sigma metamap =
subst1 b (type_of (push_rel (name,Some b,c1) env) c2)
| Fix ((_,i),(_,tys,_)) -> tys.(i)
| CoFix (i,(_,tys,_)) -> tys.(i)
- | App(f,args)->
+ | App(f,args) when isInd f ->
+ let t = type_of_applied_inductive env (destInd f) args in
+ strip_outer_cast (subst_type env sigma t (Array.to_list args))
+ | App(f,args) ->
strip_outer_cast
(subst_type env sigma (type_of env f) (Array.to_list args))
- | Cast (c,t) -> t
+ | Cast (c,_, t) -> t
| Sort _ | Prod _ -> mkSort (sort_of env cstr)
and sort_of env t =
match kind_of_term t with
- | Cast (c,s) when isSort s -> destSort s
+ | Cast (c,_, s) when isSort s -> destSort s
| Sort (Prop c) -> type_0
| Sort (Type u) -> Type (Univ.super u)
| Prod (name,t,c2) ->
@@ -95,16 +93,21 @@ let typeur sigma metamap =
| Prop _, (Prop Pos as s) -> s
| Type _, (Prop Pos as s) when
Environ.engagement env = Some ImpredicativeSet -> s
- | Type _ as s, Prop Pos -> s
- | _, (Type u2 as s) -> s (*Type Univ.dummy_univ*))
+ | Type u1, Prop Pos -> Type (Univ.sup u1 Univ.base_univ)
+ | Prop Pos, (Type u2) -> Type (Univ.sup Univ.base_univ u2)
+ | Prop Null, (Type _ as s) -> s
+ | Type u1, Type u2 -> Type (Univ.sup u1 u2))
+ | App(f,args) when isInd f ->
+ let t = type_of_applied_inductive env (destInd f) args in
+ sort_of_atomic_type env sigma t args
| App(f,args) -> sort_of_atomic_type env sigma (type_of env f) args
| Lambda _ | Fix _ | Construct _ ->
anomaly "sort_of: Not a type (1)"
- | _ -> outsort env sigma (type_of env t)
+ | _ -> decomp_sort env sigma (type_of env t)
and sort_family_of env t =
match kind_of_term t with
- | Cast (c,s) when isSort s -> family_of_sort (destSort s)
+ | Cast (c,_, s) when isSort s -> family_of_sort (destSort s)
| Sort (Prop c) -> InType
| Sort (Type u) -> InType
| Prod (name,t,c2) -> sort_family_of (push_rel (name,None,t) env) c2
@@ -112,16 +115,31 @@ let typeur sigma metamap =
family_of_sort (sort_of_atomic_type env sigma (type_of env f) args)
| Lambda _ | Fix _ | Construct _ ->
anomaly "sort_of: Not a type (1)"
- | _ -> family_of_sort (outsort env sigma (type_of env t))
+ | _ -> family_of_sort (decomp_sort env sigma (type_of env t))
+
+ and type_of_applied_inductive env ind args =
+ let specif = lookup_mind_specif env ind in
+ let t = Inductive.type_of_inductive specif in
+ if is_small_inductive specif then
+ (* No polymorphism *)
+ t
+ else
+ (* Retyping constructor with the actual arguments *)
+ let env',llc,ls0 = constructor_instances env specif ind args in
+ let lls = Array.map (Array.map (sort_of env')) llc in
+ let ls = Array.map max_inductive_sort lls in
+ set_inductive_level env (find_inductive_level env specif ind ls0 ls) t
- in type_of, sort_of, sort_family_of
+ in type_of, sort_of, sort_family_of, type_of_applied_inductive
-let get_type_of env sigma c = let f,_,_ = typeur sigma [] in f env c
-let get_sort_of env sigma t = let _,f,_ = typeur sigma [] in f env t
-let get_sort_family_of env sigma c = let _,_,f = typeur sigma [] in f env c
+let get_type_of env sigma c = let f,_,_,_ = typeur sigma [] in f env c
+let get_sort_of env sigma t = let _,f,_,_ = typeur sigma [] in f env t
+let get_sort_family_of env sigma c = let _,_,f,_ = typeur sigma [] in f env c
+let type_of_applied_inductive env sigma ind args =
+ let _,_,_,f = typeur sigma [] in f env ind args
let get_type_of_with_meta env sigma metamap =
- let f,_,_ = typeur sigma metamap in f env
+ let f,_,_,_ = typeur sigma metamap in f env
(* Makes an assumption from a constr *)
let get_assumption_of env evc c = c
diff --git a/pretyping/retyping.mli b/pretyping/retyping.mli
index f29ac8d8..7adec66b 100644
--- a/pretyping/retyping.mli
+++ b/pretyping/retyping.mli
@@ -6,15 +6,13 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: retyping.mli,v 1.16.2.1 2004/07/16 19:30:46 herbelin Exp $ i*)
+(*i $Id: retyping.mli 8673 2006-03-29 21:21:52Z herbelin $ i*)
(*i*)
open Names
open Term
open Evd
open Environ
-open Pattern
-open Termops
(*i*)
(* This family of functions assumes its constr argument is known to be
@@ -23,14 +21,18 @@ open Termops
either produces a wrong result or raise an anomaly. Use with care.
It doesn't handle predicative universes too. *)
-val get_type_of : env -> evar_map -> constr -> constr
+val get_type_of : env -> evar_map -> constr -> types
val get_sort_of : env -> evar_map -> types -> sorts
val get_sort_family_of : env -> evar_map -> types -> sorts_family
-val get_type_of_with_meta : env -> evar_map -> metamap -> constr -> constr
+val get_type_of_with_meta :
+ env -> evar_map -> Termops.metamap -> constr -> types
(* Makes an assumption from a constr *)
val get_assumption_of : env -> evar_map -> constr -> types
(* Makes an unsafe judgment from a constr *)
val get_judgment_of : env -> evar_map -> constr -> unsafe_judgment
+
+val type_of_applied_inductive : env -> evar_map -> inductive ->
+ constr array -> types
diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml
index e8bde1f3..88af6290 100644
--- a/pretyping/tacred.ml
+++ b/pretyping/tacred.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: tacred.ml,v 1.75.2.7 2005/11/02 13:18:43 herbelin Exp $ *)
+(* $Id: tacred.ml 8003 2006-02-07 22:11:50Z herbelin $ *)
open Pp
open Util
@@ -20,39 +20,26 @@ open Inductive
open Environ
open Reductionops
open Closure
-open Instantiate
open Cbv
open Rawterm
-exception Elimconst
-exception Redelimination
+(* Errors *)
-let set_opaque_const = Conv_oracle.set_opaque_const
-let set_transparent_const sp =
- let cb = Global.lookup_constant sp in
- if cb.const_body <> None & cb.const_opaque then
- errorlabstrm "set_transparent_const"
- (str "Cannot make" ++ spc () ++
- Nametab.pr_global_env Idset.empty (ConstRef sp) ++
- spc () ++ str "transparent because it was declared opaque.");
- Conv_oracle.set_transparent_const sp
+type reduction_tactic_error =
+ InvalidAbstraction of env * constr * (env * Type_errors.type_error)
-let set_opaque_var = Conv_oracle.set_opaque_var
-let set_transparent_var = Conv_oracle.set_transparent_var
+exception ReductionTacticError of reduction_tactic_error
-let _ =
- Summary.declare_summary "Transparent constants and variables"
- { Summary.freeze_function = Conv_oracle.freeze;
- Summary.unfreeze_function = Conv_oracle.unfreeze;
- Summary.init_function = Conv_oracle.init;
- Summary.survive_module = false;
- Summary.survive_section = false }
+(* Evaluable reference *)
+
+exception Elimconst
+exception Redelimination
let is_evaluable env ref =
match ref with
EvalConstRef kn ->
let (ids,kns) = Conv_oracle.freeze() in
- KNpred.mem kn kns &
+ Cpred.mem kn kns &
let cb = Environ.lookup_constant kn env in
cb.const_body <> None & not cb.const_opaque
| EvalVarRef id ->
@@ -84,7 +71,7 @@ let destEvalRef c = match kind_of_term c with
| Var id -> EvalVar id
| Rel n -> EvalRel n
| Evar ev -> EvalEvar ev
- | _ -> anomaly "Not an evaluable reference"
+ | _ -> anomaly "Not an unfoldable reference"
let reference_opt_value sigma env = function
| EvalConst cst -> constant_opt_value env cst
@@ -94,7 +81,7 @@ let reference_opt_value sigma env = function
| EvalRel n ->
let (_,v,_) = lookup_rel n env in
option_app (lift n) v
- | EvalEvar ev -> existential_opt_value sigma ev
+ | EvalEvar ev -> Evd.existential_opt_value sigma ev
exception NotEvaluable
let reference_value sigma env c =
@@ -145,17 +132,21 @@ let _ =
Summary.survive_module = false;
Summary.survive_section = false }
-
(* Check that c is an "elimination constant"
- [xn:An]..[x1:A1](<P>MutCase (Rel i) of f1..fk end g1 ..gp)
- or [xn:An]..[x1:A1](Fix(f|t) (Rel i1) ..(Rel ip))
- with i1..ip distinct variables not occuring in t
- keep relevenant information ([i1,Ai1;..;ip,Aip],n,b)
- with b = true in case of a fixpoint in order to compute
- an equivalent of Fix(f|t)[xi<-ai] as
- [yip:Bip]..[yi1:Bi1](F bn..b1)
- == [yip:Bip]..[yi1:Bi1](Fix(f|t)[xi<-ai] (Rel 1)..(Rel p))
- with bj=aj if j<>ik and bj=(Rel c) and Bic=Aic[xn..xic-1 <- an..aic-1] *)
+
+ either [xn:An]..[x1:A1](<P>Case (Rel i) of f1..fk end g1 ..gp)
+
+ or [xn:An]..[x1:A1](Fix(f|t) (Rel i1) ..(Rel ip))
+ with i1..ip distinct variables not occuring in t
+
+ In the second case, keep relevenant information ([i1,Ai1;..;ip,Aip],n)
+ in order to compute an equivalent of Fix(f|t)[xi<-ai] as
+
+ [yip:Bip]..[yi1:Bi1](F bn..b1)
+ == [yip:Bip]..[yi1:Bi1](Fix(f|t)[xi<-ai] (Rel p)..(Rel 1))
+
+ with bj=aj if j<>ik and bj=(Rel c) and Bic=Aic[xn..xic-1 <- an..aic-1]
+*)
let check_fix_reversibility labs args ((lv,i),(_,tys,bds)) =
let n = List.length labs in
@@ -199,8 +190,8 @@ let invert_name labs l na0 env sigma ref = function
| EvalRel _ | EvalEvar _ -> None
| EvalVar id' -> Some (EvalVar id)
| EvalConst kn ->
- let (mp,dp,_) = repr_kn kn in
- Some (EvalConst (make_kn mp dp (label_of_id id))) in
+ let (mp,dp,_) = repr_con kn in
+ Some (EvalConst (make_con mp dp (label_of_id id))) in
match refi with
| None -> None
| Some ref ->
@@ -242,7 +233,7 @@ let compute_consteval_mutual_fix sigma env ref =
match kind_of_term c' with
| Lambda (na,t,g) when l=[] ->
srec (push_rel (na,None,t) env) (minarg+1) (t::labs) ref g
- | Fix ((lv,i),(names,_,_) as fix) ->
+ | Fix ((lv,i),(names,_,_)) ->
(* Last known constant wrapping Fix is ref = [labs](Fix l) *)
(match compute_consteval_direct sigma env ref with
| NotAnElimination -> (*Above const was eliminable but this not!*)
@@ -294,43 +285,49 @@ let rev_firstn_liftn fn ln =
in
rfprec fn []
-(* EliminationFix ([(yi1,Ti1);...;(yip,Tip)],n) means f is some
- [y1:T1,...,yn:Tn](Fix(..) yi1 ... yip);
- f is applied to largs and we need for recursive calls to build
- [x1:Ti1',...,xp:Tip'](f a1..a(n-p) yi1 ... yip)
- where a1...an are the n first arguments of largs and Tik' is Tik[yil=al]
- To check ... *)
+(* If f is bound to EliminationFix (n',infos), then n' is the minimal
+ number of args for starting the reduction and infos is
+ (nbfix,[(yi1,Ti1);...;(yip,Tip)],n) indicating that f converts
+ to some [y1:T1,...,yn:Tn](Fix(..) yip .. yi1) where we can remark that
+ yij = Rel(n+1-j)
+
+ f is applied to largs and we need for recursive calls to build the function
+ g := [xp:Tip',...,x1:Ti1'](f a1 ... an)
+
+ s.t. (g u1 ... up) reduces to (Fix(..) u1 ... up)
+
+ This is made possible by setting
+ a_k:=z_j if k=i_j
+ a_k:=y_k otherwise
+
+ The type Tij' is Tij[yn..yi(j-1)..y1 <- ai(j-1)..a1]
+*)
+
+let x = Name (id_of_string "x")
let make_elim_fun (names,(nbfix,lv,n)) largs =
- let labs = list_firstn n (list_of_stack largs) in
+ let lu = list_firstn n (list_of_stack largs) in
let p = List.length lv in
- let ylv = List.map fst lv in
- let la' = list_map_i
- (fun q aq ->
- try (mkRel (p+1-(list_index (n-q) ylv)))
- with Not_found -> aq) 0
- (List.map (lift p) labs)
+ let lyi = List.map fst lv in
+ let la =
+ list_map_i (fun q aq ->
+ (* k from the comment is q+1 *)
+ try mkRel (p+1-(list_index (n-q) lyi))
+ with Not_found -> aq)
+ 0 (List.map (lift p) lu)
in
fun i ->
match names.(i) with
| None -> None
- | Some ref -> Some (
-(* let fi =
- if nbfix = 1 then
- mkEvalRef ref
- else
- match ref with
- | EvalConst (sp,args) ->
- mkConst (make_path (dirpath sp) id (kind_of_path sp),args)
- | _ -> anomaly "elimination of local fixpoints not implemented"
- in
-*)
- list_fold_left_i
- (fun i c (k,a) ->
- mkLambda (Name(id_of_string"x"),
- substl (rev_firstn_liftn (n-k) (-i) la') a,
- c))
- 1 (applistc (mkEvalRef ref) la') (List.rev lv))
+ | Some ref ->
+ let body = applistc (mkEvalRef ref) la in
+ let g =
+ list_fold_left_i (fun q (* j from comment is n+1-q *) c (ij,tij) ->
+ let subst = List.map (lift (-q)) (list_firstn (n-ij) la) in
+ let tij' = substl (List.rev subst) tij in
+ mkLambda (x,tij',c)
+ ) 1 body (List.rev lv)
+ in Some g
(* [f] is convertible to [Fix(recindices,bodynum),bodyvect)] make
the reduction using this extra information *)
@@ -372,7 +369,7 @@ let contract_cofix_use_function f (bodynum,(_,names,bodies as typedbodies)) =
let reduce_mind_case_use_function func env mia =
match kind_of_term mia.mconstr with
- | Construct(ind_sp,i as cstr_sp) ->
+ | Construct(ind_sp,i) ->
let real_cargs = list_skipn mia.mci.ci_npar mia.mcargs in
applist (mia.mlf.(i-1), real_cargs)
| CoFix (_,(names,_,_) as cofix) ->
@@ -380,8 +377,8 @@ let reduce_mind_case_use_function func env mia =
match names.(i) with
| Name id ->
if isConst func then
- let (mp,dp,_) = repr_kn (destConst func) in
- let kn = make_kn mp dp (label_of_id id) in
+ let (mp,dp,_) = repr_con (destConst func) in
+ let kn = make_con mp dp (label_of_id id) in
(match constant_opt_value env kn with
| None -> None
| Some _ -> Some (mkConst kn))
@@ -452,7 +449,7 @@ let rec red_elim_const env sigma ref largs =
and construct_const env sigma =
let rec hnfstack (x, stack as s) =
match kind_of_term x with
- | Cast (c,_) -> hnfstack (c, stack)
+ | Cast (c,_,_) -> hnfstack (c, stack)
| App (f,cl) -> hnfstack (f, append_stack cl stack)
| Lambda (id,t,c) ->
(match decomp_stack stack with
@@ -491,7 +488,7 @@ and construct_const env sigma =
(* Red reduction tactic: reduction to a product *)
-let internal_red_product env sigma c =
+let try_red_product env sigma c =
let simpfun = clos_norm_flags betaiotazeta env sigma in
let rec redrec env x =
match kind_of_term x with
@@ -506,7 +503,7 @@ let internal_red_product env sigma c =
let stack' = stack_assign stack recargnum recarg' in
simpfun (app_stack (f,stack')))
| _ -> simpfun (appvect (redrec env f, l)))
- | Cast (c,_) -> redrec env c
+ | Cast (c,_,_) -> redrec env c
| Prod (x,a,b) -> mkProd (x, a, redrec (push_rel (x,None,a) env) b)
| LetIn (x,a,b,t) -> redrec env (subst1 a t)
| Case (ci,p,d,lf) -> simpfun (mkCase (ci,p,redrec env d,lf))
@@ -521,11 +518,9 @@ let internal_red_product env sigma c =
in redrec env c
let red_product env sigma c =
- try internal_red_product env sigma c
+ try try_red_product env sigma c
with Redelimination -> error "Not reducible"
-(* Hnf reduction tactic: *)
-
let hnf_constr env sigma c =
let rec redrec (x, largs as s) =
match kind_of_term x with
@@ -536,7 +531,7 @@ let hnf_constr env sigma c =
stacklam redrec [a] c rest)
| LetIn (n,b,t,c) -> stacklam redrec [b] c largs
| App (f,cl) -> redrec (f, append_stack cl largs)
- | Cast (c,_) -> redrec (c, largs)
+ | Cast (c,_,_) -> redrec (c, largs)
| Case (ci,p,c,lf) ->
(try
redrec
@@ -577,7 +572,7 @@ let whd_nf env sigma c =
stacklam nf_app [a1] c2 rest)
| LetIn (n,b,t,c) -> stacklam nf_app [b] c stack
| App (f,cl) -> nf_app (f, append_stack cl stack)
- | Cast (c,_) -> nf_app (c, stack)
+ | Cast (c,_,_) -> nf_app (c, stack)
| Case (ci,p,d,lf) ->
(try
nf_app (special_red_case sigma env nf_app (ci,p,d,lf), stack)
@@ -598,9 +593,6 @@ let whd_nf env sigma c =
let nf env sigma c = strong whd_nf env sigma c
-let is_reference c =
- try let r = reference_of_constr c in true with _ -> false
-
let is_head c t =
match kind_of_term t with
| App (f,_) -> f = c
@@ -609,7 +601,6 @@ let is_head c t =
let contextually byhead (locs,c) f env sigma t =
let maxocc = List.fold_right max locs 0 in
let pos = ref 1 in
- let check = ref true in
let except = List.exists (fun n -> n<0) locs in
if except & (List.exists (fun n -> n>=0) locs)
then error "mixing of positive and negative occurences"
@@ -626,7 +617,7 @@ let contextually byhead (locs,c) f env sigma t =
f env sigma t
else if byhead then
(* find other occurrences of c in t; TODO: ensure left-to-right *)
- let (f,l) = destApplication t in
+ let (f,l) = destApp t in
mkApp (f, array_map_left (traverse envc) l)
else
t
@@ -637,7 +628,7 @@ let contextually byhead (locs,c) f env sigma t =
in
let t' = traverse (env,c) t in
if locs <> [] & List.exists (fun o -> o >= !pos or o <= - !pos) locs then
- errorlabstrm "contextually" (str "Too few occurences");
+ error_invalid_occurrence locs;
t'
(* linear bindings (following pretty-printer) of the value of name in c.
@@ -652,7 +643,7 @@ let rec substlin env name n ol c =
with
NotEvaluableConst _ ->
errorlabstrm "substlin"
- (pr_kn kn ++ str " is not a defined constant")
+ (pr_con kn ++ str " is not a defined constant")
else
((n+1), ol, c)
@@ -701,7 +692,7 @@ let rec substlin env name n ol c =
let (n2,ol2,c2') = substlin env name n1 ol1 c2 in
(n2,ol2,mkProd (na,c1',c2')))
- | Case (ci,p,d,llf) ->
+ | Case (ci,p,d,llf) ->
let rec substlist nn oll = function
| [] -> (nn,oll,[])
| f::lfe ->
@@ -712,24 +703,25 @@ let rec substlin env name n ol c =
let (nn2,oll2,lfe') = substlist nn1 oll1 lfe in
(nn2,oll2,f'::lfe'))
in
- let (n1,ol1,p') = substlin env name n ol p in (* ATTENTION ERREUR *)
- (match ol1 with (* si P pas affiche *)
- | [] -> (n1,[],mkCase (ci, p', d, llf))
+ (* p is printed after d in v8 syntax *)
+ let (n1,ol1,d') = substlin env name n ol d in
+ (match ol1 with
+ | [] -> (n1,[],mkCase (ci, p, d', llf))
| _ ->
- let (n2,ol2,d') = substlin env name n1 ol1 d in
+ let (n2,ol2,p') = substlin env name n1 ol1 p in
(match ol2 with
| [] -> (n2,[],mkCase (ci, p', d', llf))
| _ ->
let (n3,ol3,lf') = substlist n2 ol2 (Array.to_list llf)
in (n3,ol3,mkCase (ci, p', d', Array.of_list lf'))))
- | Cast (c1,c2) ->
+ | Cast (c1,k,c2) ->
let (n1,ol1,c1') = substlin env name n ol c1 in
(match ol1 with
- | [] -> (n1,[],mkCast (c1',c2))
- | _ ->
- let (n2,ol2,c2') = substlin env name n1 ol1 c2 in
- (n2,ol2,mkCast (c1',c2')))
+ | [] -> (n1,[],mkCast (c1',k,c2))
+ | _ ->
+ let (n2,ol2,c2') = substlin env name n1 ol1 c2 in
+ (n2,ol2,mkCast (c1',k,c2')))
| Fix _ ->
(warning "do not consider occurrences inside fixpoints"; (n,ol,c))
@@ -764,8 +756,8 @@ let unfoldoccs env sigma (occl,name) c =
| (_,[],uc) -> nf_betaiota uc
| (1,_,_) ->
error ((string_of_evaluable_ref env name)^" does not occur")
- | _ -> error ("bad occurrence numbers of "
- ^(string_of_evaluable_ref env name))
+ | (_,l,_) ->
+ error_invalid_occurrence l
(* Unfold reduction tactic: *)
let unfoldn loccname env sigma c =
@@ -797,78 +789,29 @@ let compute = cbv_betadeltaiota
(* gives [na:ta]c' such that c converts to ([na:ta]c' a), abstracting only
* the specified occurrences. *)
-let abstract_scheme env sigma (locc,a) t =
+let abstract_scheme env sigma (locc,a) c =
let ta = Retyping.get_type_of env sigma a in
let na = named_hd env ta Anonymous in
if occur_meta ta then error "cannot find a type for the generalisation";
if occur_meta a then
- mkLambda (na,ta,t)
+ mkLambda (na,ta,c)
else
- mkLambda (na, ta,subst_term_occ locc a t)
-
+ mkLambda (na,ta,subst_term_occ locc a c)
let pattern_occs loccs_trm env sigma c =
let abstr_trm = List.fold_right (abstract_scheme env sigma) loccs_trm c in
- let _ = Typing.type_of env sigma abstr_trm in
- applist(abstr_trm, List.map snd loccs_trm)
-
-(* Generic reduction: reduction functions used in reduction tactics *)
-
-type red_expr = (constr, evaluable_global_reference) red_expr_gen
-
-open RedFlags
-
-let make_flag_constant = function
- | EvalVarRef id -> fVAR id
- | EvalConstRef sp -> fCONST sp
-
-let make_flag f =
- let red = no_red in
- let red = if f.rBeta then red_add red fBETA else red in
- let red = if f.rIota then red_add red fIOTA else red in
- let red = if f.rZeta then red_add red fZETA else red in
- let red =
- if f.rDelta then (* All but rConst *)
- let red = red_add red fDELTA in
- let red = red_add_transparent red (Conv_oracle.freeze ()) in
- List.fold_right
- (fun v red -> red_sub red (make_flag_constant v))
- f.rConst red
- else (* Only rConst *)
- let red = red_add_transparent (red_add red fDELTA) all_opaque in
- List.fold_right
- (fun v red -> red_add red (make_flag_constant v))
- f.rConst red
- in red
-
-let red_expr_tab = ref Stringmap.empty
-
-let declare_red_expr s f =
- try
- let _ = Stringmap.find s !red_expr_tab in
- error ("There is already a reduction expression of name "^s)
- with Not_found ->
- red_expr_tab := Stringmap.add s f !red_expr_tab
-
-let reduction_of_redexp = function
- | Red internal -> if internal then internal_red_product else red_product
- | Hnf -> hnf_constr
- | Simpl (Some (_,c as lp)) -> contextually (is_reference c) lp nf
- | Simpl None -> nf
- | Cbv f -> cbv_norm_flags (make_flag f)
- | Lazy f -> clos_norm_flags (make_flag f)
- | Unfold ubinds -> unfoldn ubinds
- | Fold cl -> fold_commands cl
- | Pattern lp -> pattern_occs lp
- | ExtraRedExpr s ->
- (try Stringmap.find s !red_expr_tab
- with Not_found -> error("unknown user-defined reduction \""^s^"\""))
+ try
+ let _ = Typing.type_of env sigma abstr_trm in
+ applist(abstr_trm, List.map snd loccs_trm)
+ with Type_errors.TypeError (env',t) ->
+ raise (ReductionTacticError (InvalidAbstraction (env,abstr_trm,(env',t))))
+
(* Used in several tactics. *)
exception NotStepReducible
let one_step_reduce env sigma c =
- let rec redrec (x, largs as s) =
+ let rec redrec (x, largs) =
match kind_of_term x with
| Lambda (n,t,c) ->
(match decomp_stack largs with
@@ -885,7 +828,7 @@ let one_step_reduce env sigma c =
(match reduce_fix (whd_betadeltaiota_state env sigma) fix largs with
| Reduced s' -> s'
| NotReducible -> raise NotStepReducible)
- | Cast (c,_) -> redrec (c,largs)
+ | Cast (c,_,_) -> redrec (c,largs)
| _ when isEvalRef env x ->
let ref =
try destEvalRef x
@@ -940,14 +883,14 @@ let reduce_to_ref_gen allow_product env sigma ref t =
(str"Not an induction object of atomic type")
| _ ->
try
- if reference_of_constr c = ref
+ if global_of_constr c = ref
then it_mkProd_or_LetIn t l
else raise Not_found
with Not_found ->
try
let t' = nf_betaiota (one_step_reduce env sigma t) in
elimrec env t' l
- with NotStepReducible ->
+ with NotStepReducible ->
errorlabstrm ""
(str "Not a statement of conclusion " ++
Nametab.pr_global_env Idset.empty ref)
diff --git a/pretyping/tacred.mli b/pretyping/tacred.mli
index 7998a8fd..a5468435 100644
--- a/pretyping/tacred.mli
+++ b/pretyping/tacred.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: tacred.mli,v 1.21.2.2 2005/01/21 16:42:37 herbelin Exp $ i*)
+(*i $Id: tacred.mli 8003 2006-02-07 22:11:50Z herbelin $ i*)
(*i*)
open Names
@@ -18,15 +18,23 @@ open Closure
open Rawterm
(*i*)
+type reduction_tactic_error =
+ InvalidAbstraction of env * constr * (env * Type_errors.type_error)
+
+exception ReductionTacticError of reduction_tactic_error
+
(*s Reduction functions associated to tactics. \label{tacred} *)
val is_evaluable : env -> evaluable_global_reference -> bool
exception Redelimination
-(* Red (raise Redelimination if nothing reducible) *)
+(* Red (raise user error if nothing reducible) *)
val red_product : reduction_function
+(* Red (raise Redelimination if nothing reducible) *)
+val try_red_product : reduction_function
+
(* Hnf *)
val hnf_constr : reduction_function
@@ -69,17 +77,5 @@ val reduce_to_quantified_ref :
val reduce_to_atomic_ref :
env -> evar_map -> Libnames.global_reference -> types -> types
-type red_expr = (constr, evaluable_global_reference) red_expr_gen
-
val contextually : bool -> constr occurrences -> reduction_function
-> reduction_function
-val reduction_of_redexp : red_expr -> reduction_function
-
-val declare_red_expr : string -> reduction_function -> unit
-
-(* Opaque and Transparent commands. *)
-val set_opaque_const : constant -> unit
-val set_transparent_const : constant -> unit
-
-val set_opaque_var : identifier -> unit
-val set_transparent_var : identifier -> unit
diff --git a/pretyping/termops.ml b/pretyping/termops.ml
index 8f12ca62..89de5537 100644
--- a/pretyping/termops.ml
+++ b/pretyping/termops.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: termops.ml,v 1.29.2.1 2004/07/16 19:30:46 herbelin Exp $ *)
+(* $Id: termops.ml 8003 2006-02-07 22:11:50Z herbelin $ *)
open Pp
open Util
@@ -35,60 +35,116 @@ let pr_name = function
| Anonymous -> str "_"
let pr_sp sp = str(string_of_kn sp)
+let pr_con sp = str(string_of_con sp)
-let rec print_constr c = match kind_of_term c with
+let rec pr_constr c = match kind_of_term c with
| Rel n -> str "#"++int n
| Meta n -> str "Meta(" ++ int n ++ str ")"
| Var id -> pr_id id
| Sort s -> print_sort s
- | Cast (c,t) -> hov 1
- (str"(" ++ print_constr c ++ cut() ++
- str":" ++ print_constr t ++ str")")
+ | Cast (c,_, t) -> hov 1
+ (str"(" ++ pr_constr c ++ cut() ++
+ str":" ++ pr_constr t ++ str")")
| Prod (Name(id),t,c) -> hov 1
- (str"forall " ++ pr_id id ++ str":" ++ print_constr t ++ str"," ++
- spc() ++ print_constr c)
+ (str"forall " ++ pr_id id ++ str":" ++ pr_constr t ++ str"," ++
+ spc() ++ pr_constr c)
| Prod (Anonymous,t,c) -> hov 0
- (str"(" ++ print_constr t ++ str " ->" ++ spc() ++
- print_constr c ++ str")")
+ (str"(" ++ pr_constr t ++ str " ->" ++ spc() ++
+ pr_constr c ++ str")")
| Lambda (na,t,c) -> hov 1
(str"fun " ++ pr_name na ++ str":" ++
- print_constr t ++ str" =>" ++ spc() ++ print_constr c)
+ pr_constr t ++ str" =>" ++ spc() ++ pr_constr c)
| LetIn (na,b,t,c) -> hov 0
- (str"let " ++ pr_name na ++ str":=" ++ print_constr b ++
- str":" ++ brk(1,2) ++ print_constr t ++ cut() ++
- print_constr c)
+ (str"let " ++ pr_name na ++ str":=" ++ pr_constr b ++
+ str":" ++ brk(1,2) ++ pr_constr t ++ cut() ++
+ pr_constr c)
| App (c,l) -> hov 1
- (str"(" ++ print_constr c ++ spc() ++
- prlist_with_sep spc print_constr (Array.to_list l) ++ str")")
+ (str"(" ++ pr_constr c ++ spc() ++
+ prlist_with_sep spc pr_constr (Array.to_list l) ++ str")")
| Evar (e,l) -> hov 1
(str"Evar#" ++ int e ++ str"{" ++
- prlist_with_sep spc print_constr (Array.to_list l) ++str"}")
- | Const c -> str"Cst(" ++ pr_sp c ++ str")"
+ prlist_with_sep spc pr_constr (Array.to_list l) ++str"}")
+ | Const c -> str"Cst(" ++ pr_con c ++ str")"
| Ind (sp,i) -> str"Ind(" ++ pr_sp sp ++ str"," ++ int i ++ str")"
| Construct ((sp,i),j) ->
str"Constr(" ++ pr_sp sp ++ str"," ++ int i ++ str"," ++ int j ++ str")"
| Case (ci,p,c,bl) -> v 0
- (hv 0 (str"<"++print_constr p++str">"++ cut() ++ str"Case " ++
- print_constr c ++ str"of") ++ cut() ++
- prlist_with_sep (fun _ -> brk(1,2)) print_constr (Array.to_list bl) ++
+ (hv 0 (str"<"++pr_constr p++str">"++ cut() ++ str"Case " ++
+ pr_constr c ++ str"of") ++ cut() ++
+ prlist_with_sep (fun _ -> brk(1,2)) pr_constr (Array.to_list bl) ++
cut() ++ str"end")
| Fix ((t,i),(lna,tl,bl)) ->
let fixl = Array.mapi (fun i na -> (na,t.(i),tl.(i),bl.(i))) lna in
hov 1
(str"fix " ++ int i ++ spc() ++ str"{" ++
v 0 (prlist_with_sep spc (fun (na,i,ty,bd) ->
- pr_name na ++ str"/" ++ int i ++ str":" ++ print_constr ty ++
- cut() ++ str":=" ++ print_constr bd) (Array.to_list fixl)) ++
+ pr_name na ++ str"/" ++ int i ++ str":" ++ pr_constr ty ++
+ cut() ++ str":=" ++ pr_constr bd) (Array.to_list fixl)) ++
str"}")
| CoFix(i,(lna,tl,bl)) ->
let fixl = Array.mapi (fun i na -> (na,tl.(i),bl.(i))) lna in
hov 1
(str"cofix " ++ int i ++ spc() ++ str"{" ++
v 0 (prlist_with_sep spc (fun (na,ty,bd) ->
- pr_name na ++ str":" ++ print_constr ty ++
- cut() ++ str":=" ++ print_constr bd) (Array.to_list fixl)) ++
+ pr_name na ++ str":" ++ pr_constr ty ++
+ cut() ++ str":=" ++ pr_constr bd) (Array.to_list fixl)) ++
str"}")
+let term_printer = ref (fun _ -> pr_constr)
+let print_constr_env t = !term_printer t
+let print_constr t = !term_printer (Global.env()) t
+let set_print_constr f = term_printer := f
+
+let pr_var_decl env (id,c,typ) =
+ let pbody = match c with
+ | None -> (mt ())
+ | Some c ->
+ (* Force evaluation *)
+ let pb = print_constr_env env c in
+ (str" := " ++ pb ++ cut () ) in
+ let pt = print_constr_env env typ in
+ let ptyp = (str" : " ++ pt) in
+ (pr_id id ++ hov 0 (pbody ++ ptyp))
+
+let pr_rel_decl env (na,c,typ) =
+ let pbody = match c with
+ | None -> mt ()
+ | Some c ->
+ (* Force evaluation *)
+ let pb = print_constr_env env c in
+ (str":=" ++ spc () ++ pb ++ spc ()) in
+ let ptyp = print_constr_env env typ in
+ match na with
+ | Anonymous -> hov 0 (str"<>" ++ spc () ++ pbody ++ str":" ++ spc () ++ ptyp)
+ | Name id -> hov 0 (pr_id id ++ spc () ++ pbody ++ str":" ++ spc () ++ ptyp)
+
+let print_named_context env =
+ hv 0 (fold_named_context
+ (fun env d pps ->
+ pps ++ ws 2 ++ pr_var_decl env d)
+ env ~init:(mt ()))
+
+let print_rel_context env =
+ hv 0 (fold_rel_context
+ (fun env d pps -> pps ++ ws 2 ++ pr_rel_decl env d)
+ env ~init:(mt ()))
+
+let print_env env =
+ let sign_env =
+ fold_named_context
+ (fun env d pps ->
+ let pidt = pr_var_decl env d in
+ (pps ++ fnl () ++ pidt))
+ env ~init:(mt ())
+ in
+ let db_env =
+ fold_rel_context
+ (fun env d pps ->
+ let pnat = pr_rel_decl env d in (pps ++ fnl () ++ pnat))
+ env ~init:(mt ())
+ in
+ (sign_env ++ db_env)
+
(*let current_module = ref empty_dirpath
let set_module m = current_module := m*)
@@ -98,6 +154,20 @@ let new_univ =
(fun sp ->
incr univ_gen;
Univ.make_univ (Lib.library_dp(),!univ_gen))
+let new_Type () = mkType (new_univ ())
+let new_Type_sort () = Type (new_univ ())
+
+(* This refreshes universes in types; works only for inferred types (i.e. for
+ types of the form (x1:A1)...(xn:An)B with B a sort or an atom in
+ head normal form) *)
+let refresh_universes t =
+ let modified = ref false in
+ let rec refresh t = match kind_of_term t with
+ | Sort (Type _) -> modified := true; new_Type ()
+ | Prod (na,u,v) -> mkProd (na,u,refresh v)
+ | _ -> t in
+ let t' = refresh t in
+ if !modified then t' else t
let new_sort_in_family = function
| InProp -> mk_Prop
@@ -185,6 +255,8 @@ let it_named_context_quantifier f ~init =
let it_mkNamedProd_or_LetIn = it_named_context_quantifier mkNamedProd_or_LetIn
let it_mkNamedLambda_or_LetIn = it_named_context_quantifier mkNamedLambda_or_LetIn
+let it_mkNamedProd_wo_LetIn = it_named_context_quantifier mkNamedProd_wo_LetIn
+
(* *)
(* strips head casts and flattens head applications *)
@@ -192,11 +264,11 @@ 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)
+ | Cast (c,_,_) -> collapse_rec c cl2
+ | _ -> if Array.length cl2 = 0 then f else mkApp (f,cl2)
in
collapse_rec f cl
- | Cast (c,t) -> strip_head_cast c
+ | Cast (c,_,_) -> strip_head_cast c
| _ -> c
(* [map_constr_with_named_binders g f l c] maps [f l] on the immediate
@@ -208,7 +280,7 @@ let rec strip_head_cast c = match kind_of_term c with
let map_constr_with_named_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)
+ | Cast (c,k,t) -> mkCast (f l c, k, f l t)
| Prod (na,t,c) -> mkProd (na, f l t, f (g na l) c)
| Lambda (na,t,c) -> mkLambda (na, f l t, f (g na l) c)
| LetIn (na,b,t,c) -> mkLetIn (na, f l b, f l t, f (g na l) c)
@@ -243,7 +315,7 @@ let fold_rec_types g (lna,typarray,_) e =
let map_constr_with_binders_left_to_right g f l c = match kind_of_term c with
| (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _
| Construct _) -> c
- | Cast (c,t) -> let c' = f l c in mkCast (c', f l t)
+ | Cast (c,k,t) -> let c' = f l c in mkCast (c',k,f l t)
| Prod (na,t,c) ->
let t' = f l t in
mkProd (na, t', f (g (na,None,t) l) c)
@@ -263,7 +335,9 @@ let map_constr_with_binders_left_to_right g f l c = match kind_of_term c with
mkApp (hd, [| f l a |])
| Evar (e,al) -> mkEvar (e, array_map_left (f l) al)
| Case (ci,p,c,bl) ->
- let p' = f l p in let c' = f l c in
+ (* In v8 concrete syntax, predicate is after the term to match! *)
+ let c' = f l c in
+ let p' = f l p in
mkCase (ci, p', c', array_map_left (f l) bl)
| Fix (ln,(lna,tl,bl as fx)) ->
let l' = fold_rec_types g fx l in
@@ -278,10 +352,10 @@ let map_constr_with_binders_left_to_right g f l c = match kind_of_term c with
let map_constr_with_full_binders g f l cstr = match kind_of_term cstr with
| (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _
| Construct _) -> cstr
- | Cast (c,t) ->
+ | Cast (c,k, t) ->
let c' = f l c in
let t' = f l t in
- if c==c' && t==t' then cstr else mkCast (c', t')
+ if c==c' && t==t' then cstr else mkCast (c', k, t')
| Prod (na,t,c) ->
let t' = f l t in
let c' = f (g (na,None,t) l) c in
@@ -335,7 +409,7 @@ let map_constr_with_full_binders g f l cstr = match kind_of_term cstr with
let fold_constr_with_binders g f n acc c = match kind_of_term c with
| (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _
| Construct _) -> acc
- | Cast (c,t) -> f n (f n acc c) t
+ | Cast (c,_, t) -> f n (f n acc c) t
| Prod (_,t,c) -> f (g n) (f n acc t) c
| Lambda (_,t,c) -> f (g n) (f n acc t) c
| LetIn (_,b,t,c) -> f (g n) (f n (f n acc b) t) c
@@ -359,7 +433,7 @@ let fold_constr_with_binders g f n acc c = match kind_of_term c with
let iter_constr_with_full_binders g f l c = match kind_of_term c with
| (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _
| Construct _) -> ()
- | Cast (c,t) -> f l c; f l t
+ | Cast (c,_, t) -> f l c; f l t
| Prod (na,t,c) -> f l t; f (g (na,None,t) l) c
| Lambda (na,t,c) -> f l t; f (g (na,None,t) l) c
| LetIn (na,b,t,c) -> f l b; f l t; f (g (na,Some b,t) l) c
@@ -541,10 +615,14 @@ let replace_term = replace_term_gen eq_constr
bindings is done. The list may contain only negative occurrences
that will not be substituted. *)
+let error_invalid_occurrence l =
+ errorlabstrm ""
+ (str ("Invalid occurrence " ^ plural (List.length l) "number" ^": ") ++
+ prlist_with_sep spc int l)
+
let subst_term_occ_gen locs occ c t =
let maxocc = List.fold_right max locs 0 in
let pos = ref occ in
- let check = ref true in
let except = List.exists (fun n -> n<0) locs in
if except & (List.exists (fun n -> n>=0) locs)
then error "mixing of positive and negative occurences"
@@ -573,8 +651,8 @@ let subst_term_occ locs c t =
t
else
let (nbocc,t') = subst_term_occ_gen locs 1 c t in
- if List.exists (fun o -> o >= nbocc or o <= -nbocc) locs then
- errorlabstrm "subst_term_occ" (str "Too few occurences");
+ let rest = List.filter (fun o -> o >= nbocc or o <= -nbocc) locs in
+ if rest <> [] then error_invalid_occurrence rest;
t'
let subst_term_occ_decl locs c (id,bodyopt,typ as d) =
@@ -588,8 +666,8 @@ let subst_term_occ_decl locs c (id,bodyopt,typ as d) =
else
let (nbocc,body') = subst_term_occ_gen locs 1 c body in
let (nbocc',t') = subst_term_occ_gen locs nbocc c typ in
- if List.exists (fun o -> o >= nbocc' or o <= -nbocc') locs then
- errorlabstrm "subst_term_occ_decl" (str "Too few occurences");
+ let rest = List.filter (fun o -> o >= nbocc' or o <= -nbocc') locs in
+ if rest <> [] then error_invalid_occurrence rest;
(id,Some body',t')
@@ -626,10 +704,10 @@ let hdchar env c =
| Prod (_,_,c) -> hdrec (k+1) c
| Lambda (_,_,c) -> hdrec (k+1) c
| LetIn (_,_,_,c) -> hdrec (k+1) c
- | Cast (c,_) -> hdrec k c
+ | Cast (c,_,_) -> hdrec k c
| App (f,l) -> hdrec k f
| Const kn ->
- let c = lowercase_first_char (id_of_label (label kn)) in
+ let c = lowercase_first_char (id_of_label (con_label kn)) in
if c = "?" then "y" else c
| Ind ((kn,i) as x) ->
if i=0 then
@@ -667,8 +745,11 @@ let named_hd env a = function
let named_hd_type env a = named_hd env (body_of_type a)
-let prod_name env (n,a,b) = mkProd (named_hd_type env a n, a, b)
-let lambda_name env (n,a,b) = mkLambda (named_hd_type env a n, a, b)
+let mkProd_name env (n,a,b) = mkProd (named_hd_type env a n, a, b)
+let mkLambda_name env (n,a,b) = mkLambda (named_hd_type env a n, a, b)
+
+let lambda_name = mkLambda_name
+let prod_name = mkProd_name
let prod_create env (a,b) = mkProd (named_hd_type env a Anonymous, a, b)
let lambda_create env (a,b) = mkLambda (named_hd_type env a Anonymous, a, b)
@@ -714,6 +795,7 @@ let ids_of_rel_context sign =
Sign.fold_rel_context
(fun (na,_,_) l -> match na with Name id -> id::l | Anonymous -> l)
sign ~init:[]
+
let ids_of_named_context sign =
Sign.fold_named_context (fun (id,_,_) idl -> id::idl) sign ~init:[]
@@ -721,6 +803,7 @@ let ids_of_context env =
(ids_of_rel_context (rel_context env))
@ (ids_of_named_context (named_context env))
+
let names_of_rel_context env =
List.map (fun (na,_,_) -> na) (rel_context env)
@@ -734,7 +817,6 @@ let rec is_imported_modpath = function
let is_imported_ref = function
| VarRef _ -> false
- | ConstRef kn
| IndRef (kn,_)
| ConstructRef ((kn,_),_)
(* | ModTypeRef ln *) ->
@@ -742,6 +824,8 @@ let is_imported_ref = function
(* | ModRef mp ->
is_imported_modpath mp
*)
+ | ConstRef kn ->
+ let (mp,_,_) = repr_con kn in is_imported_modpath mp
let is_global id =
try
@@ -751,7 +835,7 @@ let is_global id =
false
let is_section_variable id =
- try let _ = Sign.lookup_named id (Global.named_context()) in true
+ try let _ = Global.lookup_named id in true
with Not_found -> false
let next_global_ident_from allow_secvar id avoid =
@@ -861,7 +945,7 @@ let eta_eq_constr =
(* iterator on rel context *)
let process_rel_context f env =
- let sign = named_context env in
+ let sign = named_context_val env in
let rels = rel_context env in
let env0 = reset_with_named_context sign env in
Sign.fold_rel_context f rels ~init:env0
@@ -933,6 +1017,6 @@ let rec rename_bound_var env l c =
| Prod (Anonymous,c1,c2) ->
let env' = push_rel (Anonymous,None,c1) env in
mkProd (Anonymous, c1, rename_bound_var env' l c2)
- | Cast (c,t) -> mkCast (rename_bound_var env l c, t)
+ | Cast (c,k,t) -> mkCast (rename_bound_var env l c, k,t)
| x -> c
diff --git a/pretyping/termops.mli b/pretyping/termops.mli
index 22bd0aba..5f8b5376 100644
--- a/pretyping/termops.mli
+++ b/pretyping/termops.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: termops.mli,v 1.21.2.3 2005/01/21 17:19:37 herbelin Exp $ i*)
+(*i $Id: termops.mli 8003 2006-02-07 22:11:50Z herbelin $ i*)
open Util
open Pp
@@ -16,14 +16,24 @@ open Sign
open Environ
(* Universes *)
-(*i val set_module : Names.dir_path -> unit i*)
val new_univ : unit -> Univ.universe
val new_sort_in_family : sorts_family -> sorts
+val new_Type : unit -> types
+val new_Type_sort : unit -> sorts
+val refresh_universes : types -> types
-(* iterators on terms *)
+(* printers *)
val print_sort : sorts -> std_ppcmds
val print_sort_family : sorts_family -> std_ppcmds
-val print_constr : constr -> std_ppcmds
+(* debug printer: do not use to display terms to the casual user... *)
+val set_print_constr : (env -> constr -> std_ppcmds) -> unit
+val print_constr : constr -> std_ppcmds
+val print_constr_env : env -> constr -> std_ppcmds
+val print_named_context : env -> std_ppcmds
+val print_rel_context : env -> std_ppcmds
+val print_env : env -> std_ppcmds
+
+(* iterators on terms *)
val prod_it : init:types -> (name * types) list -> types
val lam_it : init:constr -> (name * types) list -> constr
val rel_vect : int -> int -> constr array
@@ -43,6 +53,7 @@ val it_named_context_quantifier :
(named_declaration -> 'a -> 'a) -> init:'a -> named_context -> 'a
val it_mkNamedProd_or_LetIn : init:types -> named_context -> types
val it_mkNamedLambda_or_LetIn : init:constr -> named_context -> constr
+val it_mkNamedProd_wo_LetIn : init:types -> named_context -> types
(**********************************************************************)
(* Generic iterators on constr *)
@@ -113,6 +124,8 @@ val subst_term_occ : int list -> constr -> types -> types
val subst_term_occ_decl :
int list -> constr -> named_declaration -> named_declaration
+val error_invalid_occurrence : int list -> 'a
+
(* Alternative term equalities *)
val eta_reduce_head : constr -> constr
val eta_eq_constr : constr -> constr -> bool
@@ -126,8 +139,14 @@ val id_of_name_using_hdchar :
env -> types -> name -> identifier
val named_hd : env -> types -> name -> name
val named_hd_type : env -> types -> name -> name
-val prod_name : env -> name * types * types -> constr
+
+val mkProd_name : env -> name * types * types -> types
+val mkLambda_name : env -> name * types * constr -> constr
+
+(* Deprecated synonyms of [mkProd_name] and [mkLambda_name] *)
+val prod_name : env -> name * types * types -> types
val lambda_name : env -> name * types * constr -> constr
+
val prod_create : env -> types * types -> constr
val lambda_create : env -> types * constr -> constr
val name_assumption : env -> rel_declaration -> rel_declaration
diff --git a/pretyping/typing.ml b/pretyping/typing.ml
index a84cd612..be922c7d 100644
--- a/pretyping/typing.ml
+++ b/pretyping/typing.ml
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(* $Id: typing.ml,v 1.32.6.2 2004/07/16 19:30:46 herbelin Exp $ *)
+(* $Id: typing.ml 8673 2006-03-29 21:21:52Z herbelin $ *)
open Util
open Names
@@ -16,68 +16,67 @@ open Reductionops
open Type_errors
open Pretype_errors
open Inductive
+open Inductiveops
open Typeops
+open Evd
+
+let meta_type env mv =
+ let ty =
+ try Evd.meta_ftype env mv
+ with Not_found -> error ("unknown meta ?"^string_of_int mv) in
+ meta_instance env ty
let vect_lift = Array.mapi lift
let vect_lift_type = Array.mapi (fun i t -> type_app (lift i) t)
-type 'a mach_flags = {
- fix : bool;
- nocheck : bool }
-
(* The typing machine without information, without universes but with
existential variables. *)
-let assumption_of_judgment env sigma j =
- assumption_of_judgment env (j_nf_evar sigma j)
-
-let type_judgment env sigma j =
- type_judgment env (j_nf_evar sigma j)
-
-
-let rec execute mf env sigma cstr =
+(* cstr must be in n.f. w.r.t. evars and execute returns a judgement
+ where both the term and type are in n.f. *)
+let rec execute env evd cstr =
match kind_of_term cstr with
| Meta n ->
- error "execute: found a non-instanciated goal"
+ { uj_val = cstr; uj_type = nf_evar (evars_of evd) (meta_type evd n) }
| Evar ev ->
- let ty = Instantiate.existential_type sigma ev in
- let jty = execute mf env sigma ty in
- let jty = assumption_of_judgment env sigma jty in
+ let sigma = Evd.evars_of evd in
+ let ty = Evd.existential_type sigma ev in
+ let jty = execute env evd (nf_evar (evars_of evd) ty) in
+ let jty = assumption_of_judgment env jty in
{ uj_val = cstr; uj_type = jty }
| Rel n ->
- judge_of_relative env n
+ j_nf_evar (evars_of evd) (judge_of_relative env n)
| Var id ->
- judge_of_variable env id
+ j_nf_evar (evars_of evd) (judge_of_variable env id)
| Const c ->
- make_judge cstr (constant_type env c)
+ make_judge cstr (nf_evar (evars_of evd) (constant_type env c))
| Ind ind ->
- make_judge cstr (type_of_inductive env ind)
+ make_judge cstr (nf_evar (evars_of evd) (type_of_inductive env ind))
| Construct cstruct ->
- make_judge cstr (type_of_constructor env cstruct)
-
+ make_judge cstr
+ (nf_evar (evars_of evd) (type_of_constructor env cstruct))
+
| Case (ci,p,c,lf) ->
- let cj = execute mf env sigma c in
- let pj = execute mf env sigma p in
- let lfj = execute_array mf env sigma lf in
+ let cj = execute env evd c in
+ let pj = execute env evd p in
+ let lfj = execute_array env evd lf in
let (j,_) = judge_of_case env ci pj cj lfj in
j
| Fix ((vn,i as vni),recdef) ->
- if (not mf.fix) && array_exists (fun n -> n < 0) vn then
- error "General Fixpoints not allowed";
- let (_,tys,_ as recdef') = execute_recdef mf env sigma recdef in
+ let (_,tys,_ as recdef') = execute_recdef env evd recdef in
let fix = (vni,recdef') in
check_fix env fix;
make_judge (mkFix fix) tys.(i)
| CoFix (i,recdef) ->
- let (_,tys,_ as recdef') = execute_recdef mf env sigma recdef in
+ let (_,tys,_ as recdef') = execute_recdef env evd recdef in
let cofix = (i,recdef') in
check_cofix env cofix;
make_judge (mkCoFix cofix) tys.(i)
@@ -89,86 +88,105 @@ let rec execute mf env sigma cstr =
judge_of_type u
| App (f,args) ->
- let j = execute mf env sigma f in
- let jl = execute_array mf env sigma args in
+ let j = execute env evd f in
+ let jl = execute_array env evd args in
let (j,_) = judge_of_apply env j jl in
- j
+ if isInd f then
+ (* Sort-polymorphism of inductive types *)
+ adjust_inductive_level env evd (destInd f) args j
+ else
+ j
| Lambda (name,c1,c2) ->
- let j = execute mf env sigma c1 in
- let var = type_judgment env sigma j in
+ let j = execute env evd c1 in
+ let var = type_judgment env j in
let env1 = push_rel (name,None,var.utj_val) env in
- let j' = execute mf env1 sigma c2 in
+ let j' = execute env1 evd c2 in
judge_of_abstraction env1 name var j'
| Prod (name,c1,c2) ->
- let j = execute mf env sigma c1 in
- let varj = type_judgment env sigma j in
+ let j = execute env evd c1 in
+ let varj = type_judgment env j in
let env1 = push_rel (name,None,varj.utj_val) env in
- let j' = execute mf env1 sigma c2 in
- let varj' = type_judgment env1 sigma j' in
+ let j' = execute env1 evd c2 in
+ let varj' = type_judgment env1 j' in
judge_of_product env name varj varj'
| LetIn (name,c1,c2,c3) ->
- let j1 = execute mf env sigma c1 in
- let j2 = execute mf env sigma c2 in
- let j2 = type_judgment env sigma j2 in
- let _ = judge_of_cast env j1 j2 in
+ let j1 = execute env evd c1 in
+ let j2 = execute env evd c2 in
+ let j2 = type_judgment env j2 in
+ let _ = judge_of_cast env j1 DEFAULTcast j2 in
let env1 = push_rel (name,Some j1.uj_val,j2.utj_val) env in
- let j3 = execute mf env1 sigma c3 in
+ let j3 = execute env1 evd c3 in
judge_of_letin env name j1 j2 j3
- | Cast (c,t) ->
- let cj = execute mf env sigma c in
- let tj = execute mf env sigma t in
- let tj = type_judgment env sigma tj in
- let j, _ = judge_of_cast env cj tj in
+ | Cast (c,k,t) ->
+ let cj = execute env evd c in
+ let tj = execute env evd t in
+ let tj = type_judgment env tj in
+ let j, _ = judge_of_cast env cj k tj in
j
-and execute_recdef mf env sigma (names,lar,vdef) =
- let larj = execute_array mf env sigma lar in
- let lara = Array.map (assumption_of_judgment env sigma) larj in
+and execute_recdef env evd (names,lar,vdef) =
+ let larj = execute_array env evd lar in
+ let lara = Array.map (assumption_of_judgment env) larj in
let env1 = push_rec_types (names,lara,vdef) env in
- let vdefj = execute_array mf env1 sigma vdef in
+ let vdefj = execute_array env1 evd vdef in
let vdefv = Array.map j_val vdefj in
let _ = type_fixpoint env1 names lara vdefj in
(names,lara,vdefv)
-and execute_array mf env sigma v =
- let jl = execute_list mf env sigma (Array.to_list v) in
- Array.of_list jl
-
-and execute_list mf env sigma = function
- | [] ->
- []
- | c::r ->
- let j = execute mf env sigma c in
- let jr = execute_list mf env sigma r in
- j::jr
-
-
-let safe_machine env sigma constr =
- let mf = { fix = false; nocheck = false } in
- execute mf env sigma constr
-
-let unsafe_machine env sigma constr =
- let mf = { fix = false; nocheck = true } in
- execute mf env sigma constr
+and execute_array env evd = Array.map (execute env evd)
+
+and execute_list env evd = List.map (execute env evd)
+
+and adjust_inductive_level env evd ind args j =
+ let specif = lookup_mind_specif env ind in
+ if is_small_inductive specif then
+ (* No polymorphism *)
+ j
+ else
+ (* Retyping constructor with the actual arguments *)
+ let env',llc,ls0 = constructor_instances env specif ind args in
+ let llj = Array.map (execute_array env' evd) llc in
+ let ls =
+ Array.map (fun lj ->
+ let ls =
+ Array.map (fun c -> decomp_sort env (evars_of evd) c.uj_type) lj
+ in
+ max_inductive_sort ls) llj
+ in
+ let s = find_inductive_level env specif ind ls0 ls in
+ on_judgment_type (set_inductive_level env s) j
+
+let mcheck env evd c t =
+ let sigma = Evd.evars_of evd in
+ let j = execute env evd (nf_evar sigma c) in
+ if not (is_conv_leq env sigma j.uj_type t) then
+ error_actual_type env j (nf_evar sigma t)
(* Type of a constr *)
-
-let type_of env sigma c =
- let j = safe_machine env sigma c in
+
+let mtype_of env evd c =
+ let j = execute env evd (nf_evar (evars_of evd) c) in
(* No normalization: it breaks Pattern! *)
(*nf_betaiota*) (body_of_type j.uj_type)
-(* The typed type of a judgment. *)
+let msort_of env evd c =
+ let j = execute env evd (nf_evar (evars_of evd) c) in
+ let a = type_judgment env j in
+ a.utj_type
-let execute_type env sigma constr =
- let j = execute { fix=false; nocheck=true } env sigma constr in
- assumption_of_judgment env sigma j
+let type_of env sigma c =
+ mtype_of env (Evd.create_evar_defs sigma) c
+let sort_of env sigma c =
+ msort_of env (Evd.create_evar_defs sigma) c
+let check env sigma c =
+ mcheck env (Evd.create_evar_defs sigma) c
-let execute_rec_type env sigma constr =
- let j = execute { fix=false; nocheck=false } env sigma constr in
- assumption_of_judgment env sigma j
+(* The typed type of a judgment. *)
+let mtype_of_type env evd constr =
+ let j = execute env evd (nf_evar (evars_of evd) constr) in
+ assumption_of_judgment env j
diff --git a/pretyping/typing.mli b/pretyping/typing.mli
index 4ea74dcd..c9d7d572 100644
--- a/pretyping/typing.mli
+++ b/pretyping/typing.mli
@@ -6,7 +6,7 @@
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
-(*i $Id: typing.mli,v 1.7.14.1 2004/07/16 19:30:47 herbelin Exp $ i*)
+(*i $Id: typing.mli 6113 2004-09-17 20:28:19Z barras $ i*)
(*i*)
open Term
@@ -17,11 +17,18 @@ open Evd
(* This module provides the typing machine with existential variables
(but without universes). *)
-val unsafe_machine : env -> evar_map -> constr -> unsafe_judgment
-
-val type_of : env -> evar_map -> constr -> constr
-
-val execute_type : env -> evar_map -> constr -> types
-
-val execute_rec_type : env -> evar_map -> constr -> types
-
+(* Typecheck a term and return its type *)
+val type_of : env -> evar_map -> constr -> types
+(* Typecheck a type and return its sort *)
+val sort_of : env -> evar_map -> types -> sorts
+(* Typecheck a term has a given type (assuming the type is OK *)
+val check : env -> evar_map -> constr -> types -> unit
+
+(* The same but with metas... *)
+val mtype_of : env -> evar_defs -> constr -> types
+val msort_of : env -> evar_defs -> types -> sorts
+val mcheck : env -> evar_defs -> constr -> types -> unit
+val meta_type : evar_defs -> metavariable -> types
+
+(* unused typing function... *)
+val mtype_of_type : env -> evar_defs -> types -> types
diff --git a/pretyping/unification.ml b/pretyping/unification.ml
new file mode 100644
index 00000000..e51f5e0e
--- /dev/null
+++ b/pretyping/unification.ml
@@ -0,0 +1,471 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(* $Id: unification.ml 7113 2005-06-05 17:13:06Z barras $ *)
+
+open Pp
+open Util
+open Names
+open Nameops
+open Term
+open Termops
+open Sign
+open Environ
+open Evd
+open Reduction
+open Reductionops
+open Rawterm
+open Pattern
+open Evarutil
+open Pretype_errors
+
+(* if lname_typ is [xn,An;..;x1,A1] and l is a list of terms,
+ gives [x1:A1]..[xn:An]c' such that c converts to ([x1:A1]..[xn:An]c' l) *)
+
+let abstract_scheme env c l lname_typ =
+ List.fold_left2
+ (fun t (locc,a) (na,_,ta) ->
+ let na = match kind_of_term a with Var id -> Name id | _ -> na in
+ if occur_meta ta then error "cannot find a type for the generalisation"
+ else if occur_meta a then lambda_name env (na,ta,t)
+ else lambda_name env (na,ta,subst_term_occ locc a t))
+ c
+ (List.rev l)
+ lname_typ
+
+let abstract_list_all env sigma typ c l =
+ let ctxt,_ = decomp_n_prod env sigma (List.length l) typ in
+ let p = abstract_scheme env c (List.map (function a -> [],a) l) ctxt in
+ try
+ if is_conv_leq env sigma (Typing.type_of env sigma p) typ then p
+ else error "abstract_list_all"
+ with UserError _ ->
+ raise (PretypeError (env,CannotGeneralize typ))
+
+
+(*******************************)
+
+(* Unification à l'ordre 0 de m et n: [unify_0 env sigma cv_pb m n]
+ renvoie deux listes:
+
+ metasubst:(int*constr)list récolte les instances des (Meta k)
+ evarsubst:(constr*constr)list récolte les instances des (Const "?k")
+
+ Attention : pas d'unification entre les différences instances d'une
+ même meta ou evar, il peut rester des doublons *)
+
+(* Unification order: *)
+(* Left to right: unifies first argument and then the other arguments *)
+(*let unify_l2r x = List.rev x
+(* Right to left: unifies last argument and then the other arguments *)
+let unify_r2l x = x
+
+let sort_eqns = unify_r2l
+*)
+
+let unify_0 env sigma cv_pb mod_delta m n =
+ let trivial_unify pb substn m n =
+ if (not(occur_meta m)) && (if mod_delta then is_fconv pb env sigma m n else eq_constr m n) then substn
+ else error_cannot_unify env sigma (m,n) in
+ let rec unirec_rec pb ((metasubst,evarsubst) as substn) m n =
+ let cM = Evarutil.whd_castappevar sigma m
+ and cN = Evarutil.whd_castappevar sigma n in
+ match (kind_of_term cM,kind_of_term cN) with
+ | Meta k1, Meta k2 ->
+ if k1 < k2 then (k1,cN)::metasubst,evarsubst
+ else if k1 = k2 then substn
+ else (k2,cM)::metasubst,evarsubst
+ | Meta k, _ -> (k,cN)::metasubst,evarsubst
+ | _, Meta k -> (k,cM)::metasubst,evarsubst
+ | Evar _, _ -> metasubst,((cM,cN)::evarsubst)
+ | _, Evar _ -> metasubst,((cN,cM)::evarsubst)
+
+ | Lambda (_,t1,c1), Lambda (_,t2,c2) ->
+ unirec_rec CONV (unirec_rec CONV substn t1 t2) c1 c2
+ | Prod (_,t1,c1), Prod (_,t2,c2) ->
+ unirec_rec pb (unirec_rec CONV substn t1 t2) c1 c2
+ | LetIn (_,b,_,c), _ -> unirec_rec pb substn (subst1 b c) cN
+ | _, LetIn (_,b,_,c) -> unirec_rec pb substn cM (subst1 b c)
+
+ | App (f1,l1), App (f2,l2) ->
+ let len1 = Array.length l1
+ and len2 = Array.length l2 in
+ let (f1,l1,f2,l2) =
+ if len1 = len2 then (f1,l1,f2,l2)
+ else if len1 < len2 then
+ let extras,restl2 = array_chop (len2-len1) l2 in
+ (f1, l1, appvect (f2,extras), restl2)
+ else
+ let extras,restl1 = array_chop (len1-len2) l1 in
+ (appvect (f1,extras), restl1, f2, l2) in
+ (try
+ array_fold_left2 (unirec_rec CONV)
+ (unirec_rec CONV substn f1 f2) l1 l2
+ with ex when precatchable_exception ex ->
+ trivial_unify pb substn cM cN)
+ | Case (_,p1,c1,cl1), Case (_,p2,c2,cl2) ->
+ array_fold_left2 (unirec_rec CONV)
+ (unirec_rec CONV (unirec_rec CONV substn p1 p2) c1 c2) cl1 cl2
+
+ | _ -> trivial_unify pb substn cM cN
+
+ in
+ if (not(occur_meta m)) &&
+ (if mod_delta then is_fconv cv_pb env sigma m n else eq_constr m n)
+ then
+ ([],[])
+ else
+ let (mc,ec) = unirec_rec cv_pb ([],[]) m n in
+ ((*sort_eqns*) mc, (*sort_eqns*) ec)
+
+
+(* Unification
+ *
+ * Procedure:
+ * (1) The function [unify mc wc M N] produces two lists:
+ * (a) a list of bindings Meta->RHS
+ * (b) a list of bindings EVAR->RHS
+ *
+ * The Meta->RHS bindings cannot themselves contain
+ * meta-vars, so they get applied eagerly to the other
+ * bindings. This may or may not close off all RHSs of
+ * the EVARs. For each EVAR whose RHS is closed off,
+ * we can just apply it, and go on. For each which
+ * is not closed off, we need to do a mimick step -
+ * in general, we have something like:
+ *
+ * ?X == (c e1 e2 ... ei[Meta(k)] ... en)
+ *
+ * so we need to do a mimick step, converting ?X
+ * into
+ *
+ * ?X -> (c ?z1 ... ?zn)
+ *
+ * of the proper types. Then, we can decompose the
+ * equation into
+ *
+ * ?z1 --> e1
+ * ...
+ * ?zi --> ei[Meta(k)]
+ * ...
+ * ?zn --> en
+ *
+ * and keep on going. Whenever we find that a R.H.S.
+ * is closed, we can, as before, apply the constraint
+ * directly. Whenever we find an equation of the form:
+ *
+ * ?z -> Meta(n)
+ *
+ * we can reverse the equation, put it into our metavar
+ * substitution, and keep going.
+ *
+ * The most efficient mimick possible is, for each
+ * Meta-var remaining in the term, to declare a
+ * new EVAR of the same type. This is supposedly
+ * determinable from the clausale form context -
+ * we look up the metavar, take its type there,
+ * and apply the metavar substitution to it, to
+ * close it off. But this might not always work,
+ * since other metavars might also need to be resolved. *)
+
+let applyHead env evd n c =
+ let rec apprec n c cty evd =
+ if n = 0 then
+ (evd, c)
+ else
+ match kind_of_term (whd_betadeltaiota env (evars_of evd) cty) with
+ | Prod (_,c1,c2) ->
+ let (evd',evar) = Evarutil.new_evar evd env c1 in
+ apprec (n-1) (mkApp(c,[|evar|])) (subst1 evar c2) evd'
+ | _ -> error "Apply_Head_Then"
+ in
+ apprec n c (Typing.type_of env (evars_of evd) c) evd
+
+let is_mimick_head f =
+ match kind_of_term f with
+ (Const _|Var _|Rel _|Construct _|Ind _) -> true
+ | _ -> false
+
+(* [w_merge env sigma b metas evars] merges common instances in metas
+ or in evars, possibly generating new unification problems; if [b]
+ is true, unification of types of metas is required *)
+
+let w_merge env with_types mod_delta metas evars evd =
+ let ty_metas = ref [] in
+ let ty_evars = ref [] in
+ let rec w_merge_rec evd metas evars =
+ match (evars,metas) with
+ | ([], []) -> evd
+
+ | ((lhs,rhs)::t, metas) ->
+ (match kind_of_term rhs with
+
+ | Meta k -> w_merge_rec evd ((k,lhs)::metas) t
+
+ | krhs ->
+ (match kind_of_term lhs with
+
+ | Evar (evn,_ as ev) ->
+ if is_defined_evar evd ev then
+ let (metas',evars') =
+ unify_0 env (evars_of evd) CONV mod_delta rhs lhs in
+ w_merge_rec evd (metas'@metas) (evars'@t)
+ else begin
+ let rhs' =
+ if occur_meta rhs then subst_meta metas rhs else rhs
+ in
+ if occur_evar evn rhs' then
+ error "w_merge: recursive equation";
+ match krhs with
+ | App (f,cl) when is_mimick_head f ->
+ (try
+ w_merge_rec (fst (evar_define env ev rhs' evd)) metas t
+ with ex when precatchable_exception ex ->
+ let evd' =
+ mimick_evar evd mod_delta f (Array.length cl) evn in
+ w_merge_rec evd' metas evars)
+ | _ ->
+ (* ensure tail recursion in non-mimickable case! *)
+ w_merge_rec (fst (evar_define env ev rhs' evd)) metas t
+ end
+
+ | _ -> anomaly "w_merge_rec"))
+
+ | ([], (mv,n)::t) ->
+ if meta_defined evd mv then
+ let (metas',evars') =
+ unify_0 env (evars_of evd) CONV mod_delta
+ (meta_fvalue evd mv).rebus n in
+ w_merge_rec evd (metas'@t) evars'
+ else
+ begin
+ if with_types (* or occur_meta mvty *) then
+ (let mvty = Typing.meta_type evd mv in
+ try
+ let sigma = evars_of evd in
+ (* why not typing with the metamap ? *)
+ let nty = Typing.type_of env sigma (nf_meta evd n) in
+ let (mc,ec) = unify_0 env sigma CUMUL mod_delta nty mvty in
+ ty_metas := mc @ !ty_metas;
+ ty_evars := ec @ !ty_evars
+ with e when precatchable_exception e -> ());
+ let evd' = meta_assign mv n evd in
+ w_merge_rec evd' t []
+ end
+
+ and mimick_evar evd mod_delta hdc nargs sp =
+ let ev = Evd.map (evars_of evd) sp in
+ let sp_env = Global.env_of_context ev.evar_hyps in
+ let (evd', c) = applyHead sp_env evd nargs hdc in
+ let (mc,ec) =
+ unify_0 sp_env (evars_of evd') CUMUL mod_delta
+ (Retyping.get_type_of sp_env (evars_of evd') c) ev.evar_concl in
+ let evd'' = w_merge_rec evd' mc ec in
+ if (evars_of evd') == (evars_of evd'')
+ then Evd.evar_define sp c evd''
+ else Evd.evar_define sp (Evarutil.nf_evar (evars_of evd'') c) evd'' in
+
+ (* merge constraints *)
+ let evd' = w_merge_rec evd metas evars in
+ if with_types then
+ (* merge constraints about types: if they fail, don't worry *)
+ try w_merge_rec evd' !ty_metas !ty_evars
+ with e when precatchable_exception e -> evd'
+ else
+ evd'
+
+(* [w_unify env evd M N]
+ performs a unification of M and N, generating a bunch of
+ unification constraints in the process. These constraints
+ are processed, one-by-one - they may either generate new
+ bindings, or, if there is already a binding, new unifications,
+ which themselves generate new constraints. This continues
+ until we get failure, or we run out of constraints.
+ [clenv_typed_unify M N clenv] expects in addition that expected
+ types of metavars are unifiable with the types of their instances *)
+
+let w_unify_core_0 env with_types cv_pb mod_delta m n evd =
+ let (mc,ec) = unify_0 env (evars_of evd) cv_pb mod_delta m n in
+ w_merge env with_types mod_delta mc ec evd
+
+let w_unify_0 env = w_unify_core_0 env false
+let w_typed_unify env = w_unify_core_0 env true
+
+
+(* takes a substitution s, an open term op and a closed term cl
+ try to find a subterm of cl which matches op, if op is just a Meta
+ FAIL because we cannot find a binding *)
+
+let iter_fail f a =
+ let n = Array.length a in
+ let rec ffail i =
+ if i = n then error "iter_fail"
+ else
+ try f a.(i)
+ with ex when precatchable_exception ex -> ffail (i+1)
+ in ffail 0
+
+(* Tries to find an instance of term [cl] in term [op].
+ Unifies [cl] to every subterm of [op] until it finds a match.
+ Fails if no match is found *)
+let w_unify_to_subterm env ?(mod_delta=true) (op,cl) evd =
+ let rec matchrec cl =
+ let cl = strip_outer_cast cl in
+ (try
+ if closed0 cl
+ then w_unify_0 env CONV mod_delta op cl evd,cl
+ else error "Bound 1"
+ with ex when precatchable_exception ex ->
+ (match kind_of_term cl with
+ | App (f,args) ->
+ let n = Array.length args in
+ assert (n>0);
+ let c1 = mkApp (f,Array.sub args 0 (n-1)) in
+ let c2 = args.(n-1) in
+ (try
+ matchrec c1
+ with ex when precatchable_exception ex ->
+ matchrec c2)
+ | Case(_,_,c,lf) -> (* does not search in the predicate *)
+ (try
+ matchrec c
+ with ex when precatchable_exception ex ->
+ iter_fail matchrec lf)
+ | LetIn(_,c1,_,c2) ->
+ (try
+ matchrec c1
+ with ex when precatchable_exception ex ->
+ matchrec c2)
+
+ | Fix(_,(_,types,terms)) ->
+ (try
+ iter_fail matchrec types
+ with ex when precatchable_exception ex ->
+ iter_fail matchrec terms)
+
+ | CoFix(_,(_,types,terms)) ->
+ (try
+ iter_fail matchrec types
+ with ex when precatchable_exception ex ->
+ iter_fail matchrec terms)
+
+ | Prod (_,t,c) ->
+ (try
+ matchrec t
+ with ex when precatchable_exception ex ->
+ matchrec c)
+ | Lambda (_,t,c) ->
+ (try
+ matchrec t
+ with ex when precatchable_exception ex ->
+ matchrec c)
+ | _ -> error "Match_subterm"))
+ in
+ try matchrec cl
+ with ex when precatchable_exception ex ->
+ raise (PretypeError (env,NoOccurrenceFound op))
+
+let w_unify_to_subterm_list env mod_delta allow_K oplist t evd =
+ List.fold_right
+ (fun op (evd,l) ->
+ if isMeta op then
+ if allow_K then (evd,op::l)
+ else error "Match_subterm"
+ else if occur_meta op then
+ let (evd',cl) =
+ try
+ (* This is up to delta for subterms w/o metas ... *)
+ w_unify_to_subterm env ~mod_delta (strip_outer_cast op,t) evd
+ with PretypeError (env,NoOccurrenceFound _) when allow_K -> (evd,op)
+ in
+ (evd',cl::l)
+ else if allow_K or dependent op t then
+ (evd,op::l)
+ else
+ (* This is not up to delta ... *)
+ raise (PretypeError (env,NoOccurrenceFound op)))
+ oplist
+ (evd,[])
+
+let secondOrderAbstraction env mod_delta allow_K typ (p, oplist) evd =
+ let sigma = evars_of evd in
+ let (evd',cllist) =
+ w_unify_to_subterm_list env mod_delta allow_K oplist typ evd in
+ let typp = Typing.meta_type evd' p in
+ let pred = abstract_list_all env sigma typp typ cllist in
+ w_unify_0 env CONV mod_delta (mkMeta p) pred evd'
+
+let w_unify2 env mod_delta allow_K cv_pb ty1 ty2 evd =
+ let c1, oplist1 = whd_stack ty1 in
+ let c2, oplist2 = whd_stack ty2 in
+ match kind_of_term c1, kind_of_term c2 with
+ | Meta p1, _ ->
+ (* Find the predicate *)
+ let evd' =
+ secondOrderAbstraction env mod_delta allow_K ty2 (p1,oplist1) evd in
+ (* Resume first order unification *)
+ w_unify_0 env cv_pb mod_delta (nf_meta evd' ty1) ty2 evd'
+ | _, Meta p2 ->
+ (* Find the predicate *)
+ let evd' =
+ secondOrderAbstraction env mod_delta allow_K ty1 (p2, oplist2) evd in
+ (* Resume first order unification *)
+ w_unify_0 env cv_pb mod_delta ty1 (nf_meta evd' ty2) evd'
+ | _ -> error "w_unify2"
+
+
+(* The unique unification algorithm works like this: If the pattern is
+ flexible, and the goal has a lambda-abstraction at the head, then
+ we do a first-order unification.
+
+ If the pattern is not flexible, then we do a first-order
+ unification, too.
+
+ If the pattern is flexible, and the goal doesn't have a
+ lambda-abstraction head, then we second-order unification. *)
+
+(* We decide here if first-order or second-order unif is used for Apply *)
+(* We apply a term of type (ai:Ai)C and try to solve a goal C' *)
+(* The type C is in clenv.templtyp.rebus with a lot of Meta to solve *)
+
+(* 3-4-99 [HH] New fo/so choice heuristic :
+ In case we have to unify (Meta(1) args) with ([x:A]t args')
+ we first try second-order unification and if it fails first-order.
+ Before, second-order was used if the type of Meta(1) and [x:A]t was
+ convertible and first-order otherwise. But if failed if e.g. the type of
+ Meta(1) had meta-variables in it. *)
+let w_unify allow_K env cv_pb ?(mod_delta=true) ty1 ty2 evd =
+ let hd1,l1 = whd_stack ty1 in
+ let hd2,l2 = whd_stack ty2 in
+ match kind_of_term hd1, l1<>[], kind_of_term hd2, l2<>[] with
+ (* Pattern case *)
+ | (Meta _, true, Lambda _, _ | Lambda _, _, Meta _, true)
+ when List.length l1 = List.length l2 ->
+ (try
+ w_typed_unify env cv_pb mod_delta ty1 ty2 evd
+ with ex when precatchable_exception ex ->
+ try
+ w_unify2 env mod_delta allow_K cv_pb ty1 ty2 evd
+ with PretypeError (env,NoOccurrenceFound c) as e -> raise e
+ | ex when precatchable_exception ex ->
+ error "Cannot solve a second-order unification problem")
+
+ (* Second order case *)
+ | (Meta _, true, _, _ | _, _, Meta _, true) ->
+ (try
+ w_unify2 env mod_delta allow_K cv_pb ty1 ty2 evd
+ with PretypeError (env,NoOccurrenceFound c) as e -> raise e
+ | ex when precatchable_exception ex ->
+ try
+ w_typed_unify env cv_pb mod_delta ty1 ty2 evd
+ with ex when precatchable_exception ex ->
+ error "Cannot solve a second-order unification problem")
+
+ (* General case: try first order *)
+ | _ -> w_unify_0 env cv_pb mod_delta ty1 ty2 evd
+
diff --git a/pretyping/unification.mli b/pretyping/unification.mli
new file mode 100644
index 00000000..6be530be
--- /dev/null
+++ b/pretyping/unification.mli
@@ -0,0 +1,33 @@
+(************************************************************************)
+(* v * The Coq Proof Assistant / The Coq Development Team *)
+(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
+(* \VV/ **************************************************************)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(************************************************************************)
+
+(*i $Id: unification.mli 6142 2004-09-27 19:33:01Z sacerdot $ i*)
+
+(*i*)
+open Term
+open Environ
+open Evd
+(*i*)
+
+(* The "unique" unification fonction *)
+val w_unify :
+ bool -> env -> conv_pb -> ?mod_delta:bool -> constr -> constr -> evar_defs -> evar_defs
+
+(* [w_unify_to_subterm env (c,t) m] performs unification of [c] with a
+ subterm of [t]. Constraints are added to [m] and the matched
+ subterm of [t] is also returned. *)
+val w_unify_to_subterm :
+ env -> ?mod_delta:bool -> constr * constr -> evar_defs -> evar_defs * constr
+
+(*i This should be in another module i*)
+
+(* [abstract_list_all env sigma t c l] *)
+(* abstracts the terms in l over c to get a term of type t *)
+(* (exported for inv.ml) *)
+val abstract_list_all :
+ env -> evar_map -> constr -> constr -> constr list -> constr