diff -r a113b6839df1 -r a87c0aeae92f src/Pure/Tools/class_package.ML
--- a/src/Pure/Tools/class_package.ML	Tue Jan 31 10:39:13 2006 +0100
+++ b/src/Pure/Tools/class_package.ML	Tue Jan 31 16:12:56 2006 +0100
@@ -37,6 +37,7 @@
                       | Lookup of class list * (string * int)
   val extract_sortctxt: theory -> typ -> sortcontext
   val extract_sortlookup: theory -> string * typ -> sortlookup list list
+  val extract_sortlookup_inst: theory -> class * string -> class -> sortlookup list list
 end;
 
 structure ClassPackage: CLASS_PACKAGE =
@@ -385,9 +386,8 @@
 datatype sortlookup = Instance of (class * string) * sortlookup list list
                     | Lookup of class list * (string * int)
 
-fun extract_sortlookup thy (c, raw_typ_use) =
+fun extract_lookup thy sortctxt raw_typ_def raw_typ_use =
   let
-    val raw_typ_def = Sign.the_const_constraint thy c;
     val typ_def = Type.varifyT raw_typ_def;
     val typ_use = Type.varifyT raw_typ_use;
     val match_tab = Sign.typ_match thy (typ_def, typ_use) Vartab.empty;
@@ -411,6 +411,19 @@
               let val (deriv, classindex) = mk_class_deriv thy (syntactic_sort_of thy sort_use) class
               in Lookup (deriv, (vname, classindex)) end;
           in map mk_look sort_def end;
+
+  in
+    sortctxt
+    |> map (tab_lookup o fst)
+    |> map (apfst (syntactic_sort_of thy))
+    |> filter (not o null o fst)
+    |> map mk_lookup
+  end;
+
+fun extract_sortlookup thy (c, raw_typ_use) =
+  let
+    val raw_typ_def = Sign.the_const_constraint thy c;
+    val typ_def = Type.varifyT raw_typ_def;
     fun reorder_sortctxt ctxt =
       case lookup_const_class thy c
        of NONE => ctxt
@@ -425,14 +438,19 @@
               (v, (the o AList.lookup (op =) ctxt) v) :: AList.delete (op =) v ctxt
             end;
   in
-    extract_sortctxt thy ((fst o Type.freeze_thaw_type) raw_typ_def)
-    |> reorder_sortctxt
-    |> map (tab_lookup o fst)
-    |> map (apfst (syntactic_sort_of thy))
-    |> filter (not o null o fst)
-    |> map mk_lookup
+    extract_lookup thy
+      (reorder_sortctxt (extract_sortctxt thy ((fst o Type.freeze_thaw_type) raw_typ_def)))
+      raw_typ_def raw_typ_use
   end;
 
+fun extract_sortlookup_inst thy (class, tyco) supclass =
+  let
+    fun mk_typ class = Type (tyco, (map TFree o fst o the_inst_sign thy) (class, tyco))
+    val typ_def = mk_typ class;
+    val typ_use = mk_typ supclass;
+  in
+    extract_lookup thy (extract_sortctxt thy typ_def) typ_def typ_use
+  end;
 
 (* intermediate auxiliary *)