diff -r fb7fe6aca6f0 -r c4fa87dd0208 Quot/quotient_term.ML --- a/Quot/quotient_term.ML Mon Jan 11 01:03:34 2010 +0100 +++ b/Quot/quotient_term.ML Mon Jan 11 11:51:19 2010 +0100 @@ -411,26 +411,29 @@ end | (_, Const _) => - let - fun same_name (Const (s, T)) (Const (s', T')) = (s = s') (*andalso (T = T')*) - | same_name _ _ = false - (* TODO/FIXME: This test is not enough. *) - (* Why? *) - (* Because constants can have the same name but not be the same - constant. All overloaded constants have the same name but because - of different types they do differ. - - This code will let one write a theorem where plus on nat is - matched to plus on int, even if the latter is defined differently. - - This would result in hard to understand failures in injection and - cleaning. *) - (* cu: if I also test the type, then something else breaks *) + let + val thy = ProofContext.theory_of ctxt + fun matches_typ T T' = ( + let + val rty = #rtyp (quotdata_lookup_type thy T') + in + if Sign.typ_instance thy (T, rty) then true else T = T' + end + handle Not_found => (* raised by quotdata_lookup_type *) + case (T, T') of + (TFree _, TFree _) => true + | (TVar _, TVar _) => true + | (Type (s, tys), Type (s', tys')) => + (* 'andalso' is buildin syntax so it needs to be expanded *) + fold (fn x => fn y => x andalso y) (map2 matches_typ tys tys') (s = s') + handle UnequalLengths => false + ) + fun same_const (Const (s, T)) (Const (s', T')) = (s = s') andalso matches_typ T T' + | same_const _ _ = false in - if same_name rtrm qtrm then rtrm - else - let - val thy = ProofContext.theory_of ctxt + if same_const rtrm qtrm then rtrm + else + let val qtrm_str = Syntax.string_of_term ctxt qtrm val exc1 = LIFT_MATCH ("regularize (constant " ^ qtrm_str ^ " not found)") val exc2 = LIFT_MATCH ("regularize (constant " ^ qtrm_str ^ " mismatch)")