in
C.Prod (name,s',t'),sop,subst''',metasenv''',ugraph3
| C.Lambda (n,s,t) ->
-
let s',sort1,subst',metasenv',ugraph1 =
type_of_aux subst metasenv context s ugraph in
let s',sort1,subst',metasenv',ugraph1 =
(* TODO: check if the sort elimination
* is allowed: [(I q1 ... qr)|B] *)
let (pl',_,outtypeinstances,subst,metasenv,ugraph4) =
- List.fold_left
- (fun (pl,j,outtypeinstances,subst,metasenv,ugraph) p ->
+ List.fold_right
+ (fun p (pl,j,outtypeinstances,subst,metasenv,ugraph) ->
let constructor =
if left_args = [] then
(C.MutConstruct (uri,i,j,exp_named_subst))
type_of_aux subst metasenv context constructor ugraph1
in
let outtypeinstance,subst,metasenv,ugraph3 =
- check_branch 0 context metasenv subst no_left_params
- actual_type constructor' expected_type ugraph2
+ try
+ check_branch 0 context metasenv subst
+ no_left_params actual_type constructor' expected_type
+ ugraph2
+ with
+ exn ->
+ enrich localization_tbl constructor'
+ ~f:(fun _ ->
+ lazy ("The term " ^
+ CicMetaSubst.ppterm_in_context metasenv subst p'
+ context ^ " has type " ^
+ CicMetaSubst.ppterm_in_context metasenv subst actual_type
+ context ^ " but is here used with type " ^
+ CicMetaSubst.ppterm_in_context metasenv subst expected_type
+ context)) exn
in
- (pl @ [p'],j+1,
- outtypeinstance::outtypeinstances,subst,metasenv,ugraph3))
- ([],1,[],subst,metasenv,ugraph3) pl
+ (p'::pl,j-1,
+ outtypeinstances@[outtypeinstance],subst,metasenv,ugraph3))
+ pl ([],List.length pl,[],subst,metasenv,ugraph3)
in
(* we are left to check that the outype matches his instances.
(C.Appl(outtype::right_args@[term]))),
subst,metasenv,ugraph6)
| C.Fix (i,fl) ->
- let fl_ty',subst,metasenv,types,ugraph1 =
+ let fl_ty',subst,metasenv,types,ugraph1,len =
List.fold_left
- (fun (fl,subst,metasenv,types,ugraph) (n,_,ty,_) ->
+ (fun (fl,subst,metasenv,types,ugraph,len) (n,_,ty,_) ->
let ty',_,subst',metasenv',ugraph1 =
type_of_aux subst metasenv context ty ugraph
in
fl @ [ty'],subst',metasenv',
- Some (C.Name n,(C.Decl ty')) :: types, ugraph
- ) ([],subst,metasenv,[],ugraph) fl
+ Some (C.Name n,(C.Decl (CicSubstitution.lift len ty')))
+ :: types, ugraph, len+1
+ ) ([],subst,metasenv,[],ugraph,0) fl
in
- let len = List.length types in
let context' = types@context in
let fl_bo',subst,metasenv,ugraph2 =
List.fold_left
in
C.Fix (i,fl''),ty,subst,metasenv,ugraph2
| C.CoFix (i,fl) ->
- let fl_ty',subst,metasenv,types,ugraph1 =
+ let fl_ty',subst,metasenv,types,ugraph1,len =
List.fold_left
- (fun (fl,subst,metasenv,types,ugraph) (n,ty,_) ->
+ (fun (fl,subst,metasenv,types,ugraph,len) (n,ty,_) ->
let ty',_,subst',metasenv',ugraph1 =
type_of_aux subst metasenv context ty ugraph
in
fl @ [ty'],subst',metasenv',
- Some (C.Name n,(C.Decl ty')) :: types, ugraph1
- ) ([],subst,metasenv,[],ugraph) fl
+ Some (C.Name n,(C.Decl (CicSubstitution.lift len ty'))) ::
+ types, ugraph1, len+1
+ ) ([],subst,metasenv,[],ugraph,0) fl
in
- let len = List.length types in
let context' = types@context in
let fl_bo',subst,metasenv,ugraph2 =
List.fold_left
he
in
let x,xty,subst,metasenv,ugraph =
- type_of_aux subst metasenv context x ugraph
+ (*CSC: here unsharing is necessary to avoid an unwanted
+ relocalization. However, this also shows a great source of
+ inefficiency: "x" is refined twice (once now and once in the
+ subsequent eat_prods_and_args). Morevoer, how is divergence avoided?
+ *)
+ type_of_aux subst metasenv context (Unshare.unshare x) ugraph
in
let carr_src =
CoercDb.coerc_carr_of_term (CicMetaSubst.apply_subst subst xty)
| C.LetIn (name,so,dest) ->
let _,ty,metasenv,ugraph =
pack_coercions := false;
- type_of_aux' metasenv ctx so CicUniv.empty_ugraph in
+ type_of_aux' metasenv ctx so CicUniv.oblivion_ugraph in
pack_coercions := true;
let ctx' = Some (name,(C.Def (so,Some ty)))::ctx in
C.LetIn (name, merge_coercions ctx so, merge_coercions ctx' dest)
let b,_,_,_,_ = is_a_double_coercion t in
(* prerr_endline "CANDIDATO!!!!"; *)
if b then
- let ugraph = CicUniv.empty_ugraph in
+ let ugraph = CicUniv.oblivion_ugraph in
let old_insert_coercions = !insert_coercions in
insert_coercions := false;
let newt, _, menv, _ =