diff options
Diffstat (limited to 'kernel/term_typing.ml')
| -rw-r--r-- | kernel/term_typing.ml | 41 |
1 files changed, 20 insertions, 21 deletions
diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index 5347583f..fde5fa25 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* $Id: term_typing.ml,v 1.5.6.1 2004/07/16 19:30:27 herbelin Exp $ *) +(* $Id: term_typing.ml 7639 2005-12-02 10:01:15Z gregoire $ *) open Util open Names @@ -26,15 +26,9 @@ let constrain_type env j cst1 = function | None -> j.uj_type, cst1 | Some t -> let (tj,cst2) = infer_type env t in - let cst3 = - try conv_leq env j.uj_type tj.utj_val - with NotConvertible -> error_actual_type env j tj.utj_val in - let typ = - if t = tj.utj_val then t else - (error "Kernel built a type different from its input\n"; - flush stdout; tj.utj_val) in - typ, Constraint.union (Constraint.union cst1 cst2) cst3 - + let (_,cst3) = judge_of_cast env j DEFAULTcast tj in + assert (t = tj.utj_val); + t, Constraint.union (Constraint.union cst1 cst2) cst3 let translate_local_def env (b,topt) = let (j,cst) = infer env b in @@ -85,33 +79,38 @@ let infer_declaration env dcl = | DefinitionEntry c -> let (j,cst) = infer env c.const_entry_body in let (typ,cst) = constrain_type env j cst c.const_entry_type in - Some (Declarations.from_val j.uj_val), typ, cst, c.const_entry_opaque + Some (Declarations.from_val j.uj_val), typ, cst, + c.const_entry_opaque, c.const_entry_boxed | ParameterEntry t -> let (j,cst) = infer env t in - None, Typeops.assumption_of_judgment env j, cst, false + None, Typeops.assumption_of_judgment env j, cst, false, false -let build_constant_declaration env (body,typ,cst,op) = - let ids = match body with +let build_constant_declaration env kn (body,typ,cst,op,boxed) = + let ids = + match body with | None -> global_vars_set env typ | Some b -> Idset.union (global_vars_set env (Declarations.force b)) - (global_vars_set env typ) + (global_vars_set env typ) in + let tps = Cemitcodes.from_val (compile_constant_body env body op boxed) in let hyps = keep_hyps env ids in - { const_body = body; + { const_hyps = hyps; + const_body = body; const_type = typ; - const_hyps = hyps; + const_body_code = tps; + (* const_type_code = to_patch env typ;*) const_constraints = cst; const_opaque = op } (*s Global and local constant declaration. *) -let translate_constant env ce = - build_constant_declaration env (infer_declaration env ce) +let translate_constant env kn ce = + build_constant_declaration env kn (infer_declaration env ce) -let translate_recipe env r = - build_constant_declaration env (Cooking.cook_constant env r) +let translate_recipe env kn r = + build_constant_declaration env kn (Cooking.cook_constant env r) (* Insertion of inductive types. *) |