aux 0
;;
-
let sort_of_prod ~subst context (name,s) (t1, t2) =
let t1 = R.whd ~subst context t1 in
let t2 = R.whd ~subst ((name,C.Decl s)::context) t2 in
if not (List.length tl > rec_no) then raise NotGuarded
else
let rec_arg = List.nth tl rec_no in
- aux k rec_arg;
+ if not (is_really_smaller ~subst k rec_arg) then raise
+ NotGuarded;
List.iter (aux k) tl
| C.Match (Ref.Ref (_,uri,_) as ref,outtype,term,pl) as t ->
(match R.whd ~subst context term with
| _ -> raise (AssertFailure (lazy "split_prods"))
(*CSC: Tutto quello che segue e' l'intuzione di luca ;-) *)
-and check_is_really_smaller_arg ~subst context n nn kl x safes te =
-assert false (*
- (*CSC: forse la whd si puo' fare solo quando serve veramente. *)
- (*CSC: cfr guarded_by_destructors *)
- let module C = Cic in
- let module U = UriManager in
- match CicReduction.whd ~subst context te with
- C.Rel m when List.mem m safes -> true
- | C.Rel _ -> false
- | C.Var _
- | C.Meta _
- | C.Sort _
- | C.Implicit _
- | C.Cast _
-(* | C.Cast (te,ty) ->
- check_is_really_smaller_arg ~subst n nn kl x safes te &&
- check_is_really_smaller_arg ~subst n nn kl x safes ty*)
-(* | C.Prod (_,so,ta) ->
- check_is_really_smaller_arg ~subst n nn kl x safes so &&
- check_is_really_smaller_arg ~subst (n+1) (nn+1) kl (x+1)
- (List.map (fun x -> x + 1) safes) ta*)
- | C.Prod _ -> raise (AssertFailure (lazy "10"))
- | C.Lambda (name,so,ta) ->
- check_is_really_smaller_arg ~subst context n nn kl x safes so &&
- check_is_really_smaller_arg ~subst ((Some (name,(C.Decl so)))::context)
- (n+1) (nn+1) kl (x+1) (List.map (fun x -> x + 1) safes) ta
- | C.LetIn (name,so,ty,ta) ->
- check_is_really_smaller_arg ~subst context n nn kl x safes so &&
- check_is_really_smaller_arg ~subst context n nn kl x safes ty &&
- check_is_really_smaller_arg ~subst ((Some (name,(C.Def (so,ty))))::context)
- (n+1) (nn+1) kl (x+1) (List.map (fun x -> x + 1) safes) ta
- | C.Appl (he::_) ->
- (*CSC: sulla coda ci vogliono dei controlli? secondo noi no, ma *)
- (*CSC: solo perche' non abbiamo trovato controesempi *)
- check_is_really_smaller_arg ~subst context n nn kl x safes he
- | C.Appl [] -> raise (AssertFailure (lazy "11"))
- | C.Const _
- | C.MutInd _ -> raise (AssertFailure (lazy "12"))
- | C.MutConstruct _ -> false
- | C.MutCase (uri,i,outtype,term,pl) ->
- (match term with
- C.Rel m when List.mem m safes || m = x ->
- let (lefts_and_tys,len,isinductive,paramsno,cl) =
- let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
- match o with
- C.InductiveDefinition (tl,_,paramsno,_) ->
- let tys =
- List.map
- (fun (n,_,ty,_) -> Some (Cic.Name n,(Cic.Decl ty))) tl
- in
- let (_,isinductive,_,cl) = List.nth tl i in
- let cl' =
- List.map
- (fun (id,ty) ->
- (id, snd (split_prods ~subst tys paramsno ty))) cl in
- let lefts =
- match tl with
- [] -> assert false
- | (_,_,ty,_)::_ ->
- fst (split_prods ~subst [] paramsno ty)
- in
- (tys@lefts,List.length tl,isinductive,paramsno,cl')
- | _ ->
- raise (TypeCheckerFailure
- (lazy ("Unknown mutual inductive definition:" ^
- UriManager.string_of_uri uri)))
- in
- if not isinductive then
- List.fold_right
- (fun p i ->
- i && check_is_really_smaller_arg ~subst context n nn kl x safes p)
- pl true
- else
- let pl_and_cl =
- try
- List.combine pl cl
- with
- Invalid_argument _ ->
- raise (TypeCheckerFailure (lazy "not enough patterns"))
- in
- (*CSC: supponiamo come prima che nessun controllo sia necessario*)
- (*CSC: sugli argomenti di una applicazione *)
- List.fold_right
- (fun (p,(_,c)) i ->
- let rl' =
- let debruijnedte = debruijn uri len c in
- recursive_args lefts_and_tys 0 len debruijnedte
- in
- let (e,safes',n',nn',x',context') =
- get_new_safes ~subst context p c rl' safes n nn x
- in
- i &&
- check_is_really_smaller_arg ~subst context' n' nn' kl x' safes' e
- ) pl_and_cl true
- | C.Appl ((C.Rel m)::tl) when List.mem m safes || m = x ->
- let (lefts_and_tys,len,isinductive,paramsno,cl) =
- let o,_ = CicEnvironment.get_obj CicUniv.empty_ugraph uri in
- match o with
- C.InductiveDefinition (tl,_,paramsno,_) ->
- let (_,isinductive,_,cl) = List.nth tl i in
- let tys =
- List.map (fun (n,_,ty,_) ->
- Some(Cic.Name n,(Cic.Decl ty))) tl
- in
- let cl' =
- List.map
- (fun (id,ty) ->
- (id, snd (split_prods ~subst tys paramsno ty))) cl in
- let lefts =
- match tl with
- [] -> assert false
- | (_,_,ty,_)::_ ->
- fst (split_prods ~subst [] paramsno ty)
- in
- (tys@lefts,List.length tl,isinductive,paramsno,cl')
- | _ ->
- raise (TypeCheckerFailure
- (lazy ("Unknown mutual inductive definition:" ^
- UriManager.string_of_uri uri)))
- in
- if not isinductive then
- List.fold_right
- (fun p i ->
- i && check_is_really_smaller_arg ~subst context n nn kl x safes p)
- pl true
- else
- let pl_and_cl =
- try
- List.combine pl cl
- with
- Invalid_argument _ ->
- raise (TypeCheckerFailure (lazy "not enough patterns"))
- in
- (*CSC: supponiamo come prima che nessun controllo sia necessario*)
- (*CSC: sugli argomenti di una applicazione *)
- List.fold_right
- (fun (p,(_,c)) i ->
- let rl' =
- let debruijnedte = debruijn uri len c in
- recursive_args lefts_and_tys 0 len debruijnedte
- in
- let (e,safes',n',nn',x',context') =
- get_new_safes ~subst context p c rl' safes n nn x
- in
- i &&
- check_is_really_smaller_arg ~subst context' n' nn' kl x' safes' e
- ) pl_and_cl true
- | _ ->
- List.fold_right
- (fun p i ->
- i && check_is_really_smaller_arg ~subst context n nn kl x safes p
- ) pl true
- )
- | C.Fix (_, fl) ->
+and is_really_smaller ~subst (context, recfuns, x, safes as k) te =
+ match R.whd ~subst context te with
+ | C.Rel m when List.mem m safes -> true
+ | C.Rel _ -> false
+ | C.LetIn _ -> raise (AssertFailure (lazy "letin after whd"))
+ | C.Sort _ | C.Implicit _ | C.Prod _ | C.Lambda _
+ | C.Const (Ref.Ref (_,_,(Ref.Decl | Ref.Def | Ref.Ind _ | Ref.CoFix _))) ->
+ raise (AssertFailure (lazy "not a constructor"))
+ | C.Appl ([]|[_]) -> raise (AssertFailure (lazy "empty/unary appl"))
+ | C.Appl (he::_) ->
+ (*CSC: sulla coda ci vogliono dei controlli? secondo noi no, ma *)
+ (*CSC: solo perche' non abbiamo trovato controesempi *)
+ is_really_smaller ~subst k he
+ | C.Const (Ref.Ref (_,_,Ref.Con _)) -> false
+ | C.Const (Ref.Ref (_,_,Ref.Fix _)) -> assert false
+ (*| C.Fix (_, fl) ->
let len = List.length fl in
let n_plus_len = n + len
and nn_plus_len = nn + len
List.fold_right
(fun (_,_,ty,bo) i ->
i &&
- check_is_really_smaller_arg ~subst (tys@context) n_plus_len nn_plus_len kl
- x_plus_len safes' bo
- ) fl true
- | C.CoFix (_, fl) ->
- let len = List.length fl in
- let n_plus_len = n + len
- and nn_plus_len = nn + len
- and x_plus_len = x + len
- and tys,_ =
- List.fold_left
- (fun (types,len) (n,ty,_) ->
- (Some (C.Name n,(C.Decl (CicSubstitution.lift len ty)))::types,
- len+1)
- ) ([],0) fl
- and safes' = List.map (fun x -> x + len) safes in
- List.fold_right
- (fun (_,ty,bo) i ->
- i &&
- check_is_really_smaller_arg ~subst (tys@context) n_plus_len nn_plus_len kl
+ is_really_smaller ~subst (tys@context) n_plus_len nn_plus_len kl
x_plus_len safes' bo
- ) fl true
- *)
+ ) fl true*)
+ | C.Meta _ ->
+ true (* XXX if this check is repeated when the user completes the
+ definition *)
+ | C.Match (Ref.Ref (_,uri,_) as ref,outtype,term,pl) ->
+ (match term with
+ | C.Rel m | C.Appl (C.Rel m :: _ ) when List.mem m safes || m = x ->
+ let isinductive, paramsno, tl, _, i = E.get_checked_indtys ref in
+ if not isinductive then
+ List.for_all (is_really_smaller ~subst k) pl
+ else
+ let c_ctx,len,cl = fix_lefts_in_constrs ~subst uri paramsno tl i in
+ List.for_all2
+ (fun p (_,_,debruijnedte) ->
+ let rl' = recursive_args ~subst c_ctx 0 len debruijnedte in
+ let e, k = get_new_safes ~subst k p rl' in
+ is_really_smaller ~subst k e)
+ pl cl
+ | _ -> List.for_all (is_really_smaller ~subst k) pl)
and returns_a_coinductive ~subst _ _ = assert false
-(* Copyright (C) 2000, HELM Team.
- *
- * This file is part of HELM, an Hypertextual, Electronic
- * Library of Mathematics, developed at the Computer Science
- * Department, University of Bologna, Italy.
- *
- * HELM is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License
- * as published by the Free Software Foundation; either version 2
- * of the License, or (at your option) any later version.
- *
- * HELM is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with HELM; if not, write to the Free Software
- * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
- * MA 02111-1307, USA.
- *
- * For details, see the HELM World-Wide-Web page,
- * http://cs.unibo.it/helm/.
- *)
+(*
+ ||M|| This file is part of HELM, an Hypertextual, Electronic
+ ||A|| Library of Mathematics, developed at the Computer Science
+ ||T|| Department, University of Bologna, Italy.
+ ||I||
+ ||T|| HELM is free software; you can redistribute it and/or
+ ||A|| modify it under the terms of the GNU General Public License
+ \ / version 2 or (at your option) any later version.
+ \ / This software is distributed as is, NO WARRANTY.
+ V_______________________________________________________________ *)
+
+(* $Id$ *)
exception IllFormedReference of string Lazy.t
projects / helm.git / commitdiff