diff --git a/src/Pure/General/graph_display.ML b/src/Pure/General/graph_display.ML
--- a/src/Pure/General/graph_display.ML
+++ b/src/Pure/General/graph_display.ML
@@ -1,101 +1,102 @@
 (*  Title:      Pure/General/graph_display.ML
     Author:     Makarius
 
 Support for graph display.
 *)
 
 signature GRAPH_DISPLAY =
 sig
   type node
   val content_node: string -> Pretty.T list -> node
   val session_node: {name: string, unfold: bool, directory: string, path: string} -> node
   type entry = (string * node) * string list
   val display_graph: entry list -> unit
   val display_graph_old: entry list -> unit
 end;
 
 structure Graph_Display: GRAPH_DISPLAY =
 struct
 
 (* graph entries *)
 
 datatype node =
   Node of {name: string, content: Pretty.T list, unfold: bool, directory: string, path: string};
 
 fun content_node name content =
   Node {name = name, content = content, unfold = true, directory = "", path = ""};
 
 fun session_node {name, unfold, directory, path} =
   Node {name = name, content = [], unfold = unfold, directory = directory, path = path};
 
 type entry = (string * node) * string list;
 
 
 (* display graph *)
 
 local
 
 fun encode_node (Node {name, content, ...}) =
   (name, content) |>
     let open XML.Encode
     in pair string (YXML.parse_body o Pretty.symbolic_string_of o Pretty.chunks) end;
 
 val encode_graph =
   let open XML.Encode in list (pair (pair string encode_node) (list string)) end;
 
 in
 
 fun display_graph entries =
   let
     val ((bg1, bg2), en) =
       YXML.output_markup_elem
         (Active.make_markup Markup.graphviewN {implicit = false, properties = []});
   in writeln ("See " ^ bg1 ^ YXML.string_of_body (encode_graph entries) ^ bg2 ^ "graph" ^ en) end;
 
 end;
 
 
 (* support for old browser *)
 
 local
 
 structure Graph =
   Graph(type key = string * string val ord = prod_ord string_ord string_ord);
 
 fun build_graph entries =
   let
     val ident_names =
-      fold (fn ((ident, Node {name, ...}), _) => Symtab.update_new (ident, (name, ident)))
-        entries Symtab.empty;
+      Symtab.build
+        (entries |> fold (fn ((ident, Node {name, ...}), _) =>
+          Symtab.update_new (ident, (name, ident))));
     val the_key = the o Symtab.lookup ident_names;
   in
     Graph.empty
     |> fold (fn ((ident, node), _) => Graph.new_node (the_key ident, node)) entries
     |> fold (fn ((ident, _), parents) =>
         fold (fn parent => Graph.add_edge (the_key parent, the_key ident)) parents) entries
   end;
 
 val sort_graph = build_graph #> (fn graph =>
   Graph.topological_order graph |> map (fn key =>
     let val (_, (node, (preds, _))) = Graph.get_entry graph key
     in ((#2 key, node), map #2 (Graph.Keys.dest preds)) end));
 
 val encode_browser =
   sort_graph
   #> map (fn ((key, Node {name, unfold, content = _, directory, path}), parents) =>
     "\"" ^ name ^ "\" \"" ^ key ^ "\" \"" ^ directory ^ (if unfold then "\" + \"" else "\" \"") ^
     path ^ "\" > " ^ space_implode " " (map quote parents) ^ " ;")
   #> cat_lines;
 
 in
 
 fun display_graph_old entries =
   let
     val ((bg1, bg2), en) =
       YXML.output_markup_elem
         (Active.make_markup Markup.browserN {implicit = false, properties = []});
   in writeln ("See " ^ bg1 ^ encode_browser entries ^ bg2 ^ "graph" ^ en) end;
 
 end;
 
 end;
diff --git a/src/Pure/General/table.ML b/src/Pure/General/table.ML
--- a/src/Pure/General/table.ML
+++ b/src/Pure/General/table.ML
@@ -1,476 +1,479 @@
 (*  Title:      Pure/General/table.ML
     Author:     Markus Wenzel and Stefan Berghofer, TU Muenchen
 
 Generic tables.  Efficient purely functional implementation using
 balanced 2-3 trees.
 *)
 
 signature KEY =
 sig
   type key
   val ord: key ord
 end;
 
 signature TABLE =
 sig
   type key
   type 'a table
   exception DUP of key
   exception SAME
   exception UNDEF of key
   val empty: 'a table
+  val build: ('a table -> 'a table) -> 'a table
   val is_empty: 'a table -> bool
   val is_single: 'a table -> bool
   val map: (key -> 'a -> 'b) -> 'a table -> 'b table
   val fold: (key * 'b -> 'a -> 'a) -> 'b table -> 'a -> 'a
   val fold_rev: (key * 'b -> 'a -> 'a) -> 'b table -> 'a -> 'a
   val size: 'a table -> int
   val dest: 'a table -> (key * 'a) list
   val keys: 'a table -> key list
   val min: 'a table -> (key * 'a) option
   val max: 'a table -> (key * 'a) option
   val exists: (key * 'a -> bool) -> 'a table -> bool
   val forall: (key * 'a -> bool) -> 'a table -> bool
   val get_first: (key * 'a -> 'b option) -> 'a table -> 'b option
   val lookup_key: 'a table -> key -> (key * 'a) option
   val lookup: 'a table -> key -> 'a option
   val defined: 'a table -> key -> bool
   val update: key * 'a -> 'a table -> 'a table
   val update_new: key * 'a -> 'a table -> 'a table                     (*exception DUP*)
   val default: key * 'a -> 'a table -> 'a table
   val map_entry: key -> ('a -> 'a) (*exception SAME*) -> 'a table -> 'a table
   val map_default: key * 'a -> ('a -> 'a) -> 'a table -> 'a table
   val make: (key * 'a) list -> 'a table                                (*exception DUP*)
   val join: (key -> 'a * 'a -> 'a) (*exception SAME*) ->
     'a table * 'a table -> 'a table                                    (*exception DUP*)
   val merge: ('a * 'a -> bool) -> 'a table * 'a table -> 'a table      (*exception DUP*)
   val delete: key -> 'a table -> 'a table                              (*exception UNDEF*)
   val delete_safe: key -> 'a table -> 'a table
   val member: ('b * 'a -> bool) -> 'a table -> key * 'b -> bool
   val insert: ('a * 'a -> bool) -> key * 'a -> 'a table -> 'a table    (*exception DUP*)
   val remove: ('b * 'a -> bool) -> key * 'b -> 'a table -> 'a table
   val lookup_list: 'a list table -> key -> 'a list
   val cons_list: key * 'a -> 'a list table -> 'a list table
   val insert_list: ('a * 'a -> bool) -> key * 'a -> 'a list table -> 'a list table
   val remove_list: ('b * 'a -> bool) -> key * 'b -> 'a list table -> 'a list table
   val update_list: ('a * 'a -> bool) -> key * 'a -> 'a list table -> 'a list table
   val make_list: (key * 'a) list -> 'a list table
   val dest_list: 'a list table -> (key * 'a) list
   val merge_list: ('a * 'a -> bool) -> 'a list table * 'a list table -> 'a list table
   type set = unit table
   val insert_set: key -> set -> set
   val remove_set: key -> set -> set
   val make_set: key list -> set
   val subset: set * set -> bool
   val eq_set: set * set -> bool
 end;
 
 functor Table(Key: KEY): TABLE =
 struct
 
 
 (* datatype table *)
 
 type key = Key.key;
 
 datatype 'a table =
   Empty |
   Branch2 of 'a table * (key * 'a) * 'a table |
   Branch3 of 'a table * (key * 'a) * 'a table * (key * 'a) * 'a table;
 
 exception DUP of key;
 
 
 (* empty and single *)
 
 val empty = Empty;
 
+fun build (f: 'a table -> 'a table) = f empty;
+
 fun is_empty Empty = true
   | is_empty _ = false;
 
 fun is_single (Branch2 (Empty, _, Empty)) = true
   | is_single _ = false;
 
 
 (* map and fold combinators *)
 
 fun map_table f =
   let
     fun map Empty = Empty
       | map (Branch2 (left, (k, x), right)) =
           Branch2 (map left, (k, f k x), map right)
       | map (Branch3 (left, (k1, x1), mid, (k2, x2), right)) =
           Branch3 (map left, (k1, f k1 x1), map mid, (k2, f k2 x2), map right);
   in map end;
 
 fun fold_table f =
   let
     fun fold Empty x = x
       | fold (Branch2 (left, p, right)) x =
           fold right (f p (fold left x))
       | fold (Branch3 (left, p1, mid, p2, right)) x =
           fold right (f p2 (fold mid (f p1 (fold left x))));
   in fold end;
 
 fun fold_rev_table f =
   let
     fun fold Empty x = x
       | fold (Branch2 (left, p, right)) x =
           fold left (f p (fold right x))
       | fold (Branch3 (left, p1, mid, p2, right)) x =
           fold left (f p1 (fold mid (f p2 (fold right x))));
   in fold end;
 
 fun size tab = fold_table (fn _ => fn n => n + 1) tab 0;
 fun dest tab = fold_rev_table cons tab [];
 fun keys tab = fold_rev_table (cons o #1) tab [];
 
 
 (* min/max entries *)
 
 fun min Empty = NONE
   | min (Branch2 (Empty, p, _)) = SOME p
   | min (Branch3 (Empty, p, _, _, _)) = SOME p
   | min (Branch2 (left, _, _)) = min left
   | min (Branch3 (left, _, _, _, _)) = min left;
 
 fun max Empty = NONE
   | max (Branch2 (_, p, Empty)) = SOME p
   | max (Branch3 (_, _, _, p, Empty)) = SOME p
   | max (Branch2 (_, _, right)) = max right
   | max (Branch3 (_, _, _, _, right)) = max right;
 
 
 (* exists and forall *)
 
 fun exists pred =
   let
     fun ex Empty = false
       | ex (Branch2 (left, (k, x), right)) =
           ex left orelse pred (k, x) orelse ex right
       | ex (Branch3 (left, (k1, x1), mid, (k2, x2), right)) =
           ex left orelse pred (k1, x1) orelse ex mid orelse pred (k2, x2) orelse ex right;
   in ex end;
 
 fun forall pred = not o exists (not o pred);
 
 
 (* get_first *)
 
 fun get_first f =
   let
     fun get Empty = NONE
       | get (Branch2 (left, (k, x), right)) =
           (case get left of
             NONE =>
               (case f (k, x) of
                 NONE => get right
               | some => some)
           | some => some)
       | get (Branch3 (left, (k1, x1), mid, (k2, x2), right)) =
           (case get left of
             NONE =>
               (case f (k1, x1) of
                 NONE =>
                   (case get mid of
                     NONE =>
                       (case f (k2, x2) of
                         NONE => get right
                       | some => some)
                   | some => some)
               | some => some)
           | some => some);
   in get end;
 
 
 (* lookup *)
 
 fun lookup tab key =
   let
     fun look Empty = NONE
       | look (Branch2 (left, (k, x), right)) =
           (case Key.ord (key, k) of
             LESS => look left
           | EQUAL => SOME x
           | GREATER => look right)
       | look (Branch3 (left, (k1, x1), mid, (k2, x2), right)) =
           (case Key.ord (key, k1) of
             LESS => look left
           | EQUAL => SOME x1
           | GREATER =>
               (case Key.ord (key, k2) of
                 LESS => look mid
               | EQUAL => SOME x2
               | GREATER => look right));
   in look tab end;
 
 fun lookup_key tab key =
   let
     fun look Empty = NONE
       | look (Branch2 (left, (k, x), right)) =
           (case Key.ord (key, k) of
             LESS => look left
           | EQUAL => SOME (k, x)
           | GREATER => look right)
       | look (Branch3 (left, (k1, x1), mid, (k2, x2), right)) =
           (case Key.ord (key, k1) of
             LESS => look left
           | EQUAL => SOME (k1, x1)
           | GREATER =>
               (case Key.ord (key, k2) of
                 LESS => look mid
               | EQUAL => SOME (k2, x2)
               | GREATER => look right));
   in look tab end;
 
 fun defined tab key =
   let
     fun def Empty = false
       | def (Branch2 (left, (k, x), right)) =
           (case Key.ord (key, k) of
             LESS => def left
           | EQUAL => true
           | GREATER => def right)
       | def (Branch3 (left, (k1, x1), mid, (k2, x2), right)) =
           (case Key.ord (key, k1) of
             LESS => def left
           | EQUAL => true
           | GREATER =>
               (case Key.ord (key, k2) of
                 LESS => def mid
               | EQUAL => true
               | GREATER => def right));
   in def tab end;
 
 
 (* modify *)
 
 datatype 'a growth =
   Stay of 'a table |
   Sprout of 'a table * (key * 'a) * 'a table;
 
 exception SAME;
 
 fun modify key f tab =
   let
     fun modfy Empty = Sprout (Empty, (key, f NONE), Empty)
       | modfy (Branch2 (left, p as (k, x), right)) =
           (case Key.ord (key, k) of
             LESS =>
               (case modfy left of
                 Stay left' => Stay (Branch2 (left', p, right))
               | Sprout (left1, q, left2) => Stay (Branch3 (left1, q, left2, p, right)))
           | EQUAL => Stay (Branch2 (left, (k, f (SOME x)), right))
           | GREATER =>
               (case modfy right of
                 Stay right' => Stay (Branch2 (left, p, right'))
               | Sprout (right1, q, right2) =>
                   Stay (Branch3 (left, p, right1, q, right2))))
       | modfy (Branch3 (left, p1 as (k1, x1), mid, p2 as (k2, x2), right)) =
           (case Key.ord (key, k1) of
             LESS =>
               (case modfy left of
                 Stay left' => Stay (Branch3 (left', p1, mid, p2, right))
               | Sprout (left1, q, left2) =>
                   Sprout (Branch2 (left1, q, left2), p1, Branch2 (mid, p2, right)))
           | EQUAL => Stay (Branch3 (left, (k1, f (SOME x1)), mid, p2, right))
           | GREATER =>
               (case Key.ord (key, k2) of
                 LESS =>
                   (case modfy mid of
                     Stay mid' => Stay (Branch3 (left, p1, mid', p2, right))
                   | Sprout (mid1, q, mid2) =>
                       Sprout (Branch2 (left, p1, mid1), q, Branch2 (mid2, p2, right)))
               | EQUAL => Stay (Branch3 (left, p1, mid, (k2, f (SOME x2)), right))
               | GREATER =>
                   (case modfy right of
                     Stay right' => Stay (Branch3 (left, p1, mid, p2, right'))
                   | Sprout (right1, q, right2) =>
                       Sprout (Branch2 (left, p1, mid), p2, Branch2 (right1, q, right2)))));
 
   in
     (case modfy tab of
       Stay tab' => tab'
     | Sprout br => Branch2 br)
     handle SAME => tab
   end;
 
 fun update (key, x) tab = modify key (fn _ => x) tab;
 fun update_new (key, x) tab = modify key (fn NONE => x | SOME _ => raise DUP key) tab;
 fun default (key, x) tab = modify key (fn NONE => x | SOME _ => raise SAME) tab;
 fun map_entry key f = modify key (fn NONE => raise SAME | SOME x => f x);
 fun map_default (key, x) f = modify key (fn NONE => f x | SOME y => f y);
 
 
 (* delete *)
 
 exception UNDEF of key;
 
 local
 
 fun compare NONE (k2, _) = LESS
   | compare (SOME k1) (k2, _) = Key.ord (k1, k2);
 
 fun if_eq EQUAL x y = x
   | if_eq _ x y = y;
 
 fun del (SOME k) Empty = raise UNDEF k
   | del NONE (Branch2 (Empty, p, Empty)) = (p, (true, Empty))
   | del NONE (Branch3 (Empty, p, Empty, q, Empty)) =
       (p, (false, Branch2 (Empty, q, Empty)))
   | del k (Branch2 (Empty, p, Empty)) = (case compare k p of
       EQUAL => (p, (true, Empty)) | _ => raise UNDEF (the k))
   | del k (Branch3 (Empty, p, Empty, q, Empty)) = (case compare k p of
       EQUAL => (p, (false, Branch2 (Empty, q, Empty)))
     | _ => (case compare k q of
         EQUAL => (q, (false, Branch2 (Empty, p, Empty)))
       | _ => raise UNDEF (the k)))
   | del k (Branch2 (l, p, r)) = (case compare k p of
       LESS => (case del k l of
         (p', (false, l')) => (p', (false, Branch2 (l', p, r)))
       | (p', (true, l')) => (p', case r of
           Branch2 (rl, rp, rr) =>
             (true, Branch3 (l', p, rl, rp, rr))
         | Branch3 (rl, rp, rm, rq, rr) => (false, Branch2
             (Branch2 (l', p, rl), rp, Branch2 (rm, rq, rr)))))
     | ord => (case del (if_eq ord NONE k) r of
         (p', (false, r')) => (p', (false, Branch2 (l, if_eq ord p' p, r')))
       | (p', (true, r')) => (p', case l of
           Branch2 (ll, lp, lr) =>
             (true, Branch3 (ll, lp, lr, if_eq ord p' p, r'))
         | Branch3 (ll, lp, lm, lq, lr) => (false, Branch2
             (Branch2 (ll, lp, lm), lq, Branch2 (lr, if_eq ord p' p, r'))))))
   | del k (Branch3 (l, p, m, q, r)) = (case compare k q of
       LESS => (case compare k p of
         LESS => (case del k l of
           (p', (false, l')) => (p', (false, Branch3 (l', p, m, q, r)))
         | (p', (true, l')) => (p', (false, case (m, r) of
             (Branch2 (ml, mp, mr), Branch2 _) =>
               Branch2 (Branch3 (l', p, ml, mp, mr), q, r)
           | (Branch3 (ml, mp, mm, mq, mr), _) =>
               Branch3 (Branch2 (l', p, ml), mp, Branch2 (mm, mq, mr), q, r)
           | (Branch2 (ml, mp, mr), Branch3 (rl, rp, rm, rq, rr)) =>
               Branch3 (Branch2 (l', p, ml), mp, Branch2 (mr, q, rl), rp,
                 Branch2 (rm, rq, rr)))))
       | ord => (case del (if_eq ord NONE k) m of
           (p', (false, m')) =>
             (p', (false, Branch3 (l, if_eq ord p' p, m', q, r)))
         | (p', (true, m')) => (p', (false, case (l, r) of
             (Branch2 (ll, lp, lr), Branch2 _) =>
               Branch2 (Branch3 (ll, lp, lr, if_eq ord p' p, m'), q, r)
           | (Branch3 (ll, lp, lm, lq, lr), _) =>
               Branch3 (Branch2 (ll, lp, lm), lq,
                 Branch2 (lr, if_eq ord p' p, m'), q, r)
           | (_, Branch3 (rl, rp, rm, rq, rr)) =>
               Branch3 (l, if_eq ord p' p, Branch2 (m', q, rl), rp,
                 Branch2 (rm, rq, rr))))))
     | ord => (case del (if_eq ord NONE k) r of
         (q', (false, r')) =>
           (q', (false, Branch3 (l, p, m, if_eq ord q' q, r')))
       | (q', (true, r')) => (q', (false, case (l, m) of
           (Branch2 _, Branch2 (ml, mp, mr)) =>
             Branch2 (l, p, Branch3 (ml, mp, mr, if_eq ord q' q, r'))
         | (_, Branch3 (ml, mp, mm, mq, mr)) =>
             Branch3 (l, p, Branch2 (ml, mp, mm), mq,
               Branch2 (mr, if_eq ord q' q, r'))
         | (Branch3 (ll, lp, lm, lq, lr), Branch2 (ml, mp, mr)) =>
             Branch3 (Branch2 (ll, lp, lm), lq, Branch2 (lr, p, ml), mp,
               Branch2 (mr, if_eq ord q' q, r'))))));
 
 in
 
 fun delete key tab = snd (snd (del (SOME key) tab));
 fun delete_safe key tab = if defined tab key then delete key tab else tab;
 
 end;
 
 
 (* membership operations *)
 
 fun member eq tab (key, x) =
   (case lookup tab key of
     NONE => false
   | SOME y => eq (x, y));
 
 fun insert eq (key, x) =
   modify key (fn NONE => x | SOME y => if eq (x, y) then raise SAME else raise DUP key);
 
 fun remove eq (key, x) tab =
   (case lookup tab key of
     NONE => tab
   | SOME y => if eq (x, y) then delete key tab else tab);
 
 
 (* simultaneous modifications *)
 
 fun make entries = fold update_new entries empty;
 
 fun join f (table1, table2) =
   let
     fun add (key, y) tab = modify key (fn NONE => y | SOME x => f key (x, y)) tab;
   in
     if pointer_eq (table1, table2) then table1
     else if is_empty table1 then table2
     else fold_table add table2 table1
   end;
 
 fun merge eq = join (fn key => fn xy => if eq xy then raise SAME else raise DUP key);
 
 
 (* list tables *)
 
 fun lookup_list tab key = these (lookup tab key);
 
 fun cons_list (key, x) tab = modify key (fn NONE => [x] | SOME xs => x :: xs) tab;
 
 fun insert_list eq (key, x) =
   modify key (fn NONE => [x] | SOME xs => if Library.member eq xs x then raise SAME else x :: xs);
 
 fun remove_list eq (key, x) tab =
   map_entry key (fn xs => (case Library.remove eq x xs of [] => raise UNDEF key | ys => ys)) tab
   handle UNDEF _ => delete key tab;
 
 fun update_list eq (key, x) =
   modify key (fn NONE => [x] | SOME [] => [x] | SOME (xs as y :: _) =>
     if eq (x, y) then raise SAME else Library.update eq x xs);
 
 fun make_list args = fold_rev cons_list args empty;
 fun dest_list tab = maps (fn (key, xs) => map (pair key) xs) (dest tab);
 fun merge_list eq = join (fn _ => Library.merge eq);
 
 
 (* set operations *)
 
 type set = unit table;
 
 fun insert_set x = default (x, ());
 fun remove_set x : set -> set = delete_safe x;
 fun make_set entries = fold insert_set entries empty;
 
 fun subset (A: set, B: set) = forall (defined B o #1) A;
 fun eq_set (A: set, B: set) = size A = size B andalso subset (A, B);
 
 
 (* ML pretty-printing *)
 
 val _ =
   ML_system_pp (fn depth => fn pretty => fn tab =>
     ML_Pretty.to_polyml
       (ML_Pretty.enum "," "{" "}"
         (ML_Pretty.pair
           (ML_Pretty.from_polyml o ML_system_pretty)
           (ML_Pretty.from_polyml o pretty))
         (dest tab, depth)));
 
 
 (*final declarations of this structure!*)
 val map = map_table;
 val fold = fold_table;
 val fold_rev = fold_rev_table;
 
 end;
 
 structure Inttab = Table(type key = int val ord = int_ord);
 structure Symtab = Table(type key = string val ord = fast_string_ord);
 structure Symreltab = Table(type key = string * string
   val ord = prod_ord fast_string_ord fast_string_ord);
diff --git a/src/Pure/Isar/class.ML b/src/Pure/Isar/class.ML
--- a/src/Pure/Isar/class.ML
+++ b/src/Pure/Isar/class.ML
@@ -1,845 +1,843 @@
 (*  Title:      Pure/Isar/class.ML
     Author:     Florian Haftmann, TU Muenchen
 
 Type classes derived from primitive axclasses and locales.
 *)
 
 signature CLASS =
 sig
   (*classes*)
   val is_class: theory -> class -> bool
   val these_params: theory -> sort -> (string * (class * (string * typ))) list
   val base_sort: theory -> class -> sort
   val rules: theory -> class -> thm option * thm
   val these_defs: theory -> sort -> thm list
   val these_operations: theory -> sort -> (string * (class * ((typ * term) * bool))) list
   val print_classes: Proof.context -> unit
   val init: class -> theory -> Proof.context
   val begin: class list -> sort -> Proof.context -> Proof.context
   val const: class -> (binding * mixfix) * term -> term list * term list ->
     local_theory -> local_theory
   val abbrev: class -> Syntax.mode -> (binding * mixfix) * term -> local_theory ->
     (term * term) * local_theory
   val redeclare_operations: theory -> sort -> Proof.context -> Proof.context
   val class_prefix: string -> string
   val register: class -> class list -> ((string * typ) * (string * typ)) list ->
     sort -> morphism -> morphism -> thm option -> thm option -> thm -> theory -> theory
 
   (*instances*)
   val instantiation: string list * (string * sort) list * sort -> theory -> local_theory
   val instantiation_instance: (local_theory -> local_theory)
     -> local_theory -> Proof.state
   val prove_instantiation_instance: (Proof.context -> tactic)
     -> local_theory -> local_theory
   val prove_instantiation_exit: (Proof.context -> tactic)
     -> local_theory -> theory
   val prove_instantiation_exit_result: (morphism -> 'a -> 'b)
     -> (Proof.context -> 'b -> tactic) -> 'a -> local_theory -> 'b * theory
   val read_multi_arity: theory -> xstring list * xstring list * xstring
     -> string list * (string * sort) list * sort
   val instantiation_cmd: xstring list * xstring list * xstring -> theory -> local_theory
   val instance_arity_cmd: xstring list * xstring list * xstring -> theory -> Proof.state
   val theory_map_result: string list * (string * sort) list * sort
     -> (morphism -> 'a -> 'b) -> (local_theory -> 'a * local_theory)
     -> (Proof.context -> 'b -> tactic) -> theory -> 'b * theory
 
   (*subclasses*)
   val classrel: class * class -> theory -> Proof.state
   val classrel_cmd: xstring * xstring -> theory -> Proof.state
   val register_subclass: class * class -> morphism option -> Element.witness option
     -> morphism -> local_theory -> local_theory
 
   (*tactics*)
   val intro_classes_tac: Proof.context -> thm list -> tactic
   val standard_intro_classes_tac: Proof.context -> thm list -> tactic
 
   (*diagnostics*)
   val pretty_specification: theory -> class -> Pretty.T list
 end;
 
 structure Class: CLASS =
 struct
 
 (** class data **)
 
 datatype class_data = Class_Data of {
 
   (* static part *)
   consts: (string * string) list
     (*locale parameter ~> constant name*),
   base_sort: sort,
   base_morph: morphism
     (*static part of canonical morphism*),
   export_morph: morphism,
   assm_intro: thm option,
   of_class: thm,
   axiom: thm option,
 
   (* dynamic part *)
   defs: thm Item_Net.T,
   operations: (string * (class * ((typ * term) * bool))) list
 
   (* n.b.
     params = logical parameters of class
     operations = operations participating in user-space type system
   *)
 };
 
 fun make_class_data ((consts, base_sort, base_morph, export_morph, assm_intro, of_class, axiom),
     (defs, operations)) =
   Class_Data {consts = consts, base_sort = base_sort,
     base_morph = base_morph, export_morph = export_morph, assm_intro = assm_intro,
     of_class = of_class, axiom = axiom, defs = defs, operations = operations};
 
 fun map_class_data f (Class_Data {consts, base_sort, base_morph, export_morph, assm_intro,
     of_class, axiom, defs, operations}) =
   make_class_data (f ((consts, base_sort, base_morph, export_morph, assm_intro, of_class, axiom),
     (defs, operations)));
 
 fun merge_class_data _ (Class_Data {consts = consts,
     base_sort = base_sort, base_morph = base_morph, export_morph = export_morph, assm_intro = assm_intro,
     of_class = of_class, axiom = axiom, defs = defs1, operations = operations1},
   Class_Data {consts = _, base_sort = _, base_morph = _, export_morph = _, assm_intro = _,
     of_class = _, axiom = _, defs = defs2, operations = operations2}) =
   make_class_data ((consts, base_sort, base_morph, export_morph, assm_intro, of_class, axiom),
     (Item_Net.merge (defs1, defs2),
       AList.merge (op =) (K true) (operations1, operations2)));
 
 structure Class_Data = Theory_Data
 (
   type T = class_data Graph.T
   val empty = Graph.empty;
   val extend = I;
   val merge = Graph.join merge_class_data;
 );
 
 
 (* queries *)
 
 fun lookup_class_data thy class =
   (case try (Graph.get_node (Class_Data.get thy)) class of
     SOME (Class_Data data) => SOME data
   | NONE => NONE);
 
 fun the_class_data thy class =
   (case lookup_class_data thy class of
     NONE => error ("Undeclared class " ^ quote class)
   | SOME data => data);
 
 val is_class = is_some oo lookup_class_data;
 
 val ancestry = Graph.all_succs o Class_Data.get;
 val heritage = Graph.all_preds o Class_Data.get;
 
 fun these_params thy =
   let
     fun params class =
       let
         val const_typs = (#params o Axclass.get_info thy) class;
         val const_names = (#consts o the_class_data thy) class;
       in
         (map o apsnd)
           (fn c => (class, (c, (the o AList.lookup (op =) const_typs) c))) const_names
       end;
   in maps params o ancestry thy end;
 
 val base_sort = #base_sort oo the_class_data;
 
 fun rules thy class =
   let val {axiom, of_class, ...} = the_class_data thy class
   in (axiom, of_class) end;
 
 fun all_assm_intros thy =
   Graph.fold (fn (_, (Class_Data {assm_intro, ...}, _)) => fold (insert Thm.eq_thm)
     (the_list assm_intro)) (Class_Data.get thy) [];
 
 fun these_defs thy = maps (Item_Net.content o #defs o the_class_data thy) o ancestry thy;
 fun these_operations thy = maps (#operations o the_class_data thy) o ancestry thy;
 
 val base_morphism = #base_morph oo the_class_data;
 
 fun morphism thy class =
   (case Element.eq_morphism thy (these_defs thy [class]) of
     SOME eq_morph => base_morphism thy class $> eq_morph
   | NONE => base_morphism thy class);
 
 val export_morphism = #export_morph oo the_class_data;
 
 fun pretty_param ctxt (c, ty) =
   Pretty.block
    [Name_Space.pretty ctxt (Proof_Context.const_space ctxt) c, Pretty.str " ::",
     Pretty.brk 1, Syntax.pretty_typ ctxt ty];
 
 fun print_classes ctxt =
   let
     val thy = Proof_Context.theory_of ctxt;
     val algebra = Sign.classes_of thy;
 
     val class_space = Proof_Context.class_space ctxt;
     val type_space = Proof_Context.type_space ctxt;
 
     val arities =
-      Symtab.empty
-      |> Symtab.fold (fn (tyco, arities) => fold (fn (class, _) =>
-           Symtab.map_default (class, []) (insert (op =) tyco)) arities)
-             (Sorts.arities_of algebra);
+      Symtab.build (Sorts.arities_of algebra |> Symtab.fold (fn (tyco, arities) =>
+        fold (fn (class, _) => Symtab.map_default (class, []) (insert (op =) tyco)) arities));
 
     fun prt_supersort class =
       Syntax.pretty_sort ctxt (Sign.minimize_sort thy (Sign.super_classes thy class));
 
     fun prt_arity class tyco =
       let
         val Ss = Sorts.mg_domain algebra tyco [class];
       in Syntax.pretty_arity ctxt (tyco, Ss, [class]) end;
 
     fun prt_param (c, ty) = pretty_param ctxt (c, Type.strip_sorts_dummy ty);
 
     fun prt_entry class =
       Pretty.block
         ([Pretty.keyword1 "class", Pretty.brk 1,
           Name_Space.pretty ctxt class_space class, Pretty.str ":", Pretty.fbrk,
           Pretty.block [Pretty.str "supersort: ", prt_supersort class]] @
           (case (these o Option.map #params o try (Axclass.get_info thy)) class of
             [] => []
           | params =>
               [Pretty.fbrk, Pretty.big_list "parameters:" (map prt_param params)]) @
           (case (these o Symtab.lookup arities) class of
             [] => []
           | ars =>
               [Pretty.fbrk, Pretty.big_list "instances:"
                 (map (prt_arity class) (sort (Name_Space.extern_ord ctxt type_space) ars))]));
   in
     Sorts.all_classes algebra
     |> sort (Name_Space.extern_ord ctxt class_space)
     |> map prt_entry
     |> Pretty.writeln_chunks2
   end;
 
 
 (* updaters *)
 
 fun register class sups params base_sort base_morph export_morph
     some_axiom some_assm_intro of_class thy =
   let
     val operations = map (fn (v_ty as (_, ty), (c, _)) =>
       (c, (class, ((ty, Free v_ty), false)))) params;
     val add_class = Graph.new_node (class,
         make_class_data (((map o apply2) fst params, base_sort,
           base_morph, export_morph, Option.map Thm.trim_context some_assm_intro,
           Thm.trim_context of_class, Option.map Thm.trim_context some_axiom),
           (Thm.item_net, operations)))
       #> fold (curry Graph.add_edge class) sups;
   in Class_Data.map add_class thy end;
 
 fun activate_defs class thms thy =
   (case Element.eq_morphism thy thms of
     SOME eq_morph =>
       fold (fn cls => fn thy =>
         Context.theory_map
           (Locale.amend_registration
             {inst = (cls, base_morphism thy cls),
               mixin = SOME (eq_morph, true),
               export = export_morphism thy cls}) thy) (heritage thy [class]) thy
   | NONE => thy);
 
 fun register_operation class (c, t) input_only thy =
   let
     val base_sort = base_sort thy class;
     val prep_typ = map_type_tfree
       (fn (v, sort) => if Name.aT = v
         then TFree (v, base_sort) else TVar ((v, 0), sort));
     val t' = map_types prep_typ t;
     val ty' = Term.fastype_of t';
   in
     thy
     |> (Class_Data.map o Graph.map_node class o map_class_data o apsnd o apsnd)
         (cons (c, (class, ((ty', t'), input_only))))
   end;
 
 fun register_def class def_thm thy =
   let
     val sym_thm = Thm.trim_context (Thm.symmetric def_thm)
   in
     thy
     |> (Class_Data.map o Graph.map_node class o map_class_data o apsnd o apfst)
         (Item_Net.update sym_thm)
     |> activate_defs class [sym_thm]
   end;
 
 
 (** classes and class target **)
 
 (* class context syntax *)
 
 fun make_rewrite t c_ty =
   let
     val vs = strip_abs_vars t;
     val vts = map snd vs
       |> Name.invent_names Name.context Name.uu
       |> map (fn (v, T) => Var ((v, 0), T));
   in (betapplys (t, vts), betapplys (Const c_ty, vts)) end;
 
 fun these_unchecks thy =
   these_operations thy
   #> map_filter (fn (c, (_, ((ty, t), input_only))) =>
     if input_only then NONE else SOME (make_rewrite t (c, ty)));
 
 fun these_unchecks_reversed thy =
   these_operations thy
   #> map (fn (c, (_, ((ty, t), _))) => (Const (c, ty), t));
 
 fun redeclare_const thy c =
   let val b = Long_Name.base_name c
   in Sign.intern_const thy b = c ? Variable.declare_const (b, c) end;
 
 fun synchronize_class_syntax sort base_sort ctxt =
   let
     val thy = Proof_Context.theory_of ctxt;
     val algebra = Sign.classes_of thy;
     val operations = these_operations thy sort;
     fun subst_class_typ sort = map_type_tfree (K (TVar ((Name.aT, 0), sort)));
     val primary_constraints =
       (map o apsnd) (subst_class_typ base_sort o fst o fst o snd) operations;
     val secondary_constraints =
       (map o apsnd) (fn (class, ((ty, _), _)) => subst_class_typ [class] ty) operations;
     fun improve (c, ty) =
       (case AList.lookup (op =) primary_constraints c of
         SOME ty' =>
           (case try (Type.raw_match (ty', ty)) Vartab.empty of
             SOME tyenv =>
               (case Vartab.lookup tyenv (Name.aT, 0) of
                 SOME (_, ty' as TVar (vi, sort)) =>
                   if Type_Infer.is_param vi andalso Sorts.sort_le algebra (base_sort, sort)
                   then SOME (ty', Term.aT base_sort)
                   else NONE
               | _ => NONE)
           | NONE => NONE)
       | NONE => NONE);
     fun subst (c, _) = Option.map (fst o snd) (AList.lookup (op =) operations c);
     val unchecks = these_unchecks thy sort;
   in
     ctxt
     |> fold (redeclare_const thy o fst) primary_constraints
     |> Overloading.map_improvable_syntax (K {primary_constraints = primary_constraints,
       secondary_constraints = secondary_constraints, improve = improve, subst = subst,
       no_subst_in_abbrev_mode = true, unchecks = unchecks})
     |> Overloading.set_primary_constraints
   end;
 
 fun synchronize_class_syntax_target class lthy =
   lthy
   |> Local_Theory.map_contexts
       (K (synchronize_class_syntax [class] (base_sort (Proof_Context.theory_of lthy) class)));
 
 fun redeclare_operations thy sort =
   fold (redeclare_const thy o fst) (these_operations thy sort);
 
 fun begin sort base_sort ctxt =
   ctxt
   |> Variable.declare_term (Logic.mk_type (Term.aT base_sort))
   |> synchronize_class_syntax sort base_sort
   |> Overloading.activate_improvable_syntax;
 
 fun init class thy =
   thy
   |> Locale.init class
   |> begin [class] (base_sort thy class);
 
 
 (* class target *)
 
 val class_prefix = Logic.const_of_class o Long_Name.base_name;
 
 fun guess_morphism_identity (b, rhs) phi1 phi2 =
   let
     (*FIXME proper concept to identify morphism instead of educated guess*)
     val name_of_binding = Name_Space.full_name Name_Space.global_naming;
     val n1 = (name_of_binding o Morphism.binding phi1) b;
     val n2 = (name_of_binding o Morphism.binding phi2) b;
     val rhs1 = Morphism.term phi1 rhs;
     val rhs2 = Morphism.term phi2 rhs;
   in n1 = n2 andalso Term.aconv_untyped (rhs1, rhs2) end;
 
 fun target_const class phi0 prmode (b, rhs) lthy =
   let
     val export = Variable.export_morphism lthy (Local_Theory.target_of lthy);
     val guess_identity = guess_morphism_identity (b, rhs) export;
     val guess_canonical = guess_morphism_identity (b, rhs) (export $> phi0);
   in
     lthy
     |> Generic_Target.locale_target_const class
       (not o (guess_identity orf guess_canonical)) prmode ((b, NoSyn), rhs)
   end;
 
 local
 
 fun dangling_params_for lthy class (type_params, term_params) =
   let
     val class_param_names =
       map fst (these_params (Proof_Context.theory_of lthy) [class]);
     val dangling_term_params =
       subtract (fn (v, Free (w, _)) => v = w | _ => false) class_param_names term_params;
   in (type_params, dangling_term_params) end;
 
 fun global_def (b, eq) thy =
   let
     val ((_, def_thm), thy') = thy |> Thm.add_def_global false false (b, eq);
     val def_thm' = def_thm |> Thm.forall_intr_frees |> Thm.forall_elim_vars 0 |> Thm.varifyT_global;
     val (_, thy'') = thy' |> Global_Theory.store_thm (b, def_thm');
   in (def_thm', thy'') end;
 
 fun canonical_const class phi dangling_params ((b, mx), rhs) thy =
   let
     val b_def = Binding.suffix_name "_dict" b;
     val c = Sign.full_name thy b;
     val ty = map Term.fastype_of dangling_params ---> Term.fastype_of rhs;
     val def_eq = Logic.mk_equals (list_comb (Const (c, ty), dangling_params), rhs)
       |> map_types Type.strip_sorts;
   in
     thy
     |> Sign.declare_const_global ((b, Type.strip_sorts ty), mx)
     |> snd
     |> global_def (b_def, def_eq)
     |-> (fn def_thm => register_def class def_thm)
     |> null dangling_params ? register_operation class (c, rhs) false
     |> Sign.add_const_constraint (c, SOME ty)
   end;
 
 in
 
 fun const class ((b, mx), lhs) params lthy =
   let
     val phi = morphism (Proof_Context.theory_of lthy) class;
     val dangling_params = map (Morphism.term phi) (uncurry append (dangling_params_for lthy class params));
   in
     lthy
     |> target_const class phi Syntax.mode_default (b, lhs)
     |> Local_Theory.raw_theory (canonical_const class phi dangling_params
          ((Morphism.binding phi b, if null dangling_params then mx else NoSyn), Morphism.term phi lhs))
     |> Generic_Target.standard_const (fn (this, other) => other <> 0 andalso this <> other)
          Syntax.mode_default ((b, if null dangling_params then NoSyn else mx), lhs)
     |> synchronize_class_syntax_target class
   end;
 
 end;
 
 local
 
 fun canonical_abbrev class phi prmode with_syntax ((b, mx), rhs) thy =
   let
     val c = Sign.full_name thy b;
     val constrain = map_atyps (fn T as TFree (v, _) =>
       if v = Name.aT then TFree (v, [class]) else T | T => T);
     val rhs' = map_types constrain rhs;
   in
     thy
     |> Sign.add_abbrev (#1 prmode) (b, Logic.varify_types_global rhs')
     |> snd
     |> with_syntax ? Sign.notation true prmode [(Const (c, fastype_of rhs), mx)]
     |> with_syntax ? register_operation class (c, rhs)
         (#1 prmode = Print_Mode.input)
     |> Sign.add_const_constraint (c, SOME (fastype_of rhs'))
   end;
 
 fun canonical_abbrev_target class phi prmode ((b, mx), rhs) lthy =
   let
     val thy = Proof_Context.theory_of lthy;
     val preprocess = perhaps (try (Pattern.rewrite_term_top thy (these_unchecks thy [class]) []));
     val (global_rhs, (_, (_, term_params))) =
       Generic_Target.export_abbrev lthy preprocess rhs;
     val mx' = Generic_Target.check_mixfix_global (b, null term_params) mx;
   in
     lthy
     |> Local_Theory.raw_theory (canonical_abbrev class phi prmode (null term_params)
         ((Morphism.binding phi b, mx'), Logic.unvarify_types_global global_rhs))
   end;
 
 fun further_abbrev_target class phi prmode (b, mx) rhs params =
   Generic_Target.background_abbrev (b, rhs) (snd params)
   #-> (fn (lhs, _) => target_const class phi prmode (b, lhs)
     #> Generic_Target.standard_const (fn (this, other) => other <> 0 andalso this <> other) prmode ((b, mx), lhs))
 
 in
 
 fun abbrev class prmode ((b, mx), rhs) lthy =
   let
     val thy = Proof_Context.theory_of lthy;
     val phi = morphism thy class;
     val rhs_generic =
       perhaps (try (Pattern.rewrite_term_top thy (these_unchecks_reversed thy [class]) [])) rhs;
   in
     lthy
     |> canonical_abbrev_target class phi prmode ((b, mx), rhs)
     |> Generic_Target.abbrev (further_abbrev_target class phi) prmode ((b, mx), rhs_generic)
     ||> synchronize_class_syntax_target class
   end;
 
 end;
 
 
 (* subclasses *)
 
 fun register_subclass (sub, sup) some_dep_morph some_witn export lthy =
   let
     val thy = Proof_Context.theory_of lthy;
     val intros = (snd o rules thy) sup :: map_filter I
       [Option.map (Drule.export_without_context_open o Element.conclude_witness lthy) some_witn,
         (fst o rules thy) sub];
     val classrel =
       Goal.prove_sorry_global thy [] [] (Logic.mk_classrel (sub, sup))
         (fn {context = ctxt, ...} => EVERY (map (TRYALL o resolve_tac ctxt o single) intros));
     val diff_sort = Sign.complete_sort thy [sup]
       |> subtract (op =) (Sign.complete_sort thy [sub])
       |> filter (is_class thy);
     val add_dependency =
       (case some_dep_morph of
         SOME dep_morph =>
           Generic_Target.locale_dependency sub
             {inst = (sup, dep_morph $> Element.satisfy_morphism (the_list some_witn)),
               mixin = NONE, export = export}
       | NONE => I);
   in
     lthy
     |> Local_Theory.raw_theory
       (Axclass.add_classrel classrel
       #> Class_Data.map (Graph.add_edge (sub, sup))
       #> activate_defs sub (these_defs thy diff_sort))
     |> add_dependency
     |> synchronize_class_syntax_target sub
   end;
 
 local
 
 fun gen_classrel mk_prop classrel thy =
   let
     fun after_qed results =
       Proof_Context.background_theory ((fold o fold) Axclass.add_classrel results);
   in
     thy
     |> Proof_Context.init_global
     |> Proof.theorem NONE after_qed [[(mk_prop thy classrel, [])]]
   end;
 
 in
 
 val classrel =
   gen_classrel (Logic.mk_classrel oo Axclass.cert_classrel);
 val classrel_cmd =
   gen_classrel (Logic.mk_classrel oo Axclass.read_classrel);
 
 end; (*local*)
 
 
 (** instantiation target **)
 
 (* bookkeeping *)
 
 datatype instantiation = Instantiation of {
   arities: string list * (string * sort) list * sort,
   params: ((string * string) * (string * typ)) list
     (*(instantiation parameter, type constructor), (local instantiation parameter, typ)*)
 }
 
 fun make_instantiation (arities, params) =
   Instantiation {arities = arities, params = params};
 
 val empty_instantiation = make_instantiation (([], [], []), []);
 
 structure Instantiation = Proof_Data
 (
   type T = instantiation;
   fun init _ = empty_instantiation;
 );
 
 val get_instantiation =
   (fn Instantiation data => data) o Instantiation.get o Local_Theory.target_of;
 
 fun map_instantiation f =
   (Local_Theory.target o Instantiation.map)
     (fn Instantiation {arities, params} => make_instantiation (f (arities, params)));
 
 fun the_instantiation lthy =
   (case get_instantiation lthy of
     {arities = ([], [], []), ...} => error "No instantiation target"
   | data => data);
 
 val instantiation_params = #params o get_instantiation;
 
 fun instantiation_param lthy b = instantiation_params lthy
   |> find_first (fn (_, (v, _)) => Binding.name_of b = v)
   |> Option.map (fst o fst);
 
 fun read_multi_arity thy (raw_tycos, raw_sorts, raw_sort) =
   let
     val ctxt = Proof_Context.init_global thy;
     val all_arities = map (fn raw_tyco => Proof_Context.read_arity ctxt
       (raw_tyco, raw_sorts, raw_sort)) raw_tycos;
     val tycos = map #1 all_arities;
     val (_, sorts, sort) = hd all_arities;
     val vs = Name.invent_names Name.context Name.aT sorts;
   in (tycos, vs, sort) end;
 
 
 (* syntax *)
 
 fun synchronize_inst_syntax ctxt =
   let
     val Instantiation {params, ...} = Instantiation.get ctxt;
 
     val lookup_inst_param = Axclass.lookup_inst_param
       (Sign.consts_of (Proof_Context.theory_of ctxt)) params;
     fun subst (c, ty) =
       (case lookup_inst_param (c, ty) of
         SOME (v_ty as (_, ty)) => SOME (ty, Free v_ty)
       | NONE => NONE);
     val unchecks =
       map (fn ((c, _), v_ty as (_, ty)) => (Free v_ty, Const (c, ty))) params;
   in
     ctxt
     |> Overloading.map_improvable_syntax (fn {primary_constraints, improve, ...} =>
       {primary_constraints = primary_constraints, secondary_constraints = [],
         improve = improve, subst = subst, no_subst_in_abbrev_mode = false,
         unchecks = unchecks})
   end;
 
 fun resort_terms ctxt algebra consts constraints ts =
   let
     fun matchings (Const (c_ty as (c, _))) =
           (case constraints c of
             NONE => I
           | SOME sorts =>
               fold2 (curry (Sorts.meet_sort algebra)) (Consts.typargs consts c_ty) sorts)
       | matchings _ = I;
-    val tvartab = (fold o fold_aterms) matchings ts Vartab.empty
+    val tvartab = Vartab.build ((fold o fold_aterms) matchings ts)
       handle Sorts.CLASS_ERROR e => error (Sorts.class_error (Context.Proof ctxt) e);
     val inst = map_type_tvar
       (fn (vi, sort) => TVar (vi, the_default sort (Vartab.lookup tvartab vi)));
   in if Vartab.is_empty tvartab then ts else (map o map_types) inst ts end;
 
 
 (* target *)
 
 fun define_overloaded (c, U) b (b_def, rhs) lthy =
   let
     val name = Binding.name_of b;
     val pos = Binding.pos_of b;
     val _ =
       if Context_Position.is_reported lthy pos then
         Position.report_text pos Markup.class_parameter
           (Pretty.string_of
             (Pretty.block [Pretty.keyword1 "class", Pretty.brk 1,
                 Pretty.str "parameter", Pretty.brk 1, pretty_param lthy (c, U)]))
       else ();
   in
     lthy |> Local_Theory.background_theory_result
       (Axclass.declare_overloaded (c, U) ##>> Axclass.define_overloaded b_def (c, rhs))
     ||> (map_instantiation o apsnd) (filter_out (fn (_, (v', _)) => v' = name))
     ||> Local_Theory.map_contexts (K synchronize_inst_syntax)
   end;
 
 fun foundation (((b, U), mx), (b_def, rhs)) params lthy =
   (case instantiation_param lthy b of
     SOME c =>
       if Mixfix.is_empty mx then lthy |> define_overloaded (c, U) b (b_def, rhs)
       else error ("Illegal mixfix syntax for overloaded constant " ^ quote c)
   | NONE => lthy |> Generic_Target.theory_target_foundation (((b, U), mx), (b_def, rhs)) params);
 
 fun pretty lthy =
   let
     val {arities = (tycos, vs, sort), params} = the_instantiation lthy;
     fun pr_arity tyco = Syntax.pretty_arity lthy (tyco, map snd vs, sort);
     fun pr_param ((c, _), (v, ty)) =
       Pretty.block (Pretty.breaks
         [Pretty.str v, Pretty.str "==", Proof_Context.pretty_const lthy c,
           Pretty.str "::", Syntax.pretty_typ lthy ty]);
   in
     [Pretty.block
       (Pretty.fbreaks (Pretty.keyword1 "instantiation" :: map pr_arity tycos @ map pr_param params))]
   end;
 
 fun conclude lthy =
   let
     val (tycos, vs, sort) = #arities (the_instantiation lthy);
     val thy = Proof_Context.theory_of lthy;
     val _ = tycos |> List.app (fn tyco =>
       if Sign.of_sort thy (Type (tyco, map TFree vs), sort) then ()
       else error ("Missing instance proof for type " ^ quote (Proof_Context.markup_type lthy tyco)));
   in lthy end;
 
 fun registration thy_ctxt {inst, mixin, export} lthy =
   lthy
   |> Generic_Target.theory_registration
       {inst = inst,
        mixin = mixin,
        export = export $> Proof_Context.export_morphism lthy thy_ctxt}
          (*handle fixed types variables on target context properly*);
 
 fun instantiation (tycos, vs, sort) thy =
   let
     val _ = if null tycos then error "At least one arity must be given" else ();
     val class_params = these_params thy (filter (can (Axclass.get_info thy)) sort);
     fun get_param tyco (param, (_, (c, ty))) =
       if can (Axclass.param_of_inst thy) (c, tyco)
       then NONE else SOME ((c, tyco),
         (param ^ "_" ^ Long_Name.base_name tyco, map_atyps (K (Type (tyco, map TFree vs))) ty));
     val params = map_product get_param tycos class_params |> map_filter I;
     val _ = if null params andalso forall (fn tyco => can (Sign.arity_sorts thy tyco) sort) tycos
       then error "No parameters and no pending instance proof obligations in instantiation."
       else ();
     val primary_constraints = map (apsnd
       (map_atyps (K (TVar ((Name.aT, 0), [])))) o snd o snd) class_params;
     val algebra = Sign.classes_of thy
       |> fold (fn tyco => Sorts.add_arities (Context.Theory thy)
             (tyco, map (fn class => (class, map snd vs)) sort)) tycos;
     val consts = Sign.consts_of thy;
     val improve_constraints = AList.lookup (op =)
       (map (fn (_, (class, (c, _))) => (c, [[class]])) class_params);
     fun resort_check ctxt ts = resort_terms ctxt algebra consts improve_constraints ts;
     val lookup_inst_param = Axclass.lookup_inst_param consts params;
     fun improve (c, ty) =
       (case lookup_inst_param (c, ty) of
         SOME (_, ty') => if Sign.typ_instance thy (ty', ty) then SOME (ty, ty') else NONE
       | NONE => NONE);
   in
     thy
     |> Local_Theory.init
        {background_naming = Sign.naming_of thy,
         setup = Proof_Context.init_global
           #> Instantiation.put (make_instantiation ((tycos, vs, sort), params))
           #> fold (Variable.declare_typ o TFree) vs
           #> fold (Variable.declare_names o Free o snd) params
           #> (Overloading.map_improvable_syntax) (K {primary_constraints = primary_constraints,
             secondary_constraints = [], improve = improve, subst = K NONE,
             no_subst_in_abbrev_mode = false, unchecks = []})
           #> Overloading.activate_improvable_syntax
           #> Context.proof_map (Syntax_Phases.term_check 0 "resorting" resort_check)
           #> synchronize_inst_syntax,
         conclude = conclude}
        {define = Generic_Target.define foundation,
         notes = Generic_Target.notes Generic_Target.theory_target_notes,
         abbrev = Generic_Target.abbrev Generic_Target.theory_target_abbrev,
         declaration = K Generic_Target.theory_declaration,
         theory_registration = registration (Proof_Context.init_global thy),
         locale_dependency = fn _ => error "Not possible in instantiation target",
         pretty = pretty}
   end;
 
 fun instantiation_cmd arities thy =
   instantiation (read_multi_arity thy arities) thy;
 
 fun gen_instantiation_instance do_proof after_qed lthy =
   let
     val (tycos, vs, sort) = (#arities o the_instantiation) lthy;
     val arities_proof = maps (fn tyco => Logic.mk_arities (tyco, map snd vs, sort)) tycos;
     fun after_qed' results =
       Local_Theory.background_theory (fold (Axclass.add_arity o Thm.varifyT_global) results)
       #> after_qed;
   in
     lthy
     |> do_proof after_qed' arities_proof
   end;
 
 val instantiation_instance = gen_instantiation_instance (fn after_qed => fn ts =>
   Proof.theorem NONE (after_qed o map the_single) (map (fn t => [(t, [])]) ts));
 
 fun prove_instantiation_instance tac = gen_instantiation_instance (fn after_qed =>
   fn ts => fn lthy => after_qed (map (fn t => Goal.prove lthy [] [] t
     (fn {context, ...} => tac context)) ts) lthy) I;
 
 fun prove_instantiation_exit tac = prove_instantiation_instance tac
   #> Local_Theory.exit_global;
 
 fun prove_instantiation_exit_result f tac x lthy =
   let
     val morph = Proof_Context.export_morphism lthy
       (Proof_Context.init_global (Proof_Context.theory_of lthy));
     val y = f morph x;
   in
     lthy
     |> prove_instantiation_exit (fn ctxt => tac ctxt y)
     |> pair y
   end;
 
 fun theory_map_result arities f g tac =
   instantiation arities
   #> g
   #-> prove_instantiation_exit_result f tac;
 
 
 (* simplified instantiation interface with no class parameter *)
 
 fun instance_arity_cmd raw_arities thy =
   let
     val (tycos, vs, sort) = read_multi_arity thy raw_arities;
     val sorts = map snd vs;
     val arities = maps (fn tyco => Logic.mk_arities (tyco, sorts, sort)) tycos;
     fun after_qed results =
       Proof_Context.background_theory ((fold o fold) Axclass.add_arity results);
   in
     thy
     |> Proof_Context.init_global
     |> Proof.theorem NONE after_qed (map (fn t => [(t, [])]) arities)
   end;
 
 
 
 (** tactics and methods **)
 
 fun intro_classes_tac ctxt facts st =
   let
     val thy = Proof_Context.theory_of ctxt;
     val classes = Sign.all_classes thy;
     val class_trivs = map (Thm.class_triv thy) classes;
     val class_intros = map_filter (try (#intro o Axclass.get_info thy)) classes;
     val assm_intros = all_assm_intros thy;
   in
     Method.intros_tac ctxt (class_trivs @ class_intros @ assm_intros) facts st
   end;
 
 fun standard_intro_classes_tac ctxt facts st =
   if null facts andalso not (Thm.no_prems st) then
     (intro_classes_tac ctxt [] ORELSE
       Locale.intro_locales_tac {strict = true, eager = true} ctxt []) st
   else no_tac st;
 
 fun standard_tac ctxt facts =
   HEADGOAL (Method.some_rule_tac ctxt [] facts) ORELSE
   standard_intro_classes_tac ctxt facts;
 
 val _ = Theory.setup
  (Method.setup \<^binding>\<open>intro_classes\<close> (Scan.succeed (METHOD o intro_classes_tac))
     "back-chain introduction rules of classes" #>
   Method.setup \<^binding>\<open>standard\<close> (Scan.succeed (METHOD o standard_tac))
     "standard proof step: Pure intro/elim rule or class introduction");
 
 
 
 (** diagnostics **)
 
 fun pretty_specification thy class =
   if is_class thy class then
     let
       val class_ctxt = init class thy;
       val prt_class = Name_Space.pretty class_ctxt (Proof_Context.class_space class_ctxt);
 
       val super_classes = Sign.minimize_sort thy (Sign.super_classes thy class);
 
       val fix_args =
         #params (Axclass.get_info thy class)
         |> map (fn (c, T) => (Binding.name (Long_Name.base_name c), SOME T, NoSyn));
       val fixes = if null fix_args then [] else [Element.Fixes fix_args];
       val assumes = Locale.hyp_spec_of thy class;
 
       val header =
         [Pretty.keyword1 "class", Pretty.brk 1, prt_class class, Pretty.str " =", Pretty.brk 1] @
         Pretty.separate " +" (map prt_class super_classes) @
         (if null super_classes then [] else [Pretty.str " +"]);
       val body =
         if null fixes andalso null assumes then []
         else
           maps (Element.pretty_ctxt_no_attribs class_ctxt) (fixes @ assumes)
           |> maps (fn prt => [Pretty.fbrk, prt]);
     in if null body then [] else [Pretty.block (header @ body)] end
   else [];
 
 end;
diff --git a/src/Pure/Isar/generic_target.ML b/src/Pure/Isar/generic_target.ML
--- a/src/Pure/Isar/generic_target.ML
+++ b/src/Pure/Isar/generic_target.ML
@@ -1,477 +1,475 @@
 (*  Title:      Pure/Isar/generic_target.ML
     Author:     Makarius
     Author:     Florian Haftmann, TU Muenchen
 
 Common target infrastructure.
 *)
 
 signature GENERIC_TARGET =
 sig
   (*auxiliary*)
   val export_abbrev: Proof.context ->
       (term -> term) -> term -> term * ((string * sort) list * (term list * term list))
   val check_mixfix: Proof.context -> binding * (string * sort) list -> mixfix -> mixfix
   val check_mixfix_global: binding * bool -> mixfix -> mixfix
 
   (*background primitives*)
   val background_foundation: ((binding * typ) * mixfix) * (binding * term) ->
     term list * term list -> local_theory -> (term * thm) * local_theory
   val background_declaration: declaration -> local_theory -> local_theory
   val background_abbrev: binding * term -> term list -> local_theory -> (term * term) * local_theory
   val add_foundation_interpretation: (binding * (term * term list) -> Context.generic -> Context.generic) ->
     theory -> theory
 
   (*nested local theories primitives*)
   val standard_facts: local_theory -> Proof.context -> Attrib.fact list -> Attrib.fact list
   val standard_notes: (int * int -> bool) -> string -> Attrib.fact list ->
     local_theory -> local_theory
   val standard_declaration: (int * int -> bool) ->
     (morphism -> Context.generic -> Context.generic) -> local_theory -> local_theory
   val standard_const: (int * int -> bool) -> Syntax.mode -> (binding * mixfix) * term ->
     local_theory -> local_theory
   val local_interpretation: Locale.registration ->
     local_theory -> local_theory
 
   (*lifting target primitives to local theory operations*)
   val define: (((binding * typ) * mixfix) * (binding * term) ->
       term list * term list -> local_theory -> (term * thm) * local_theory) ->
     bool -> (binding * mixfix) * (Attrib.binding * term) -> local_theory ->
     (term * (string * thm)) * local_theory
   val notes:
     (string -> Attrib.fact list -> Attrib.fact list -> local_theory -> local_theory) ->
     string -> Attrib.fact list -> local_theory -> (string * thm list) list * local_theory
   val abbrev: (Syntax.mode -> binding * mixfix -> term ->
       term list * term list -> local_theory -> local_theory) ->
     Syntax.mode -> (binding * mixfix) * term -> local_theory -> (term * term) * local_theory
 
   (*theory target primitives*)
   val theory_target_foundation: ((binding * typ) * mixfix) * (binding * term) ->
      term list * term list -> local_theory -> (term * thm) * local_theory
   val theory_target_notes: string -> Attrib.fact list -> Attrib.fact list ->
     local_theory -> local_theory
   val theory_target_abbrev: Syntax.mode -> (binding * mixfix) -> term -> term list * term list ->
     local_theory -> local_theory
 
   (*theory target operations*)
   val theory_abbrev: Syntax.mode -> (binding * mixfix) * term ->
     local_theory -> (term * term) * local_theory
   val theory_declaration: declaration -> local_theory -> local_theory
   val theory_registration: Locale.registration -> local_theory -> local_theory
 
   (*locale target primitives*)
   val locale_target_notes: string -> string -> Attrib.fact list -> Attrib.fact list ->
     local_theory -> local_theory
   val locale_target_abbrev: string -> Syntax.mode ->
     (binding * mixfix) -> term -> term list * term list -> local_theory -> local_theory
   val locale_target_declaration: string -> bool -> declaration -> local_theory -> local_theory
   val locale_target_const: string -> (morphism -> bool) -> Syntax.mode ->
     (binding * mixfix) * term -> local_theory -> local_theory
 
   (*locale operations*)
   val locale_abbrev: string -> Syntax.mode -> (binding * mixfix) * term ->
     local_theory -> (term * term) * local_theory
   val locale_declaration: string -> {syntax: bool, pervasive: bool} -> declaration ->
     local_theory -> local_theory
   val locale_const: string -> Syntax.mode -> (binding * mixfix) * term ->
     local_theory -> local_theory
   val locale_dependency: string -> Locale.registration ->
     local_theory -> local_theory
 end
 
 structure Generic_Target: GENERIC_TARGET =
 struct
 
 (** consts **)
 
 fun export_abbrev lthy preprocess rhs =
   let
     val thy_ctxt = Proof_Context.init_global (Proof_Context.theory_of lthy);
 
     val rhs' = rhs
       |> Assumption.export_term lthy (Local_Theory.target_of lthy)
       |> preprocess;
     val term_params =
       map Free (sort (Variable.fixed_ord lthy o apply2 #1) (Variable.add_fixed lthy rhs' []));
     val u = fold_rev lambda term_params rhs';
     val global_rhs = singleton (Variable.polymorphic thy_ctxt) u;
 
-    val type_tfrees = Term_Subst.add_tfreesT (Term.fastype_of u) Term_Subst.TFrees.empty;
+    val type_tfrees = Term_Subst.TFrees.build (Term_Subst.add_tfreesT (Term.fastype_of u));
     val extra_tfrees =
       (u, []) |-> (Term.fold_types o Term.fold_atyps)
         (fn TFree v => not (Term_Subst.TFrees.defined type_tfrees v) ? insert (op =) v | _ => I)
       |> rev;
     val type_params = map (Logic.mk_type o TFree) extra_tfrees;
   in (global_rhs, (extra_tfrees, (type_params, term_params))) end;
 
 fun check_mixfix ctxt (b, extra_tfrees) mx =
   if null extra_tfrees then mx
   else
    (if Context_Position.is_visible ctxt then
       warning
         ("Additional type variable(s) in specification of " ^ Binding.print b ^ ": " ^
           commas (map (Syntax.string_of_typ ctxt o TFree) (sort_by #1 extra_tfrees)) ^
           (if Mixfix.is_empty mx then ""
            else "\nDropping mixfix syntax " ^ Pretty.string_of (Mixfix.pretty_mixfix mx)))
     else (); NoSyn);
 
 fun check_mixfix_global (b, no_params) mx =
   if no_params orelse Mixfix.is_empty mx then mx
   else
     (warning ("Dropping global mixfix syntax: " ^ Binding.print b ^ " " ^
       Pretty.string_of (Mixfix.pretty_mixfix mx)); NoSyn);
 
 fun same_const (Const (c, _), Const (c', _)) = c = c'
   | same_const (t $ _, t' $ _) = same_const (t, t')
   | same_const (_, _) = false;
 
 fun const_decl phi_pred prmode ((b, mx), rhs) phi context =
   if phi_pred phi then
     let
       val b' = Morphism.binding phi b;
       val rhs' = Morphism.term phi rhs;
       val same_shape = Term.aconv_untyped (rhs, rhs');
       val same_stem = same_shape orelse same_const (rhs, rhs');
       val const_alias =
         if same_shape then
           (case rhs' of
             Const (c, T) =>
               let
                 val thy = Context.theory_of context;
                 val ctxt = Context.proof_of context;
               in
                 (case Type_Infer_Context.const_type ctxt c of
                   SOME T' => if Sign.typ_equiv thy (T, T') then SOME c else NONE
                 | NONE => NONE)
               end
           | _ => NONE)
         else NONE;
     in
       (case const_alias of
         SOME c =>
           context
           |> Context.mapping (Sign.const_alias b' c) (Proof_Context.const_alias b' c)
           |> Morphism.form (Proof_Context.generic_notation true prmode [(rhs', mx)])
       | NONE =>
           context
           |> Proof_Context.generic_add_abbrev Print_Mode.internal
             (b', Term.close_schematic_term rhs')
           |-> (fn (const as Const (c, _), _) => same_stem ?
                 (Proof_Context.generic_revert_abbrev (#1 prmode) c #>
                  same_shape ?
                   Morphism.form (Proof_Context.generic_notation true prmode [(const, mx)]))))
     end
   else context;
 
 
 
 (** background primitives **)
 
 structure Foundation_Interpretations = Theory_Data
 (
   type T = (binding * (term * term list) -> Context.generic -> Context.generic) Inttab.table;
   val empty = Inttab.empty;
   val extend = I;
   val merge = Inttab.merge (K true);
 );
 
 fun add_foundation_interpretation f =
   Foundation_Interpretations.map (Inttab.update_new (serial (), f));
 
 fun foundation_interpretation binding_const_params lthy =
   let
     val interps = Foundation_Interpretations.get (Proof_Context.theory_of lthy);
     val interp = Inttab.fold (fn (_, f) => f binding_const_params) interps;
   in
     lthy
     |> Local_Theory.background_theory (Context.theory_map interp)
     |> Local_Theory.map_contexts (K (Context.proof_map interp))
   end;
 
 fun background_foundation (((b, U), mx), (b_def, rhs)) (type_params, term_params) lthy =
   let
     val params = type_params @ term_params;
     val target_params = type_params
       @ take_prefix is_Free (Variable.export_terms lthy (Local_Theory.target_of lthy) term_params);
     val mx' = check_mixfix_global (b, null params) mx;
 
     val (const, lthy2) = lthy
       |> Local_Theory.background_theory_result (Sign.declare_const lthy ((b, U), mx'));
     val lhs = Term.list_comb (const, params);
 
     val ((_, def), lthy3) = lthy2
       |> Local_Theory.background_theory_result
         (Thm.add_def (Proof_Context.defs_context lthy2) false false
           (Thm.def_binding_optional b b_def, Logic.mk_equals (lhs, rhs)))
       ||> foundation_interpretation (b, (const, target_params));
   in ((lhs, def), lthy3) end;
 
 fun background_declaration decl lthy =
   let
     fun theory_decl context =
       Local_Theory.standard_form lthy
         (Proof_Context.init_global (Context.theory_of context)) decl context;
   in Local_Theory.background_theory (Context.theory_map theory_decl) lthy end;
 
 fun background_abbrev (b, global_rhs) params =
   Local_Theory.background_theory_result (Sign.add_abbrev Print_Mode.internal (b, global_rhs))
   #>> apply2 (fn t => Term.list_comb (Logic.unvarify_global t, params))
 
 
 
 (** nested local theories primitives **)
 
 fun standard_facts lthy ctxt =
   Attrib.transform_facts (Local_Theory.standard_morphism lthy ctxt);
 
 fun standard_notes pred kind facts lthy =
   Local_Theory.map_contexts (fn level => fn ctxt =>
     if pred (Local_Theory.level lthy, level)
     then Attrib.local_notes kind (standard_facts lthy ctxt facts) ctxt |> snd
     else ctxt) lthy;
 
 fun standard_declaration pred decl lthy =
   Local_Theory.map_contexts (fn level => fn ctxt =>
     if pred (Local_Theory.level lthy, level)
     then Context.proof_map (Local_Theory.standard_form lthy ctxt decl) ctxt
     else ctxt) lthy;
 
 fun standard_const pred prmode ((b, mx), rhs) =
   standard_declaration pred (const_decl (K true) prmode ((b, mx), rhs));
 
 fun standard_registration pred registration lthy =
   Local_Theory.map_contexts (fn level =>
     if pred (Local_Theory.level lthy, level)
     then Context.proof_map (Locale.add_registration registration)
     else I) lthy;
 
 val local_interpretation = standard_registration (fn (n, level) => level = n - 1);
 
 
 
 (** lifting target primitives to local theory operations **)
 
 (* define *)
 
 fun define foundation internal ((b, mx), ((b_def, atts), rhs)) lthy =
   let
     val thy_ctxt = Proof_Context.init_global (Proof_Context.theory_of lthy);
 
     (*term and type parameters*)
     val ((defs, _), rhs') = Thm.cterm_of lthy rhs
       |> Local_Defs.export_cterm lthy thy_ctxt ||> Thm.term_of;
 
     val xs = Variable.add_fixed lthy rhs' [];
     val T = Term.fastype_of rhs;
     val type_tfrees =
-      Term_Subst.TFrees.empty
-      |> Term_Subst.add_tfreesT T
-      |> fold (Term_Subst.add_tfreesT o #2) xs;
+      Term_Subst.TFrees.build (Term_Subst.add_tfreesT T #> fold (Term_Subst.add_tfreesT o #2) xs);
     val extra_tfrees =
       (rhs, []) |-> (Term.fold_types o Term.fold_atyps)
         (fn TFree v => not (Term_Subst.TFrees.defined type_tfrees v) ? insert (op =) v | _ => I)
       |> rev;
     val mx' = check_mixfix lthy (b, extra_tfrees) mx;
 
     val type_params = map (Logic.mk_type o TFree) extra_tfrees;
     val term_params = map Free (sort (Variable.fixed_ord lthy o apply2 #1) xs);
     val params = type_params @ term_params;
 
     val U = map Term.fastype_of params ---> T;
 
     (*foundation*)
     val ((lhs', global_def), lthy2) = lthy
       |> foundation (((b, U), mx'), (b_def, rhs')) (type_params, term_params);
 
     (*local definition*)
     val ([(lhs, (_, local_def))], lthy3) = lthy2
       |> Context_Position.set_visible false
       |> Local_Defs.define [((b, NoSyn), (Binding.empty_atts, lhs'))]
       ||> Context_Position.restore_visible lthy2;
 
     (*result*)
     val def =
       Thm.transitive local_def global_def
       |> Local_Defs.contract lthy3 defs (Thm.cterm_of lthy3 (Logic.mk_equals (lhs, rhs)));
     val ([(res_name, [res])], lthy4) = lthy3
       |> Local_Theory.notes [((if internal then Binding.empty else b_def, atts), [([def], [])])];
   in ((lhs, (res_name, res)), lthy4) end;
 
 
 (* notes *)
 
 local
 
 fun import_export_proof ctxt (name, raw_th) =
   let
     val thy_ctxt = Proof_Context.init_global (Proof_Context.theory_of ctxt);
 
     (*export assumes/defines*)
     val th = Goal.norm_result ctxt raw_th;
     val ((defs, asms), th') = Local_Defs.export ctxt thy_ctxt th;
     val asms' = map (rewrite_rule ctxt (Drule.norm_hhf_eqs @ defs)) asms;
 
     (*export fixes*)
     val tfrees = map TFree (Thm.fold_terms Term.add_tfrees th' []);
     val frees = map Free (Thm.fold_terms Term.add_frees th' []);
     val (th'' :: vs) =
       (th' :: map (Drule.mk_term o Thm.cterm_of ctxt) (map Logic.mk_type tfrees @ frees))
       |> Variable.export ctxt thy_ctxt
       |> Drule.zero_var_indexes_list;
 
     (*thm definition*)
     val result = Global_Theory.name_thm Global_Theory.official1 name th'';
 
     (*import fixes*)
     val (tvars, vars) =
       chop (length tfrees) (map (Thm.term_of o Drule.dest_term) vs)
       |>> map Logic.dest_type;
 
     val instT =
-      fold2 (fn a => fn b => (case a of TVar v => Term_Subst.TVars.add (v, b) | _ => I))
-        tvars tfrees Term_Subst.TVars.empty;
+      Term_Subst.TVars.build (fold2 (fn a => fn b =>
+        (case a of TVar v => Term_Subst.TVars.add (v, b) | _ => I)) tvars tfrees);
     val cinstT = Term_Subst.TVars.fold (fn (v, T) => cons (v, Thm.ctyp_of ctxt T)) instT [];
     val cinst =
       map_filter
         (fn (Var (xi, T), t) =>
           SOME ((xi, Term_Subst.instantiateT instT T),
             Thm.cterm_of ctxt (Term.map_types (Term_Subst.instantiateT instT) t))
         | _ => NONE) (vars ~~ frees);
     val result' = Thm.instantiate (cinstT, cinst) result;
 
     (*import assumes/defines*)
     val result'' =
       (fold (curry op COMP) asms' result'
         handle THM _ => raise THM ("Failed to re-import result", 0, result' :: asms'))
       |> Local_Defs.contract ctxt defs (Thm.cprop_of th)
       |> Goal.norm_result ctxt
       |> Global_Theory.name_thm Global_Theory.unofficial2 name;
 
   in (result'', result) end;
 
 fun bind_name lthy b =
   (Local_Theory.full_name lthy b, Binding.default_pos_of b);
 
 fun map_facts f = map (apsnd (map (apfst (map f))));
 
 in
 
 fun notes target_notes kind facts lthy =
   let
     val facts' = facts
       |> map (fn (a, bs) =>
           (a, Global_Theory.burrow_fact (Global_Theory.name_multi (bind_name lthy (fst a))) bs))
       |> map_facts (import_export_proof lthy);
     val local_facts = map_facts #1 facts';
     val global_facts = map_facts #2 facts';
   in
     lthy
     |> target_notes kind global_facts (Attrib.partial_evaluation lthy local_facts)
     |> Attrib.local_notes kind local_facts
   end;
 
 end;
 
 
 (* abbrev *)
 
 fun abbrev target_abbrev prmode ((b, mx), rhs) lthy =
   let
     val (global_rhs, (extra_tfrees, (type_params, term_params))) = export_abbrev lthy I rhs;
     val mx' = check_mixfix lthy (b, extra_tfrees) mx;
   in
     lthy
     |> target_abbrev prmode (b, mx') global_rhs (type_params, term_params)
     |> Context_Position.set_visible false
     |> Proof_Context.add_abbrev Print_Mode.internal (b, rhs) |> snd
     |> Local_Defs.fixed_abbrev ((b, NoSyn), rhs)
     ||> Context_Position.restore_visible lthy
   end;
 
 
 
 (** theory target primitives **)
 
 fun theory_target_foundation (((b, U), mx), (b_def, rhs)) (type_params, term_params) =
   background_foundation (((b, U), mx), (b_def, rhs)) (type_params, term_params)
   #-> (fn (lhs, def) => standard_const (op <>) Syntax.mode_default ((b, mx), lhs)
     #> pair (lhs, def));
 
 fun theory_target_notes kind global_facts local_facts =
   Local_Theory.background_theory (Attrib.global_notes kind global_facts #> snd)
   #> standard_notes (op <>) kind local_facts;
 
 fun theory_target_abbrev prmode (b, mx) global_rhs params =
   Local_Theory.background_theory_result
     (Sign.add_abbrev (#1 prmode) (b, global_rhs) #->
       (fn (lhs, _) =>  (* FIXME type_params!? *)
         Sign.notation true prmode
           [(lhs, check_mixfix_global (b, null (snd params)) mx)] #> pair lhs))
   #-> (fn lhs =>
         standard_const (op <>) prmode
           ((b, if null (snd params) then NoSyn else mx),
             Term.list_comb (Logic.unvarify_global lhs, snd params)));
 
 
 (** theory operations **)
 
 val theory_abbrev = abbrev theory_target_abbrev;
 
 fun theory_declaration decl =
   background_declaration decl #> standard_declaration (K true) decl;
 
 fun target_registration lthy {inst, mixin, export} =
   {inst = inst, mixin = mixin,
     export = export $> Proof_Context.export_morphism lthy (Local_Theory.target_of lthy)};
 
 fun theory_registration registration lthy =
   lthy
   |> (Local_Theory.raw_theory o Context.theory_map)
     (Locale.add_registration (target_registration lthy registration))
   |> standard_registration (K true) registration;
 
 
 (** locale target primitives **)
 
 fun locale_target_notes locale kind global_facts local_facts =
   Local_Theory.background_theory
     (Attrib.global_notes kind (Attrib.map_facts (K []) global_facts) #> snd) #>
   (fn lthy => lthy |>
     Local_Theory.target (fn ctxt => ctxt |>
       Locale.add_facts locale kind (standard_facts lthy ctxt local_facts))) #>
   standard_notes (fn (this, other) => other <> 0 andalso this <> other) kind local_facts;
 
 fun locale_target_declaration locale syntax decl lthy = lthy
   |> Local_Theory.target (fn ctxt => ctxt |>
     Locale.add_declaration locale syntax
       (Morphism.transform (Local_Theory.standard_morphism lthy ctxt) decl));
 
 fun locale_target_const locale phi_pred prmode ((b, mx), rhs) =
   locale_target_declaration locale true (const_decl phi_pred prmode ((b, mx), rhs))
 
 
 (** locale operations **)
 
 fun locale_declaration locale {syntax, pervasive} decl =
   pervasive ? background_declaration decl
   #> locale_target_declaration locale syntax decl
   #> standard_declaration (fn (_, other) => other <> 0) decl;
 
 fun locale_const locale prmode ((b, mx), rhs) =
   locale_target_const locale (K true) prmode ((b, mx), rhs)
   #> standard_const (fn (this, other) => other <> 0 andalso this <> other) prmode ((b, mx), rhs);
 
 fun locale_dependency loc registration lthy =
   lthy
   |> Local_Theory.raw_theory (Locale.add_dependency loc registration)
   |> standard_registration (K true) registration;
 
 
 (** locale abbreviations **)
 
 fun locale_target_abbrev locale prmode (b, mx) global_rhs params =
   background_abbrev (b, global_rhs) (snd params)
   #-> (fn (lhs, _) => locale_const locale prmode ((b, mx), lhs));
 
 fun locale_abbrev locale = abbrev (locale_target_abbrev locale);
 
 end;
diff --git a/src/Pure/Isar/obtain.ML b/src/Pure/Isar/obtain.ML
--- a/src/Pure/Isar/obtain.ML
+++ b/src/Pure/Isar/obtain.ML
@@ -1,426 +1,427 @@
 (*  Title:      Pure/Isar/obtain.ML
     Author:     Markus Wenzel, TU Muenchen
 
 Generalized existence and cases rules within Isar proof text.
 *)
 
 signature OBTAIN =
 sig
   val obtain_thesis: Proof.context -> ((string * typ) * term) * Proof.context
   val obtains_attributes: ('typ, 'term) Element.obtain list -> attribute list
   val obtains_attribs: ('typ, 'term) Element.obtain list -> Token.src list
   val read_obtains: Proof.context -> term -> Element.obtains -> (binding * term) list
   val cert_obtains: Proof.context -> term -> Element.obtains_i -> (binding * term) list
   val parse_obtains: Proof.context -> term -> Element.obtains -> (binding * term) list
   val consider: Element.obtains_i -> bool -> Proof.state -> Proof.state
   val consider_cmd: Element.obtains -> bool -> Proof.state -> Proof.state
   val obtain: binding -> (binding * typ option * mixfix) list ->
     (binding * typ option * mixfix) list -> (term * term list) list list ->
     (Thm.binding * (term * term list) list) list -> bool -> Proof.state -> Proof.state
   val obtain_cmd: binding -> (binding * string option * mixfix) list ->
     (binding * string option * mixfix) list -> (string * string list) list list ->
     (Attrib.binding * (string * string list) list) list -> bool -> Proof.state -> Proof.state
   val result: (Proof.context -> tactic) -> thm list -> Proof.context ->
     ((string * cterm) list * thm list) * Proof.context
   val guess: (binding * typ option * mixfix) list -> bool -> Proof.state -> Proof.state
   val guess_cmd: (binding * string option * mixfix) list -> bool -> Proof.state -> Proof.state
 end;
 
 structure Obtain: OBTAIN =
 struct
 
 (** specification elements **)
 
 (* obtain_export *)
 
 (*
   [x, A x]
      :
      B
   --------
      B
 *)
 fun eliminate_term ctxt xs tm =
   let
     val vs = map (dest_Free o Thm.term_of) xs;
     val bads = Term.fold_aterms (fn t as Free v =>
       if member (op =) vs v then insert (op aconv) t else I | _ => I) tm [];
     val _ = null bads orelse
       error ("Result contains obtained parameters: " ^
         space_implode " " (map (Syntax.string_of_term ctxt) bads));
   in tm end;
 
 fun eliminate ctxt rule xs As thm =
   let
     val _ = eliminate_term ctxt xs (Thm.full_prop_of thm);
     val _ = Object_Logic.is_judgment ctxt (Thm.concl_of thm) orelse
       error "Conclusion in obtained context must be object-logic judgment";
 
     val ((_, [thm']), ctxt') = Variable.import true [thm] ctxt;
     val prems = Drule.strip_imp_prems (Thm.cprop_of thm');
   in
     ((Drule.implies_elim_list thm' (map Thm.assume prems)
         |> Drule.implies_intr_list (map (Drule.norm_hhf_cterm ctxt') As)
         |> Drule.forall_intr_list xs)
       COMP rule)
     |> Drule.implies_intr_list prems
     |> singleton (Variable.export ctxt' ctxt)
   end;
 
 fun obtain_export ctxt rule xs _ As =
   (eliminate ctxt rule xs As, eliminate_term ctxt xs);
 
 
 (* result declaration *)
 
 fun case_names (obtains: ('typ, 'term) Element.obtain list) =
   obtains |> map_index (fn (i, (b, _)) =>
     if Binding.is_empty b then string_of_int (i + 1) else Name_Space.base_name b);
 
 fun obtains_attributes obtains =
   [Rule_Cases.consumes (~ (length obtains)), Rule_Cases.case_names (case_names obtains)];
 
 fun obtains_attribs obtains =
   [Attrib.consumes (~ (length obtains)), Attrib.case_names (case_names obtains)];
 
 
 (* obtain thesis *)
 
 fun obtain_thesis ctxt =
   let
     val ([x], ctxt') =
       Proof_Context.add_fixes [(Binding.name Auto_Bind.thesisN, NONE, NoSyn)] ctxt;
     val t = Object_Logic.fixed_judgment ctxt x;
     val v = dest_Free (Object_Logic.drop_judgment ctxt t);
   in ((v, t), ctxt') end;
 
 
 (* obtain clauses *)
 
 local
 
 val mk_all_external = Logic.all_constraint o Variable.default_type;
 
 fun mk_all_internal ctxt (y, z) t =
   let
     val frees =
-      (t, Term_Subst.Frees.empty)
-      |-> Term.fold_aterms (fn Free v => Term_Subst.Frees.add (v, ()) | _ => I);
+      Term_Subst.Frees.build (t |> Term.fold_aterms
+        (fn Free v => Term_Subst.Frees.add (v, ()) | _ => I));
     val T =
       (case Term_Subst.Frees.get_first (fn ((x, T), ()) => if x = z then SOME T else NONE) frees of
         SOME T => T
       | NONE => the_default dummyT (Variable.default_type ctxt z));
   in Logic.all_const T $ Term.lambda_name (y, Free (z, T)) t end;
 
 fun prepare_clause prep_var parse_prop mk_all ctxt thesis raw_vars raw_props =
   let
     val ((xs', vars), ctxt') = ctxt
       |> fold_map prep_var raw_vars
       |-> (fn vars => Proof_Context.add_fixes vars ##>> pair vars);
     val xs = map (Variable.check_name o #1) vars;
   in
     Logic.list_implies (map (parse_prop ctxt') raw_props, thesis)
     |> fold_rev (mk_all ctxt') (xs ~~ xs')
   end;
 
 fun prepare_obtains prep_clause check_terms
     ctxt thesis (raw_obtains: ('typ, 'term) Element.obtain list) =
   let
     val clauses = raw_obtains
       |> map (fn (_, (raw_vars, raw_props)) => prep_clause ctxt thesis raw_vars raw_props)
       |> check_terms ctxt;
   in map fst raw_obtains ~~ clauses end;
 
 val parse_clause = prepare_clause Proof_Context.read_var Syntax.parse_prop mk_all_external;
 val cert_clause = prepare_clause Proof_Context.cert_var (K I) mk_all_internal;
 
 in
 
 val read_obtains = prepare_obtains parse_clause Syntax.check_terms;
 val cert_obtains = prepare_obtains cert_clause (K I);
 val parse_obtains = prepare_obtains parse_clause (K I);
 
 end;
 
 
 
 (** consider: generalized elimination and cases rule **)
 
 (*
   consider (a) x where "A x" | (b) y where "B y" | ... \<equiv>
 
   have thesis
     if a [intro?]: "\<And>x. A x \<Longrightarrow> thesis"
     and b [intro?]: "\<And>y. B y \<Longrightarrow> thesis"
     and ...
     for thesis
     apply (insert that)
 *)
 
 local
 
 fun gen_consider prep_obtains raw_obtains int state =
   let
     val _ = Proof.assert_forward_or_chain state;
     val ctxt = Proof.context_of state;
 
     val ((_, thesis), thesis_ctxt) = obtain_thesis ctxt;
     val obtains = prep_obtains thesis_ctxt thesis raw_obtains;
     val atts = Rule_Cases.cases_open :: obtains_attributes raw_obtains;
   in
     state
     |> Proof.have true NONE (K I)
       [(Binding.name Auto_Bind.thesisN, NONE, NoSyn)]
       (map (fn (a, A) => ((a, [Context_Rules.intro_query NONE]), [(A, [])])) obtains)
       [((Binding.empty, atts), [(thesis, [])])] int
     |-> Proof.refine_insert
   end;
 
 in
 
 val consider = gen_consider cert_obtains;
 val consider_cmd = gen_consider read_obtains;
 
 end;
 
 
 
 (** obtain: augmented context based on generalized existence rule **)
 
 (*
   obtain (a) x where "A x" <proof> \<equiv>
 
   have thesis if a [intro?]: "\<And>x. A x \<Longrightarrow> thesis" for thesis
     apply (insert that)
     <proof>
   fix x assm <<obtain_export>> "A x"
 *)
 
 local
 
 fun gen_obtain prep_stmt prep_att that_binding raw_decls raw_fixes raw_prems raw_concls int state =
   let
     val _ = Proof.assert_forward_or_chain state;
 
     val ((_, thesis), thesis_ctxt) = obtain_thesis (Proof.context_of state);
 
     val ({vars, propss, binds, result_binds, ...}, params_ctxt) =
       prep_stmt (raw_decls @ raw_fixes) (raw_prems @ map #2 raw_concls) thesis_ctxt;
     val (decls, fixes) = chop (length raw_decls) vars ||> map #2;
     val (premss, conclss) = chop (length raw_prems) propss;
     val propss' = (map o map) (Logic.close_prop fixes (flat premss)) conclss;
 
     val that_prop =
       Logic.list_rename_params (map (#1 o #2) decls)
         (fold_rev (Logic.all o #2 o #2) decls (Logic.list_implies (flat propss', thesis)));
 
     val cparams = map (Thm.cterm_of params_ctxt o #2 o #2) decls;
     val asms =
       map (fn ((b, raw_atts), _) => (b, map (prep_att params_ctxt) raw_atts)) raw_concls ~~
       map (map (rpair [])) propss';
 
     fun after_qed (result_ctxt, results) state' =
       let val [rule] = Proof_Context.export result_ctxt (Proof.context_of state') (flat results) in
         state'
         |> Proof.fix (map #1 decls)
         |> Proof.map_context (fold (Variable.bind_term o apsnd (Logic.close_term fixes)) binds)
         |> Proof.assm (obtain_export params_ctxt rule cparams) [] [] asms
       end;
   in
     state
     |> Proof.have true NONE after_qed
       [(Binding.name Auto_Bind.thesisN, NONE, NoSyn)]
       [((that_binding, [Context_Rules.intro_query NONE]), [(that_prop, [])])]
       [(Binding.empty_atts, [(thesis, [])])] int
     |-> Proof.refine_insert
     |> Proof.map_context (fold Variable.bind_term result_binds)
   end;
 
 in
 
 val obtain = gen_obtain Proof_Context.cert_stmt (K I);
 val obtain_cmd = gen_obtain Proof_Context.read_stmt Attrib.attribute_cmd;
 
 end;
 
 
 
 (** tactical result **)
 
 fun check_result ctxt thesis th =
   (case Thm.prems_of th of
     [prem] =>
       if Thm.concl_of th aconv thesis andalso
         Logic.strip_assums_concl prem aconv thesis then th
       else error ("Guessed a different clause:\n" ^ Thm.string_of_thm ctxt th)
   | [] => error "Goal solved -- nothing guessed"
   | _ => error ("Guess split into several cases:\n" ^ Thm.string_of_thm ctxt th));
 
 fun result tac facts ctxt =
   let
     val ((thesis_var, thesis), thesis_ctxt) = obtain_thesis ctxt;
     val st = Goal.init (Thm.cterm_of ctxt thesis);
     val rule =
       (case SINGLE (Method.insert_tac thesis_ctxt facts 1 THEN tac thesis_ctxt) st of
         NONE => raise THM ("Obtain.result: tactic failed", 0, facts)
       | SOME th =>
           check_result thesis_ctxt thesis (Raw_Simplifier.norm_hhf thesis_ctxt (Goal.conclude th)));
 
     val closed_rule = Thm.forall_intr (Thm.cterm_of ctxt (Free thesis_var)) rule;
     val ((_, [rule']), ctxt') = Variable.import false [closed_rule] ctxt;
     val obtain_rule =
       Thm.forall_elim (Thm.cterm_of ctxt (Logic.varify_global (Free thesis_var))) rule';
     val ((params, stmt), fix_ctxt) = Variable.focus_cterm NONE (Thm.cprem_of obtain_rule 1) ctxt';
     val (prems, ctxt'') =
       Assumption.add_assms (obtain_export fix_ctxt obtain_rule (map #2 params))
         (Drule.strip_imp_prems stmt) fix_ctxt;
   in ((params, prems), ctxt'') end;
 
 
 
 (** guess: obtain based on tactical result **)
 
 (*
   <chain_facts>
   guess x <proof body> <proof end> \<equiv>
 
   {
     fix thesis
     <chain_facts> have "PROP ?guess"
       apply magic      \<comment> \<open>turn goal into \<open>thesis \<Longrightarrow> #thesis\<close>\<close>
       <proof body>
       apply_end magic  \<comment> \<open>turn final \<open>(\<And>x. P x \<Longrightarrow> thesis) \<Longrightarrow> #thesis\<close> into\<close>
         \<comment> \<open>\<open>#((\<And>x. A x \<Longrightarrow> thesis) \<Longrightarrow> thesis)\<close> which is a finished goal state\<close>
       <proof end>
   }
   fix x assm <<obtain_export>> "A x"
 *)
 
 local
 
 fun unify_params vars thesis_var raw_rule ctxt =
   let
     val thy = Proof_Context.theory_of ctxt;
     val string_of_term = Syntax.string_of_term (Config.put show_types true ctxt);
 
     fun err msg th = error (msg ^ ":\n" ^ Thm.string_of_thm ctxt th);
 
     val maxidx = fold (Term.maxidx_typ o snd o fst) vars ~1;
     val rule = Thm.incr_indexes (maxidx + 1) raw_rule;
 
     val params = Rule_Cases.strip_params (Logic.nth_prem (1, Thm.prop_of rule));
     val m = length vars;
     val n = length params;
     val _ = m <= n orelse err "More variables than parameters in obtained rule" rule;
 
     fun unify ((x, T), (y, U)) (tyenv, max) = Sign.typ_unify thy (T, U) (tyenv, max)
       handle Type.TUNIFY =>
         err ("Failed to unify variable " ^
           string_of_term (Free (x, Envir.norm_type tyenv T)) ^ " against parameter " ^
           string_of_term (Syntax_Trans.mark_bound_abs (y, Envir.norm_type tyenv U)) ^ " in") rule;
     val (tyenv, _) = fold unify (map #1 vars ~~ take m params)
       (Vartab.empty, Int.max (maxidx, Thm.maxidx_of rule));
     val norm_type = Envir.norm_type tyenv;
 
     val xs = map (apsnd norm_type o fst) vars;
     val ys = map (apsnd norm_type) (drop m params);
     val ys' = map Name.internal (Name.variant_list (map fst xs) (map fst ys)) ~~ map #2 ys;
     val terms = map (Drule.mk_term o Thm.cterm_of ctxt o Free) (xs @ ys');
 
     val instT =
-      (params, Term_Subst.TVars.empty) |-> fold (#2 #> Term.fold_atyps (fn T => fn instT =>
-        (case T of
-          TVar v =>
-            if Term_Subst.TVars.defined instT v then instT
-            else Term_Subst.TVars.update (v, Thm.ctyp_of ctxt (norm_type T)) instT
-        | _ => instT)));
+      Term_Subst.TVars.build
+        (params |> fold (#2 #> Term.fold_atyps (fn T => fn instT =>
+          (case T of
+            TVar v =>
+              if Term_Subst.TVars.defined instT v then instT
+              else Term_Subst.TVars.update (v, Thm.ctyp_of ctxt (norm_type T)) instT
+          | _ => instT))));
     val closed_rule = rule
       |> Thm.forall_intr (Thm.cterm_of ctxt (Free thesis_var))
       |> Thm.instantiate (Term_Subst.TVars.dest instT, []);
 
     val ((_, rule' :: terms'), ctxt') = Variable.import false (closed_rule :: terms) ctxt;
     val vars' =
       map (dest_Free o Thm.term_of o Drule.dest_term) terms' ~~
       (map snd vars @ replicate (length ys) NoSyn);
     val rule'' = Thm.forall_elim (Thm.cterm_of ctxt' (Logic.varify_global (Free thesis_var))) rule';
   in ((vars', rule''), ctxt') end;
 
 fun inferred_type (binding, _, mx) ctxt =
   let
     val x = Variable.check_name binding;
     val ((_, T), ctxt') = Proof_Context.inferred_param x ctxt
   in ((x, T, mx), ctxt') end;
 
 fun polymorphic ctxt vars =
   let val Ts = map Logic.dest_type (Variable.polymorphic ctxt (map (Logic.mk_type o #2) vars))
   in map2 (fn (x, _, mx) => fn T => ((x, T), mx)) vars Ts end;
 
 fun gen_guess prep_var raw_vars int state =
   let
     val _ = Proof.assert_forward_or_chain state;
     val ctxt = Proof.context_of state;
     val chain_facts = if can Proof.assert_chain state then Proof.the_facts state else [];
 
     val (thesis_var, thesis) = #1 (obtain_thesis ctxt);
     val vars = ctxt
       |> fold_map prep_var raw_vars |-> fold_map inferred_type
       |> fst |> polymorphic ctxt;
 
     fun guess_context raw_rule state' =
       let
         val ((parms, rule), ctxt') =
           unify_params vars thesis_var raw_rule (Proof.context_of state');
         val (xs, _) = Variable.add_fixes (map (#1 o #1) parms) ctxt';
         val ps = xs ~~ map (#2 o #1) parms;
         val ts = map Free ps;
         val asms =
           Logic.strip_assums_hyp (Logic.nth_prem (1, Thm.prop_of rule))
           |> map (fn asm => (Term.betapplys (fold_rev Term.abs ps asm, ts), []));
         val _ = not (null asms) orelse error "Trivial result -- nothing guessed";
       in
         state'
         |> Proof.map_context (K ctxt')
         |> Proof.fix (map (fn ((x, T), mx) => (Binding.name x, SOME T, mx)) parms)
         |> `Proof.context_of |-> (fn fix_ctxt => Proof.assm
           (obtain_export fix_ctxt rule (map (Thm.cterm_of ctxt) ts))
             [] [] [(Binding.empty_atts, asms)])
         |> Proof.map_context (fold Variable.unbind_term Auto_Bind.no_facts)
       end;
 
     val goal = Var (("guess", 0), propT);
     val pos = Position.thread_data ();
     fun print_result ctxt' (k, [(s, [_, th])]) =
       Proof_Display.print_results int pos ctxt' (k, [(s, [th])]);
     val before_qed =
       Method.primitive_text (fn ctxt =>
         Goal.conclude #> Raw_Simplifier.norm_hhf ctxt #>
           (fn th => Goal.protect 0 (Conjunction.intr (Drule.mk_term (Thm.cprop_of th)) th)));
     fun after_qed (result_ctxt, results) state' =
       let val [_, res] = Proof_Context.export result_ctxt (Proof.context_of state') (flat results)
       in
         state'
         |> Proof.end_block
         |> guess_context (check_result ctxt thesis res)
       end;
   in
     state
     |> Proof.enter_forward
     |> Proof.begin_block
     |> Proof.fix [(Binding.name Auto_Bind.thesisN, NONE, NoSyn)]
     |> Proof.chain_facts chain_facts
     |> Proof.internal_goal print_result Proof_Context.mode_schematic true "guess"
       (SOME before_qed) after_qed
       [] [] [(Binding.empty_atts, [(Logic.mk_term goal, []), (goal, [])])]
     |> snd
     |> Proof.refine_singleton
         (Method.primitive_text (fn _ => fn _ => Goal.init (Thm.cterm_of ctxt thesis)))
   end;
 
 in
 
 val guess = gen_guess Proof_Context.cert_var;
 val guess_cmd = gen_guess Proof_Context.read_var;
 
 end;
 
 end;
diff --git a/src/Pure/Isar/overloading.ML b/src/Pure/Isar/overloading.ML
--- a/src/Pure/Isar/overloading.ML
+++ b/src/Pure/Isar/overloading.ML
@@ -1,226 +1,226 @@
 (*  Title:      Pure/Isar/overloading.ML
     Author:     Florian Haftmann, TU Muenchen
 
 Overloaded definitions without any discipline.
 *)
 
 signature OVERLOADING =
 sig
   type improvable_syntax
   val activate_improvable_syntax: Proof.context -> Proof.context
   val map_improvable_syntax: (improvable_syntax -> improvable_syntax)
     -> Proof.context -> Proof.context
   val set_primary_constraints: Proof.context -> Proof.context
   val show_reverted_improvements: bool Config.T;
 
   val overloading: (string * (string * typ) * bool) list -> theory -> local_theory
   val overloading_cmd: (string * string * bool) list -> theory -> local_theory
   val theory_map: (string * (string * typ) * bool) list
     -> (local_theory -> local_theory) -> theory -> theory
   val theory_map_result: (string * (string * typ) * bool) list
     -> (morphism -> 'a -> 'b) -> (local_theory -> 'a * local_theory)
     -> theory -> 'b * theory
 end;
 
 structure Overloading: OVERLOADING =
 struct
 
 (* generic check/uncheck combinators for improvable constants *)
 
 type improvable_syntax = {
   primary_constraints: (string * typ) list,
   secondary_constraints: (string * typ) list,
   improve: string * typ -> (typ * typ) option,
   subst: string * typ -> (typ * term) option,
   no_subst_in_abbrev_mode: bool,
   unchecks: (term * term) list
 }
 
 structure Improvable_Syntax = Proof_Data
 (
   type T = {syntax: improvable_syntax, secondary_pass: bool}
   fun init _ = {syntax = {
       primary_constraints = [],
       secondary_constraints = [],
       improve = K NONE,
       subst = K NONE,
       no_subst_in_abbrev_mode = false,
       unchecks = []
     }, secondary_pass = false}: T;
 );
 
 fun map_improvable_syntax f =
   Improvable_Syntax.map (fn {syntax, secondary_pass} => {syntax = f syntax, secondary_pass = secondary_pass});
 
 val mark_passed =
   Improvable_Syntax.map (fn {syntax, secondary_pass} => {syntax = syntax, secondary_pass = true});
 
 fun improve_term_check ts ctxt =
   let
     val thy = Proof_Context.theory_of ctxt;
 
     val {syntax = {secondary_constraints, improve, subst, no_subst_in_abbrev_mode, ...}, secondary_pass} =
       Improvable_Syntax.get ctxt;
     val no_subst = Proof_Context.abbrev_mode ctxt andalso no_subst_in_abbrev_mode;
     fun accumulate_improvements (Const (c, ty)) =
           (case improve (c, ty) of
             SOME ty_ty' => Sign.typ_match thy ty_ty'
           | _ => I)
       | accumulate_improvements _ = I;
     fun apply_subst t =
       Envir.expand_term
         (fn Const (c, ty) =>
           (case subst (c, ty) of
             SOME (ty', t') =>
               if Sign.typ_instance thy (ty, ty')
               then SOME (ty', apply_subst t') else NONE
           | NONE => NONE)
         | _ => NONE) t;
-    val improvements = (fold o fold_aterms) accumulate_improvements ts Vartab.empty;
+    val improvements = Vartab.build ((fold o fold_aterms) accumulate_improvements ts);
     val ts' =
       ts
       |> (map o map_types) (Envir.subst_type improvements)
       |> not no_subst ? map apply_subst;
   in
     if secondary_pass orelse no_subst then
       if eq_list (op aconv) (ts, ts') then NONE
       else SOME (ts', ctxt)
     else
       SOME (ts', ctxt
         |> fold (Proof_Context.add_const_constraint o apsnd SOME) secondary_constraints
         |> mark_passed)
   end;
 
 fun rewrite_liberal thy unchecks t =
   (case try (Pattern.rewrite_term_top thy unchecks []) t of
     NONE => NONE
   | SOME t' => if t aconv t' then NONE else SOME t');
 
 val show_reverted_improvements =
   Attrib.setup_config_bool \<^binding>\<open>show_reverted_improvements\<close> (K true);
 
 fun improve_term_uncheck ts ctxt =
   let
     val thy = Proof_Context.theory_of ctxt;
     val {syntax = {unchecks, ...}, ...} = Improvable_Syntax.get ctxt;
     val revert = Config.get ctxt show_reverted_improvements;
     val ts' = map (rewrite_liberal thy unchecks) ts;
   in if revert andalso exists is_some ts' then SOME (map2 the_default ts ts', ctxt) else NONE end;
 
 fun set_primary_constraints ctxt =
   let
     val {syntax = {primary_constraints, ...}, ...} = Improvable_Syntax.get ctxt;
   in fold (Proof_Context.add_const_constraint o apsnd SOME) primary_constraints ctxt end;
 
 val activate_improvable_syntax =
   Context.proof_map
     (Syntax_Phases.term_check' 0 "improvement" improve_term_check
     #> Syntax_Phases.term_uncheck' 0 "improvement" improve_term_uncheck)
   #> set_primary_constraints;
 
 
 (* overloading target *)
 
 structure Data = Proof_Data
 (
   type T = ((string * typ) * (string * bool)) list;
   fun init _ = [];
 );
 
 val get_overloading = Data.get o Local_Theory.target_of;
 val map_overloading = Local_Theory.target o Data.map;
 
 fun operation lthy b =
   get_overloading lthy
   |> get_first (fn ((c, _), (v, checked)) =>
       if Binding.name_of b = v then SOME (c, (v, checked)) else NONE);
 
 fun synchronize_syntax ctxt =
   let
     val overloading = Data.get ctxt;
     fun subst (c, ty) =
       (case AList.lookup (op =) overloading (c, ty) of
         SOME (v, _) => SOME (ty, Free (v, ty))
       | NONE => NONE);
     val unchecks =
       map (fn (c_ty as (_, ty), (v, _)) => (Free (v, ty), Const c_ty)) overloading;
   in
     ctxt
     |> map_improvable_syntax (K {primary_constraints = [],
       secondary_constraints = [], improve = K NONE, subst = subst,
       no_subst_in_abbrev_mode = false, unchecks = unchecks})
   end;
 
 fun define_overloaded (c, U) (v, checked) (b_def, rhs) =
   Local_Theory.background_theory_result
     (Thm.add_def_global (not checked) true
       (Thm.def_binding_optional (Binding.name v) b_def,
         Logic.mk_equals (Const (c, Term.fastype_of rhs), rhs)))
   ##> map_overloading (filter_out (fn (_, (v', _)) => v' = v))
   ##> Local_Theory.map_contexts (K synchronize_syntax)
   #-> (fn (_, def) => pair (Const (c, U), def));
 
 fun foundation (((b, U), mx), (b_def, rhs)) params lthy =
   (case operation lthy b of
     SOME (c, (v, checked)) =>
       if Mixfix.is_empty mx then
         lthy |> define_overloaded (c, U) (v, checked) (b_def, rhs)
       else error ("Illegal mixfix syntax for overloaded constant " ^ quote c)
   | NONE => lthy |> Generic_Target.theory_target_foundation (((b, U), mx), (b_def, rhs)) params);
 
 fun pretty lthy =
   let
     val overloading = get_overloading lthy;
     fun pr_operation ((c, ty), (v, _)) =
       Pretty.block (Pretty.breaks
         [Pretty.str v, Pretty.str "\<equiv>", Proof_Context.pretty_const lthy c,
           Pretty.str "::", Syntax.pretty_typ lthy ty]);
   in
     [Pretty.block
       (Pretty.fbreaks (Pretty.keyword1 "overloading" :: map pr_operation overloading))]
   end;
 
 fun conclude lthy =
   let
     val overloading = get_overloading lthy;
     val _ =
       if null overloading then ()
       else
         error ("Missing definition(s) for parameter(s) " ^
           commas_quote (map (Syntax.string_of_term lthy o Const o fst) overloading));
   in lthy end;
 
 fun gen_overloading prep_const raw_overloading_spec thy =
   let
     val ctxt = Proof_Context.init_global thy;
     val _ = if null raw_overloading_spec then error "At least one parameter must be given" else ();
     val overloading_spec = raw_overloading_spec |> map (fn (v, const, checked) =>
       (Term.dest_Const (prep_const ctxt const), (v, checked)));
   in
     thy
     |> Local_Theory.init
        {background_naming = Sign.naming_of thy,
         setup = Proof_Context.init_global
           #> Data.put overloading_spec
           #> fold (fn ((_, ty), (v, _)) => Variable.declare_names (Free (v, ty))) overloading_spec
           #> activate_improvable_syntax
           #> synchronize_syntax,
         conclude = conclude}
        {define = Generic_Target.define foundation,
         notes = Generic_Target.notes Generic_Target.theory_target_notes,
         abbrev = Generic_Target.abbrev Generic_Target.theory_target_abbrev,
         declaration = K Generic_Target.theory_declaration,
         theory_registration = Generic_Target.theory_registration,
         locale_dependency = fn _ => error "Not possible in overloading target",
         pretty = pretty}
   end;
 
 val overloading = gen_overloading (fn ctxt => Syntax.check_term ctxt o Const);
 val overloading_cmd = gen_overloading Syntax.read_term;
 
 fun theory_map overloading_spec g =
   overloading overloading_spec #> g #> Local_Theory.exit_global;
 fun theory_map_result overloading_spec f g =
   overloading overloading_spec #> g #> Local_Theory.exit_result_global f;
 
 end;
diff --git a/src/Pure/Isar/proof_context.ML b/src/Pure/Isar/proof_context.ML
--- a/src/Pure/Isar/proof_context.ML
+++ b/src/Pure/Isar/proof_context.ML
@@ -1,1657 +1,1657 @@
 (*  Title:      Pure/Isar/proof_context.ML
     Author:     Markus Wenzel, TU Muenchen
 
 The key concept of Isar proof contexts: elevates primitive local
 reasoning Gamma |- phi to a structured concept, with generic context
 elements.  See also structure Variable and Assumption.
 *)
 
 signature PROOF_CONTEXT =
 sig
   val theory_of: Proof.context -> theory
   val init_global: theory -> Proof.context
   val get_global: theory -> string -> Proof.context
   type mode
   val mode_default: mode
   val mode_pattern: mode
   val mode_schematic: mode
   val mode_abbrev: mode
   val set_mode: mode -> Proof.context -> Proof.context
   val get_mode: Proof.context -> mode
   val restore_mode: Proof.context -> Proof.context -> Proof.context
   val abbrev_mode: Proof.context -> bool
   val syn_of: Proof.context -> Syntax.syntax
   val tsig_of: Proof.context -> Type.tsig
   val set_defsort: sort -> Proof.context -> Proof.context
   val default_sort: Proof.context -> indexname -> sort
   val arity_sorts: Proof.context -> string -> sort -> sort list
   val consts_of: Proof.context -> Consts.T
   val set_syntax_mode: Syntax.mode -> Proof.context -> Proof.context
   val restore_syntax_mode: Proof.context -> Proof.context -> Proof.context
   val map_naming: (Name_Space.naming -> Name_Space.naming) -> Proof.context -> Proof.context
   val naming_of: Proof.context -> Name_Space.naming
   val restore_naming: Proof.context -> Proof.context -> Proof.context
   val full_name: Proof.context -> binding -> string
   val get_scope: Proof.context -> Binding.scope option
   val new_scope: Proof.context -> Binding.scope * Proof.context
   val private_scope: Binding.scope -> Proof.context -> Proof.context
   val private: Position.T -> Proof.context -> Proof.context
   val qualified_scope: Binding.scope -> Proof.context -> Proof.context
   val qualified: Position.T -> Proof.context -> Proof.context
   val concealed: Proof.context -> Proof.context
   val class_space: Proof.context -> Name_Space.T
   val type_space: Proof.context -> Name_Space.T
   val const_space: Proof.context -> Name_Space.T
   val defs_context: Proof.context -> Defs.context
   val intern_class: Proof.context -> xstring -> string
   val intern_type: Proof.context -> xstring -> string
   val intern_const: Proof.context -> xstring -> string
   val extern_class: Proof.context -> string -> xstring
   val markup_class: Proof.context -> string -> string
   val pretty_class: Proof.context -> string -> Pretty.T
   val extern_type: Proof.context -> string -> xstring
   val markup_type: Proof.context -> string -> string
   val pretty_type: Proof.context -> string -> Pretty.T
   val extern_const: Proof.context -> string -> xstring
   val markup_const: Proof.context -> string -> string
   val pretty_const: Proof.context -> string -> Pretty.T
   val transfer: theory -> Proof.context -> Proof.context
   val transfer_facts: theory -> Proof.context -> Proof.context
   val background_theory: (theory -> theory) -> Proof.context -> Proof.context
   val background_theory_result: (theory -> 'a * theory) -> Proof.context -> 'a * Proof.context
   val facts_of: Proof.context -> Facts.T
   val facts_of_fact: Proof.context -> string -> Facts.T
   val markup_extern_fact: Proof.context -> string -> Markup.T list * xstring
   val augment: term -> Proof.context -> Proof.context
   val print_name: Proof.context -> string -> string
   val pretty_name: Proof.context -> string -> Pretty.T
   val pretty_term_abbrev: Proof.context -> term -> Pretty.T
   val pretty_fact: Proof.context -> string * thm list -> Pretty.T
   val check_class: Proof.context -> xstring * Position.T -> class * Position.report list
   val read_class: Proof.context -> string -> class
   val read_typ: Proof.context -> string -> typ
   val read_typ_syntax: Proof.context -> string -> typ
   val read_typ_abbrev: Proof.context -> string -> typ
   val cert_typ: Proof.context -> typ -> typ
   val cert_typ_syntax: Proof.context -> typ -> typ
   val cert_typ_abbrev: Proof.context -> typ -> typ
   val infer_type: Proof.context -> string * typ -> typ
   val inferred_param: string -> Proof.context -> (string * typ) * Proof.context
   val inferred_fixes: Proof.context -> (string * typ) list * Proof.context
   val check_type_name: {proper: bool, strict: bool} -> Proof.context ->
     xstring * Position.T -> typ * Position.report list
   val read_type_name: {proper: bool, strict: bool} -> Proof.context -> string -> typ
   val consts_completion_message: Proof.context -> xstring * Position.T list -> string
   val check_const: {proper: bool, strict: bool} -> Proof.context ->
     xstring * Position.T list -> term * Position.report list
   val read_const: {proper: bool, strict: bool} -> Proof.context -> string -> term
   val read_arity: Proof.context -> xstring * string list * string -> arity
   val cert_arity: Proof.context -> arity -> arity
   val allow_dummies: Proof.context -> Proof.context
   val prepare_sortsT: Proof.context -> typ list -> string list * typ list
   val prepare_sorts: Proof.context -> term list -> string list * term list
   val check_tfree: Proof.context -> string * sort -> string * sort
   val read_term_pattern: Proof.context -> string -> term
   val read_term_schematic: Proof.context -> string -> term
   val read_term_abbrev: Proof.context -> string -> term
   val show_abbrevs: bool Config.T
   val expand_abbrevs: Proof.context -> term -> term
   val cert_term: Proof.context -> term -> term
   val cert_prop: Proof.context -> term -> term
   val def_type: Proof.context -> indexname -> typ option
   val standard_typ_check: Proof.context -> typ list -> typ list
   val standard_term_check_finish: Proof.context -> term list -> term list
   val standard_term_uncheck: Proof.context -> term list -> term list
   val goal_export: Proof.context -> Proof.context -> thm list -> thm list
   val export: Proof.context -> Proof.context -> thm list -> thm list
   val export_morphism: Proof.context -> Proof.context -> morphism
   val norm_export_morphism: Proof.context -> Proof.context -> morphism
   val auto_bind_goal: term list -> Proof.context -> Proof.context
   val auto_bind_facts: term list -> Proof.context -> Proof.context
   val simult_matches: Proof.context -> term * term list -> (indexname * term) list
   val maybe_bind_term: indexname * term option -> Proof.context -> Proof.context
   val bind_term: indexname * term -> Proof.context -> Proof.context
   val cert_propp: Proof.context -> (term * term list) list list ->
     (term list list * (indexname * term) list)
   val read_propp: Proof.context -> (string * string list) list list ->
     (term list list * (indexname * term) list)
   val fact_tac: Proof.context -> thm list -> int -> tactic
   val some_fact_tac: Proof.context -> int -> tactic
   val lookup_fact: Proof.context -> string -> {dynamic: bool, thms: thm list} option
   val dynamic_facts_dummy: bool Config.T
   val get_fact_generic: Context.generic -> Facts.ref -> string option * thm list
   val get_fact: Proof.context -> Facts.ref -> thm list
   val get_fact_single: Proof.context -> Facts.ref -> thm
   val get_thms: Proof.context -> xstring -> thm list
   val get_thm: Proof.context -> xstring -> thm
   val is_stmt: Proof.context -> bool
   val set_stmt: bool -> Proof.context -> Proof.context
   val restore_stmt: Proof.context -> Proof.context -> Proof.context
   val add_thms_dynamic: binding * (Context.generic -> thm list) ->
     Proof.context -> string * Proof.context
   val add_thms_lazy: string -> (binding * thm list lazy) -> Proof.context -> Proof.context
   val note_thms: string -> Thm.binding * (thm list * attribute list) list ->
     Proof.context -> (string * thm list) * Proof.context
   val note_thmss: string -> (Thm.binding * (thm list * attribute list) list) list ->
     Proof.context -> (string * thm list) list * Proof.context
   val put_thms: bool -> string * thm list option -> Proof.context -> Proof.context
   val alias_fact: binding -> string -> Proof.context -> Proof.context
   val read_var: binding * string option * mixfix -> Proof.context ->
     (binding * typ option * mixfix) * Proof.context
   val cert_var: binding * typ option * mixfix -> Proof.context ->
     (binding * typ option * mixfix) * Proof.context
   val add_fixes: (binding * typ option * mixfix) list -> Proof.context ->
     string list * Proof.context
   val add_fixes_cmd: (binding * string option * mixfix) list -> Proof.context ->
     string list * Proof.context
   val add_assms: Assumption.export ->
     (Thm.binding * (term * term list) list) list ->
     Proof.context -> (string * thm list) list * Proof.context
   val add_assms_cmd: Assumption.export ->
     (Thm.binding * (string * string list) list) list ->
     Proof.context -> (string * thm list) list * Proof.context
   val dest_cases: Proof.context option -> Proof.context -> (string * Rule_Cases.T) list
   val update_cases: (string * Rule_Cases.T option) list -> Proof.context -> Proof.context
   val apply_case: Rule_Cases.T -> Proof.context -> (string * term list) list * Proof.context
   val check_case: Proof.context -> bool ->
     string * Position.T -> binding option list -> Rule_Cases.T
   val type_notation: bool -> Syntax.mode -> (typ * mixfix) list -> Proof.context -> Proof.context
   val notation: bool -> Syntax.mode -> (term * mixfix) list -> Proof.context -> Proof.context
   val generic_type_notation: bool -> Syntax.mode -> (typ * mixfix) list -> morphism ->
     Context.generic -> Context.generic
   val generic_notation: bool -> Syntax.mode -> (term * mixfix) list -> morphism ->
     Context.generic -> Context.generic
   val type_alias: binding -> string -> Proof.context -> Proof.context
   val const_alias: binding -> string -> Proof.context -> Proof.context
   val add_const_constraint: string * typ option -> Proof.context -> Proof.context
   val add_abbrev: string -> binding * term -> Proof.context -> (term * term) * Proof.context
   val revert_abbrev: string -> string -> Proof.context -> Proof.context
   val generic_add_abbrev: string -> binding * term -> Context.generic ->
     (term * term) * Context.generic
   val generic_revert_abbrev: string -> string -> Context.generic -> Context.generic
   type stmt =
    {vars: ((binding * typ option * mixfix) * (string * term)) list,
     propss: term list list,
     binds: (indexname * term) list,
     result_binds: (indexname * term) list}
   val cert_stmt: (binding * typ option * mixfix) list -> (term * term list) list list ->
     Proof.context -> stmt * Proof.context
   val read_stmt: (binding * string option * mixfix) list -> (string * string list) list list ->
     Proof.context -> stmt * Proof.context
   type statement =
    {fixes: (string * term) list,
     assumes: term list list,
     shows: term list list,
     result_binds: (indexname * term option) list,
     text: term,
     result_text: term}
   val cert_statement: (binding * typ option * mixfix) list ->
     (term * term list) list list -> (term * term list) list list -> Proof.context ->
     statement * Proof.context
   val read_statement: (binding * string option * mixfix) list ->
     (string * string list) list list -> (string * string list) list list -> Proof.context ->
     statement * Proof.context
   val print_syntax: Proof.context -> unit
   val print_abbrevs: bool -> Proof.context -> unit
   val pretty_term_bindings: Proof.context -> Pretty.T list
   val pretty_local_facts: bool -> Proof.context -> Pretty.T list
   val print_local_facts: bool -> Proof.context -> unit
   val pretty_cases: Proof.context -> Pretty.T list
   val print_cases_proof: Proof.context -> Proof.context -> string
   val debug: bool Config.T
   val verbose: bool Config.T
   val pretty_ctxt: Proof.context -> Pretty.T list
   val pretty_context: Proof.context -> Pretty.T list
 end;
 
 structure Proof_Context: PROOF_CONTEXT =
 struct
 
 val theory_of = Proof_Context.theory_of;
 val init_global = Proof_Context.init_global;
 val get_global = Proof_Context.get_global;
 
 
 
 (** inner syntax mode **)
 
 datatype mode =
   Mode of
    {pattern: bool,             (*pattern binding schematic variables*)
     schematic: bool,           (*term referencing loose schematic variables*)
     abbrev: bool};             (*abbrev mode -- no normalization*)
 
 fun make_mode (pattern, schematic, abbrev) =
   Mode {pattern = pattern, schematic = schematic, abbrev = abbrev};
 
 val mode_default   = make_mode (false, false, false);
 val mode_pattern   = make_mode (true, false, false);
 val mode_schematic = make_mode (false, true, false);
 val mode_abbrev    = make_mode (false, false, true);
 
 
 
 (** Isar proof context information **)
 
 type cases = Rule_Cases.T Name_Space.table;
 val empty_cases: cases = Name_Space.empty_table Markup.caseN;
 
 datatype data =
   Data of
    {mode: mode,                  (*inner syntax mode*)
     syntax: Local_Syntax.T,      (*local syntax*)
     tsig: Type.tsig * Type.tsig, (*local/global type signature -- local name space / defsort only*)
     consts: Consts.T * Consts.T, (*local/global consts -- local name space / abbrevs only*)
     facts: Facts.T,              (*local facts, based on initial global facts*)
     cases: cases};               (*named case contexts*)
 
 fun make_data (mode, syntax, tsig, consts, facts, cases) =
   Data {mode = mode, syntax = syntax, tsig = tsig, consts = consts, facts = facts, cases = cases};
 
 structure Data = Proof_Data
 (
   type T = data;
   fun init thy =
     make_data (mode_default,
       Local_Syntax.init thy,
       (Type.change_ignore (Sign.tsig_of thy), Sign.tsig_of thy),
       (Consts.change_ignore (Sign.consts_of thy), Sign.consts_of thy),
       Global_Theory.facts_of thy,
       empty_cases);
 );
 
 fun rep_data ctxt = Data.get ctxt |> (fn Data rep => rep);
 
 fun map_data_result f ctxt =
   let
     val Data {mode, syntax, tsig, consts, facts, cases} = Data.get ctxt;
     val (res, data') = f (mode, syntax, tsig, consts, facts, cases) ||> make_data;
   in (res, Data.put data' ctxt) end;
 
 fun map_data f = snd o map_data_result (pair () o f);
 
 fun set_mode mode = map_data (fn (_, syntax, tsig, consts, facts, cases) =>
   (mode, syntax, tsig, consts, facts, cases));
 
 fun map_syntax f =
   map_data (fn (mode, syntax, tsig, consts, facts, cases) =>
     (mode, f syntax, tsig, consts, facts, cases));
 
 fun map_syntax_idents f ctxt =
   let val (opt_idents', syntax') = f (#syntax (rep_data ctxt)) in
     ctxt
     |> map_syntax (K syntax')
     |> (case opt_idents' of NONE => I | SOME idents' => Syntax_Trans.put_idents idents')
   end;
 
 fun map_tsig f =
   map_data (fn (mode, syntax, tsig, consts, facts, cases) =>
     (mode, syntax, f tsig, consts, facts, cases));
 
 fun map_consts f =
   map_data (fn (mode, syntax, tsig, consts, facts, cases) =>
     (mode, syntax, tsig, f consts, facts, cases));
 
 fun map_facts_result f =
   map_data_result (fn (mode, syntax, tsig, consts, facts, cases) =>
     let val (res, facts') = f facts
     in (res, (mode, syntax, tsig, consts, facts', cases)) end);
 
 fun map_facts f = snd o map_facts_result (pair () o f);
 
 fun map_cases f =
   map_data (fn (mode, syntax, tsig, consts, facts, cases) =>
     (mode, syntax, tsig, consts, facts, f cases));
 
 val get_mode = #mode o rep_data;
 val restore_mode = set_mode o get_mode;
 val abbrev_mode = get_mode #> (fn Mode {abbrev, ...} => abbrev);
 
 val syntax_of = #syntax o rep_data;
 val syn_of = Local_Syntax.syn_of o syntax_of;
 val set_syntax_mode = map_syntax o Local_Syntax.set_mode;
 val restore_syntax_mode = map_syntax o Local_Syntax.restore_mode o syntax_of;
 
 val tsig_of = #1 o #tsig o rep_data;
 val set_defsort = map_tsig o apfst o Type.set_defsort;
 fun default_sort ctxt = the_default (Type.defaultS (tsig_of ctxt)) o Variable.def_sort ctxt;
 fun arity_sorts ctxt = Type.arity_sorts (Context.Proof ctxt) (tsig_of ctxt);
 
 val consts_of = #1 o #consts o rep_data;
 val cases_of = #cases o rep_data;
 
 
 (* naming *)
 
 val naming_of = Name_Space.naming_of o Context.Proof;
 val map_naming = Context.proof_map o Name_Space.map_naming;
 val restore_naming = map_naming o K o naming_of;
 
 val full_name = Name_Space.full_name o naming_of;
 
 val get_scope = Name_Space.get_scope o naming_of;
 
 fun new_scope ctxt =
   let
     val (scope, naming') = Name_Space.new_scope (naming_of ctxt);
     val ctxt' = map_naming (K naming') ctxt;
   in (scope, ctxt') end;
 
 val private_scope = map_naming o Name_Space.private_scope;
 val private = map_naming o Name_Space.private;
 val qualified_scope = map_naming o Name_Space.qualified_scope;
 val qualified = map_naming o Name_Space.qualified;
 
 val concealed = map_naming Name_Space.concealed;
 
 
 (* name spaces *)
 
 val class_space = Type.class_space o tsig_of;
 val type_space = Type.type_space o tsig_of;
 val const_space = Consts.space_of o consts_of;
 
 fun defs_context ctxt = (ctxt, (const_space ctxt, type_space ctxt));
 
 val intern_class = Name_Space.intern o class_space;
 val intern_type = Name_Space.intern o type_space;
 val intern_const = Name_Space.intern o const_space;
 
 fun extern_class ctxt = Name_Space.extern ctxt (class_space ctxt);
 fun extern_type ctxt = Name_Space.extern ctxt (type_space ctxt);
 fun extern_const ctxt = Name_Space.extern ctxt (const_space ctxt);
 
 fun markup_class ctxt c = Name_Space.markup_extern ctxt (class_space ctxt) c |-> Markup.markup;
 fun markup_type ctxt c = Name_Space.markup_extern ctxt (type_space ctxt) c |-> Markup.markup;
 fun markup_const ctxt c = Name_Space.markup_extern ctxt (const_space ctxt) c |-> Markup.markup;
 
 fun pretty_class ctxt c = Name_Space.markup_extern ctxt (class_space ctxt) c |> Pretty.mark_str;
 fun pretty_type ctxt c = Name_Space.markup_extern ctxt (type_space ctxt) c |> Pretty.mark_str;
 fun pretty_const ctxt c = Name_Space.markup_extern ctxt (const_space ctxt) c |> Pretty.mark_str;
 
 
 (* theory transfer *)
 
 fun transfer_syntax thy ctxt = ctxt |>
   map_syntax (Local_Syntax.rebuild thy) |>
   map_tsig (fn tsig as (local_tsig, global_tsig) =>
     let val thy_tsig = Sign.tsig_of thy in
       if Type.eq_tsig (thy_tsig, global_tsig) then tsig
       else (Type.merge_tsig (Context.Proof ctxt) (local_tsig, thy_tsig), thy_tsig)  (*historic merge order*)
     end) |>
   map_consts (fn consts as (local_consts, global_consts) =>
     let val thy_consts = Sign.consts_of thy in
       if Consts.eq_consts (thy_consts, global_consts) then consts
       else (Consts.merge (local_consts, thy_consts), thy_consts)  (*historic merge order*)
     end);
 
 fun transfer thy = Context.raw_transfer thy #> transfer_syntax thy;
 
 fun transfer_facts thy =
   map_facts (fn local_facts => Facts.merge (Global_Theory.facts_of thy, local_facts));
 
 fun background_theory f ctxt = transfer (f (theory_of ctxt)) ctxt;
 
 fun background_theory_result f ctxt =
   let val (res, thy') = f (theory_of ctxt)
   in (res, ctxt |> transfer thy') end;
 
 
 (* hybrid facts *)
 
 val facts_of = #facts o rep_data;
 
 fun facts_of_fact ctxt name =
   let
     val local_facts = facts_of ctxt;
     val global_facts = Global_Theory.facts_of (theory_of ctxt);
   in
     if Facts.defined local_facts name
     then local_facts else global_facts
   end;
 
 fun markup_extern_fact ctxt name =
   let
     val facts = facts_of_fact ctxt name;
     val (markup, xname) = Facts.markup_extern ctxt facts name;
     val markups =
       if Facts.is_dynamic facts name then [markup, Markup.dynamic_fact name]
       else [markup];
   in (markups, xname) end;
 
 
 (* augment context by implicit term declarations *)
 
 fun augment t ctxt = ctxt
   |> Variable.add_fixes_implicit t
   |> Variable.declare_term t
   |> Soft_Type_System.augment t;
 
 
 
 (** pretty printing **)
 
 val print_name = Token.print_name o Thy_Header.get_keywords';
 val pretty_name = Pretty.str oo print_name;
 
 fun pretty_term_abbrev ctxt = Syntax.pretty_term (set_mode mode_abbrev ctxt);
 
 fun pretty_fact_name ctxt a =
   Pretty.block [Pretty.marks_str (markup_extern_fact ctxt a), Pretty.str ":"];
 
 fun pretty_fact ctxt =
   let
     val pretty_thm = Thm.pretty_thm ctxt;
     val pretty_thms = map (Thm.pretty_thm_item ctxt);
   in
     fn ("", [th]) => pretty_thm th
      | ("", ths) => Pretty.blk (0, Pretty.fbreaks (pretty_thms ths))
      | (a, [th]) => Pretty.block [pretty_fact_name ctxt a, Pretty.brk 1, pretty_thm th]
      | (a, ths) => Pretty.block (Pretty.fbreaks (pretty_fact_name ctxt a :: pretty_thms ths))
   end;
 
 
 
 (** prepare types **)
 
 (* classes *)
 
 fun check_class ctxt (xname, pos) =
   let
     val tsig = tsig_of ctxt;
     val class_space = Type.class_space tsig;
 
     val name = Type.cert_class tsig (Name_Space.intern class_space xname)
       handle TYPE (msg, _, _) =>
         error (msg ^ Position.here pos ^
           Completion.markup_report
             [Name_Space.completion (Context.Proof ctxt) class_space (K true) (xname, pos)]);
     val reports =
       if Context_Position.is_reported ctxt pos
       then [(pos, Name_Space.markup class_space name)] else [];
   in (name, reports) end;
 
 fun read_class ctxt text =
   let
     val source = Syntax.read_input text;
     val (c, reports) = check_class ctxt (Input.source_content source);
     val _ = Context_Position.reports ctxt reports;
   in c end;
 
 
 (* types *)
 
 fun read_typ_mode mode ctxt s =
   Syntax.read_typ (Type.set_mode mode ctxt) s;
 
 val read_typ = read_typ_mode Type.mode_default;
 val read_typ_syntax = read_typ_mode Type.mode_syntax;
 val read_typ_abbrev = read_typ_mode Type.mode_abbrev;
 
 
 fun cert_typ_mode mode ctxt T =
   Type.cert_typ_mode mode (tsig_of ctxt) T
     handle TYPE (msg, _, _) => error msg;
 
 val cert_typ = cert_typ_mode Type.mode_default;
 val cert_typ_syntax = cert_typ_mode Type.mode_syntax;
 val cert_typ_abbrev = cert_typ_mode Type.mode_abbrev;
 
 
 
 (** prepare terms and propositions **)
 
 (* inferred types of parameters *)
 
 fun infer_type ctxt x =
   Term.fastype_of (singleton (Syntax.check_terms (set_mode mode_schematic ctxt)) (Free x));
 
 fun inferred_param x ctxt =
   let val p = (x, infer_type ctxt (x, dummyT))
   in (p, ctxt |> Variable.declare_term (Free p)) end;
 
 fun inferred_fixes ctxt =
   fold_map inferred_param (map #2 (Variable.dest_fixes ctxt)) ctxt;
 
 
 (* type names *)
 
 fun check_type_name {proper, strict} ctxt (c, pos) =
   if Lexicon.is_tid c then
     if proper then error ("Not a type constructor: " ^ quote c ^ Position.here pos)
     else
       let
         val reports =
           if Context_Position.is_reported ctxt pos
           then [(pos, Markup.tfree)] else [];
       in (TFree (c, default_sort ctxt (c, ~1)), reports) end
   else
     let
       val ((d, reports), decl) = Type.check_decl (Context.Proof ctxt) (tsig_of ctxt) (c, pos);
       fun err () = error ("Bad type name: " ^ quote d ^ Position.here pos);
       val args =
         (case decl of
           Type.LogicalType n => n
         | Type.Abbreviation (vs, _, _) => if strict then err () else length vs
         | Type.Nonterminal => if strict then err () else 0);
     in (Type (d, replicate args dummyT), reports) end;
 
 fun read_type_name flags ctxt text =
   let
     val source = Syntax.read_input text;
     val (T, reports) = check_type_name flags ctxt (Input.source_content source);
     val _ = Context_Position.reports ctxt reports;
   in T end;
 
 
 (* constant names *)
 
 fun consts_completion_message ctxt (c, ps) =
   ps |> map (fn pos =>
     Name_Space.completion (Context.Proof ctxt) (Consts.space_of (consts_of ctxt)) (K true) (c, pos))
   |> Completion.markup_report;
 
 fun check_const {proper, strict} ctxt (c, ps) =
   let
     val _ =
       Name.reject_internal (c, ps) handle ERROR msg =>
         error (msg ^ consts_completion_message ctxt (c, ps));
     fun err msg = error (msg ^ Position.here_list ps);
     val consts = consts_of ctxt;
     val fixed = if proper then NONE else Variable.lookup_fixed ctxt c;
     val (t, reports) =
       (case (fixed, Variable.lookup_const ctxt c) of
         (SOME x, NONE) =>
           let
             val reports = ps
               |> filter (Context_Position.is_reported ctxt)
               |> map (fn pos =>
                 (pos, Markup.name x (if Name.is_skolem x then Markup.skolem else Markup.free)));
           in (Free (x, infer_type ctxt (x, dummyT)), reports) end
       | (_, SOME d) =>
           let
             val T = Consts.type_scheme consts d handle TYPE (msg, _, _) => err msg;
             val reports = ps
               |> filter (Context_Position.is_reported ctxt)
               |> map (fn pos => (pos, Name_Space.markup (Consts.space_of consts) d));
           in (Const (d, T), reports) end
       | _ => Consts.check_const (Context.Proof ctxt) consts (c, ps));
     val _ =
       (case (strict, t) of
         (true, Const (d, _)) =>
           (ignore (Consts.the_const consts d) handle TYPE (msg, _, _) => err msg)
       | _ => ());
   in (t, reports) end;
 
 fun read_const flags ctxt text =
   let
     val source = Syntax.read_input text;
     val (c, pos) = Input.source_content source;
     val (t, reports) = check_const flags ctxt (c, [pos]);
     val _ = Context_Position.reports ctxt reports;
   in t end;
 
 
 (* type arities *)
 
 local
 
 fun prep_arity prep_tycon prep_sort ctxt (t, Ss, S) =
   let val arity = (prep_tycon ctxt t, map (prep_sort ctxt) Ss, prep_sort ctxt S)
   in Type.add_arity (Context.Proof ctxt) arity (tsig_of ctxt); arity end;
 
 in
 
 val read_arity =
   prep_arity ((#1 o dest_Type) oo read_type_name {proper = true, strict = true}) Syntax.read_sort;
 
 val cert_arity = prep_arity (K I) (Type.cert_sort o tsig_of);
 
 end;
 
 
 (* read_term *)
 
 fun read_term_mode mode ctxt = Syntax.read_term (set_mode mode ctxt);
 
 val read_term_pattern   = read_term_mode mode_pattern;
 val read_term_schematic = read_term_mode mode_schematic;
 val read_term_abbrev    = read_term_mode mode_abbrev;
 
 
 (* local abbreviations *)
 
 local
 
 fun certify_consts ctxt =
   Consts.certify (Context.Proof ctxt) (tsig_of ctxt)
     (not (abbrev_mode ctxt)) (consts_of ctxt);
 
 fun expand_binds ctxt =
   let
     val Mode {pattern, schematic, ...} = get_mode ctxt;
 
     fun reject_schematic (t as Var _) =
           error ("Unbound schematic variable: " ^ Syntax.string_of_term ctxt t)
       | reject_schematic (Abs (_, _, t)) = reject_schematic t
       | reject_schematic (t $ u) = (reject_schematic t; reject_schematic u)
       | reject_schematic _ = ();
   in
     if pattern then I
     else Variable.expand_binds ctxt #> (if schematic then I else tap reject_schematic)
   end;
 
 in
 
 fun expand_abbrevs ctxt = certify_consts ctxt #> expand_binds ctxt;
 
 end;
 
 val show_abbrevs = Config.declare_bool ("show_abbrevs", \<^here>) (K true);
 
 fun contract_abbrevs ctxt t =
   let
     val thy = theory_of ctxt;
     val consts = consts_of ctxt;
     val Mode {abbrev, ...} = get_mode ctxt;
     val retrieve = Consts.retrieve_abbrevs consts (print_mode_value () @ [""]);
     fun match_abbrev u = Option.map #1 (get_first (Pattern.match_rew thy u) (retrieve u));
   in
     if abbrev orelse not (Config.get ctxt show_abbrevs) orelse not (can Term.type_of t) then t
     else Pattern.rewrite_term_top thy [] [match_abbrev] t
   end;
 
 
 (* patterns *)
 
 fun prepare_patternT ctxt T =
   let
     val Mode {pattern, schematic, ...} = get_mode ctxt;
     val _ =
       pattern orelse schematic orelse
         T |> Term.exists_subtype
           (fn T as TVar (xi, _) =>
             not (Type_Infer.is_param xi) andalso
               error ("Illegal schematic type variable: " ^ Syntax.string_of_typ ctxt T)
           | _ => false)
   in T end;
 
 
 local
 
 val dummies = Config.declare_bool ("Proof_Context.dummies", \<^here>) (K false);
 
 fun check_dummies ctxt t =
   if Config.get ctxt dummies then t
   else Term.no_dummy_patterns t handle TERM _ => error "Illegal dummy pattern(s) in term";
 
 fun prepare_dummies ts = #1 (fold_map Term.replace_dummy_patterns ts 1);
 
 in
 
 val allow_dummies = Config.put dummies true;
 
 fun prepare_patterns ctxt =
   let val Mode {pattern, ...} = get_mode ctxt in
     Type_Infer.fixate ctxt pattern #>
     pattern ? Variable.polymorphic ctxt #>
     (map o Term.map_types) (prepare_patternT ctxt) #>
     (if pattern then prepare_dummies else map (check_dummies ctxt))
   end;
 
 end;
 
 
 (* sort constraints *)
 
 local
 
 fun prepare_sorts_env ctxt tys =
   let
     val tsig = tsig_of ctxt;
     val defaultS = Type.defaultS tsig;
 
     val dummy_var = ("'_dummy_", ~1);
 
     fun constraint (xi, raw_S) env =
       let val (ps, S) = Term_Position.decode_positionS raw_S in
         if xi = dummy_var orelse S = dummyS then env
         else
           Vartab.insert (op =) (xi, Type.minimize_sort tsig S) env
             handle Vartab.DUP _ =>
               error ("Inconsistent sort constraints for type variable " ^
                 quote (Term.string_of_vname' xi) ^ Position.here_list ps)
       end;
 
     val env =
-      (fold o fold_atyps)
+      Vartab.build (tys |> (fold o fold_atyps)
         (fn TFree (x, S) => constraint ((x, ~1), S)
           | TVar v => constraint v
-          | _ => I) tys Vartab.empty;
+          | _ => I));
 
     fun get_sort xi raw_S =
       if xi = dummy_var then
         Type.minimize_sort tsig (#2 (Term_Position.decode_positionS raw_S))
       else
         (case (Vartab.lookup env xi, Variable.def_sort ctxt xi) of
           (NONE, NONE) => defaultS
         | (NONE, SOME S) => S
         | (SOME S, NONE) => S
         | (SOME S, SOME S') =>
             if Type.eq_sort tsig (S, S') then S'
             else
               error ("Sort constraint " ^ Syntax.string_of_sort ctxt S ^
                 " inconsistent with default " ^ Syntax.string_of_sort ctxt S' ^
                 " for type variable " ^ quote (Term.string_of_vname' xi)));
 
     fun add_report S pos reports =
       if Position.is_reported pos andalso not (AList.defined (op =) reports pos) then
         (pos, Position.reported_text pos Markup.sorting (Syntax.string_of_sort ctxt S)) :: reports
       else reports;
 
     fun get_sort_reports xi raw_S =
       let
         val ps = #1 (Term_Position.decode_positionS raw_S);
         val S = get_sort xi raw_S handle ERROR msg => error (msg ^ Position.here_list ps);
       in fold (add_report S) ps end;
 
     val reports =
       (fold o fold_atyps)
         (fn T =>
           if Term_Position.is_positionT T then I
           else
             (case T of
               TFree (x, raw_S) => get_sort_reports (x, ~1) raw_S
             | TVar (xi, raw_S) => get_sort_reports xi raw_S
             | _ => I)) tys [];
 
   in (map #2 reports, get_sort) end;
 
 fun replace_sortsT get_sort =
   map_atyps
     (fn T =>
       if Term_Position.is_positionT T then T
       else
         (case T of
           TFree (x, raw_S) => TFree (x, get_sort (x, ~1) raw_S)
         | TVar (xi, raw_S) => TVar (xi, get_sort xi raw_S)
         | _ => T));
 
 in
 
 fun prepare_sortsT ctxt tys =
   let val (sorting_report, get_sort) = prepare_sorts_env ctxt tys
   in (sorting_report, map (replace_sortsT get_sort) tys) end;
 
 fun prepare_sorts ctxt tms =
   let
     val tys = rev ((fold o fold_types) cons tms []);
     val (sorting_report, get_sort) = prepare_sorts_env ctxt tys;
   in (sorting_report, (map o map_types) (replace_sortsT get_sort) tms) end;
 
 fun check_tfree ctxt v =
   let
     val (sorting_report, [TFree a]) = prepare_sortsT ctxt [TFree v];
     val _ = if Context_Position.reports_enabled ctxt then Output.report sorting_report else ();
   in a end;
 
 end;
 
 
 (* certify terms *)
 
 local
 
 fun gen_cert prop ctxt t =
   t
   |> expand_abbrevs ctxt
   |> (fn t' =>
       #1 (Sign.certify' prop (Context.Proof ctxt) false (consts_of ctxt) (theory_of ctxt) t')
         handle TYPE (msg, _, _) => error msg | TERM (msg, _) => error msg);
 
 in
 
 val cert_term = gen_cert false;
 val cert_prop = gen_cert true;
 
 end;
 
 
 (* check/uncheck *)
 
 fun def_type ctxt =
   let val Mode {pattern, ...} = get_mode ctxt
   in Variable.def_type ctxt pattern end;
 
 fun standard_typ_check ctxt =
   map (cert_typ_mode (Type.get_mode ctxt) ctxt #> prepare_patternT ctxt);
 
 val standard_term_check_finish = prepare_patterns;
 
 fun standard_term_uncheck ctxt = map (contract_abbrevs ctxt);
 
 
 
 (** export results **)
 
 fun common_export is_goal inner outer =
   map (Assumption.export is_goal inner outer) #>
   Variable.export inner outer;
 
 val goal_export = common_export true;
 val export = common_export false;
 
 fun export_morphism inner outer =
   Assumption.export_morphism inner outer $>
   Variable.export_morphism inner outer;
 
 fun norm_export_morphism inner outer =
   export_morphism inner outer $>
   Morphism.thm_morphism "Proof_Context.norm_export" (Goal.norm_result outer);
 
 
 
 (** term bindings **)
 
 (* auto bindings *)
 
 fun auto_bind f props ctxt = fold Variable.maybe_bind_term (f ctxt props) ctxt;
 
 val auto_bind_goal = auto_bind Auto_Bind.goal;
 val auto_bind_facts = auto_bind Auto_Bind.facts;
 
 
 (* match bindings *)
 
 fun simult_matches ctxt (t, pats) =
   (case Seq.pull (Unify.matchers (Context.Proof ctxt) (map (rpair t) pats)) of
     NONE => error "Pattern match failed!"
   | SOME (env, _) => Vartab.fold (fn (v, (_, t)) => cons (v, t)) (Envir.term_env env) []);
 
 fun maybe_bind_term (xi, t) ctxt =
   ctxt
   |> Variable.maybe_bind_term (xi, Option.map (cert_term (set_mode mode_default ctxt)) t);
 
 val bind_term = maybe_bind_term o apsnd SOME;
 
 
 (* propositions with patterns *)
 
 local
 
 fun prep_propp prep_props ctxt raw_args =
   let
     val props = prep_props ctxt (maps (map fst) raw_args);
     val props_ctxt = fold Variable.declare_term props ctxt;
     val patss = maps (map (prep_props (set_mode mode_pattern props_ctxt) o snd)) raw_args;
 
     val propps = unflat raw_args (props ~~ patss);
     val binds = (maps o maps) (simult_matches props_ctxt) propps;
   in (map (map fst) propps, binds) end;
 
 in
 
 val cert_propp = prep_propp (map o cert_prop);
 val read_propp = prep_propp Syntax.read_props;
 
 end;
 
 
 
 (** theorems **)
 
 (* fact_tac *)
 
 local
 
 fun comp_hhf_tac ctxt th i st =
   PRIMSEQ (Thm.bicompose (SOME ctxt) {flatten = true, match = false, incremented = true}
     (false, Drule.lift_all ctxt (Thm.cprem_of st i) th, 0) i) st;
 
 fun comp_incr_tac _ [] _ = no_tac
   | comp_incr_tac ctxt (th :: ths) i =
       (fn st => comp_hhf_tac ctxt (Drule.incr_indexes st th) i st) APPEND
       comp_incr_tac ctxt ths i;
 
 val vacuous_facts = [Drule.termI];
 
 in
 
 fun potential_facts ctxt prop =
   let
     val body = Term.strip_all_body prop;
     val vacuous =
       filter (fn th => Term.could_unify (body, Thm.concl_of th)) vacuous_facts
       |> map (rpair Position.none);
   in Facts.could_unify (facts_of ctxt) body @ vacuous end;
 
 fun fact_tac ctxt facts = Goal.norm_hhf_tac ctxt THEN' comp_incr_tac ctxt facts;
 
 fun some_fact_tac ctxt =
   SUBGOAL (fn (goal, i) => fact_tac ctxt (map #1 (potential_facts ctxt goal)) i);
 
 end;
 
 
 (* lookup facts *)
 
 fun lookup_fact ctxt name =
   let
     val context = Context.Proof ctxt;
     val thy = Proof_Context.theory_of ctxt;
   in
     (case Facts.lookup context (facts_of ctxt) name of
       NONE => Facts.lookup context (Global_Theory.facts_of thy) name
     | some => some)
   end;
 
 
 (* retrieve facts *)
 
 val dynamic_facts_dummy = Config.declare_bool ("dynamic_facts_dummy_", \<^here>) (K false);
 
 local
 
 fun retrieve_global context =
   Facts.retrieve context (Global_Theory.facts_of (Context.theory_of context));
 
 fun retrieve_generic (context as Context.Proof ctxt) arg =
       (Facts.retrieve context (facts_of ctxt) arg handle ERROR local_msg =>
         (retrieve_global context arg handle ERROR _ => error local_msg))
   | retrieve_generic context arg = retrieve_global context arg;
 
 fun retrieve pick context (Facts.Fact s) =
       let
         val ctxt = Context.the_proof context;
         val pos = Syntax.read_input_pos s;
         val prop =
           Syntax.read_prop (ctxt |> set_mode mode_default |> allow_dummies) s
           |> singleton (Variable.polymorphic ctxt);
         fun err ps msg =
           error (msg ^ Position.here_list (pos :: ps) ^ ":\n" ^ Syntax.string_of_term ctxt prop);
 
         val (prop', _) = Term.replace_dummy_patterns prop (Variable.maxidx_of ctxt + 1);
         fun prove th = Goal.prove ctxt [] [] prop' (K (ALLGOALS (fact_tac ctxt [th])));
         val results = map_filter (try (apfst prove)) (potential_facts ctxt prop');
         val (thm, thm_pos) =
           (case distinct (eq_fst Thm.eq_thm_prop) results of
             [res] => res
           | [] => err [] "Failed to retrieve literal fact"
           | dups => err (distinct (op =) (map #2 dups)) "Ambiguous specification of literal fact");
 
         val markup = Position.entity_markup Markup.literal_factN ("", thm_pos);
         val _ = Context_Position.report_generic context pos markup;
       in pick true ("", thm_pos) [thm] end
   | retrieve pick context (Facts.Named ((xname, pos), sel)) =
       let
         val thy = Context.theory_of context;
         fun immediate thms = {name = xname, dynamic = false, thms = map (Thm.transfer thy) thms};
         val {name, dynamic, thms} =
           (case xname of
             "" => immediate [Drule.dummy_thm]
           | "_" => immediate [Drule.asm_rl]
           | "nothing" => immediate []
           | _ => retrieve_generic context (xname, pos));
         val thms' =
           if dynamic andalso Config.get_generic context dynamic_facts_dummy
           then [Drule.free_dummy_thm]
           else Facts.select (Facts.Named ((name, pos), sel)) thms;
       in pick (dynamic andalso is_none sel) (name, pos) thms' end;
 
 in
 
 val get_fact_generic =
   retrieve (fn dynamic => fn (name, _) => fn thms =>
     (if dynamic then SOME name else NONE, thms));
 
 val get_fact = retrieve (K (K I)) o Context.Proof;
 val get_fact_single = retrieve (K Facts.the_single) o Context.Proof;
 
 fun get_thms ctxt = get_fact ctxt o Facts.named;
 fun get_thm ctxt = get_fact_single ctxt o Facts.named;
 
 end;
 
 
 (* inner statement mode *)
 
 val inner_stmt = Config.declare_bool ("inner_stmt", \<^here>) (K false);
 fun is_stmt ctxt = Config.get ctxt inner_stmt;
 val set_stmt = Config.put inner_stmt;
 val restore_stmt = set_stmt o is_stmt;
 
 
 (* facts *)
 
 fun add_thms_dynamic arg ctxt =
   ctxt |> map_facts_result (Facts.add_dynamic (Context.Proof ctxt) arg);
 
 local
 
 fun add_facts {index} arg ctxt = ctxt
   |> map_facts_result (Facts.add_static (Context.Proof ctxt) {strict = false, index = index} arg);
 
 fun update_facts flags (b, SOME ths) ctxt = ctxt |> add_facts flags (b, Lazy.value ths) |> #2
   | update_facts _ (b, NONE) ctxt = ctxt |> map_facts (Facts.del (full_name ctxt b));
 
 fun bind_name ctxt b = (full_name ctxt b, Binding.default_pos_of b);
 
 in
 
 fun add_thms_lazy kind (b, ths) ctxt =
   let
     val name_pos = bind_name ctxt b;
     val ths' =
       Global_Theory.check_thms_lazy ths
       |> Lazy.map_finished
           (Global_Theory.name_thms Global_Theory.unofficial1 name_pos #> map (Thm.kind_rule kind));
     val (_, ctxt') = add_facts {index = is_stmt ctxt} (b, ths') ctxt;
   in ctxt' end;
 
 fun note_thms kind ((b, more_atts), facts) ctxt =
   let
     val (name, pos) = bind_name ctxt b;
     val facts' = facts
       |> Global_Theory.burrow_fact (Global_Theory.name_thms Global_Theory.unofficial1 (name, pos));
     fun app (ths, atts) =
       fold_map (Thm.proof_attributes (surround (Thm.kind kind) (atts @ more_atts))) ths;
     val (res, ctxt') = fold_map app facts' ctxt;
     val thms = Global_Theory.name_thms Global_Theory.unofficial2 (name, pos) (flat res);
     val (_, ctxt'') = ctxt' |> add_facts {index = is_stmt ctxt} (b, Lazy.value thms);
   in ((name, thms), ctxt'') end;
 
 val note_thmss = fold_map o note_thms;
 
 fun put_thms index thms ctxt = ctxt
   |> map_naming (K Name_Space.local_naming)
   |> Context_Position.set_visible false
   |> update_facts {index = index} (apfst Binding.name thms)
   |> Context_Position.restore_visible ctxt
   |> restore_naming ctxt;
 
 end;
 
 fun alias_fact b c ctxt = map_facts (Facts.alias (naming_of ctxt) b c) ctxt;
 
 
 
 (** basic logical entities **)
 
 (* variables *)
 
 fun declare_var (x, opt_T, mx) ctxt =
   let val T = (case opt_T of SOME T => T | NONE => Mixfix.default_constraint mx)
   in (T, ctxt |> Variable.declare_constraints (Free (x, T))) end;
 
 fun add_syntax vars ctxt =
   map_syntax_idents (Local_Syntax.add_syntax ctxt (map (pair Local_Syntax.Fixed) vars)) ctxt;
 
 fun check_var internal b =
   let
     val x = Variable.check_name b;
     val check = if internal then Name.reject_skolem else Name.reject_internal;
     val _ =
       if can check (x, []) andalso Symbol_Pos.is_identifier x then ()
       else error ("Bad name: " ^ Binding.print b);
   in x end;
 
 local
 
 fun check_mixfix ctxt (b, T, mx) =
   let
     val ([x], ctxt') = Variable.add_fixes_binding [Binding.reset_pos b] ctxt;
     val mx' = Mixfix.reset_pos mx;
     val _ = add_syntax [(x, T, if Context_Position.reports_enabled ctxt then mx else mx')] ctxt';
   in mx' end;
 
 fun prep_var prep_typ internal (b, raw_T, mx) ctxt =
   let
     val x = check_var internal b;
     fun cond_tvars T =
       if internal then T
       else Type.no_tvars T handle TYPE (msg, _, _) => error msg;
     val opt_T = Option.map (cond_tvars o prep_typ ctxt) raw_T;
     val (T, ctxt') = ctxt |> declare_var (x, opt_T, mx);
     val mx' = if Mixfix.is_empty mx then mx else check_mixfix ctxt' (b, T, mx);
   in ((b, SOME T, mx'), ctxt') end;
 
 in
 
 val read_var = prep_var Syntax.read_typ false;
 val cert_var = prep_var cert_typ true;
 
 end;
 
 
 (* notation *)
 
 local
 
 fun type_syntax (Type (c, args), mx) =
       SOME (Local_Syntax.Type, (Lexicon.mark_type c, Mixfix.make_type (length args), mx))
   | type_syntax _ = NONE;
 
 fun const_syntax _ (Free (x, T), mx) = SOME (Local_Syntax.Fixed, (x, T, mx))
   | const_syntax ctxt (Const (c, _), mx) =
       (case try (Consts.type_scheme (consts_of ctxt)) c of
         SOME T => SOME (Local_Syntax.Const, (Lexicon.mark_const c, T, mx))
       | NONE => NONE)
   | const_syntax _ _ = NONE;
 
 fun gen_notation syntax add mode args ctxt =
   ctxt |> map_syntax_idents
     (Local_Syntax.update_modesyntax ctxt add mode (map_filter (syntax ctxt) args));
 
 in
 
 val type_notation = gen_notation (K type_syntax);
 val notation = gen_notation const_syntax;
 
 fun generic_type_notation add mode args phi =
   let
     val args' = args |> map_filter (fn (T, mx) =>
       let
         val T' = Morphism.typ phi T;
         val similar = (case (T, T') of (Type (c, _), Type (c', _)) => c = c' | _ => false);
       in if similar then SOME (T', mx) else NONE end);
   in Context.mapping (Sign.type_notation add mode args') (type_notation add mode args') end;
 
 fun generic_notation add mode args phi =
   let
     val args' = args |> map_filter (fn (t, mx) =>
       let val t' = Morphism.term phi t
       in if Term.aconv_untyped (t, t') then SOME (t', mx) else NONE end);
   in Context.mapping (Sign.notation add mode args') (notation add mode args') end;
 
 end;
 
 
 (* aliases *)
 
 fun type_alias b c ctxt = (map_tsig o apfst) (Type.type_alias (naming_of ctxt) b c) ctxt;
 fun const_alias b c ctxt = (map_consts o apfst) (Consts.alias (naming_of ctxt) b c) ctxt;
 
 
 (* local constants *)
 
 fun add_const_constraint (c, opt_T) ctxt =
   let
     fun prepT raw_T =
       let val T = cert_typ ctxt raw_T
       in cert_term ctxt (Const (c, T)); T end;
   in ctxt |> (map_consts o apfst) (Consts.constrain (c, Option.map prepT opt_T)) end;
 
 fun add_abbrev mode (b, raw_t) ctxt =
   let
     val t0 = cert_term (ctxt |> set_mode mode_abbrev) raw_t
       handle ERROR msg => cat_error msg ("in constant abbreviation " ^ Binding.print b);
     val [t] = Variable.exportT_terms (Variable.declare_term t0 ctxt) ctxt [t0];
     val ((lhs, rhs), consts') = consts_of ctxt
       |> Consts.abbreviate (Context.Proof ctxt) (tsig_of ctxt) mode (b, t);
   in
     ctxt
     |> (map_consts o apfst) (K consts')
     |> Variable.declare_term rhs
     |> pair (lhs, rhs)
   end;
 
 fun revert_abbrev mode c = (map_consts o apfst) (Consts.revert_abbrev mode c);
 
 fun generic_add_abbrev mode arg =
   Context.mapping_result (Sign.add_abbrev mode arg) (add_abbrev mode arg);
 
 fun generic_revert_abbrev mode arg =
   Context.mapping (Sign.revert_abbrev mode arg) (revert_abbrev mode arg);
 
 
 (* fixes *)
 
 local
 
 fun gen_fixes prep_var raw_vars ctxt =
   let
     val (vars, _) = fold_map prep_var raw_vars ctxt;
     val (xs, ctxt') = Variable.add_fixes_binding (map #1 vars) ctxt;
     val _ =
       Context_Position.reports ctxt'
         (flat (map2 (fn x => fn pos =>
           [(pos, Variable.markup ctxt' x), (pos, Variable.markup_entity_def ctxt' x)])
             xs (map (Binding.pos_of o #1) vars)));
     val vars' = map2 (fn x => fn (_, opt_T, mx) => (x, opt_T, mx)) xs vars;
     val (Ts, ctxt'') = fold_map declare_var vars' ctxt';
     val vars'' = map2 (fn T => fn (x, _, mx) => (x, T, mx)) Ts vars';
   in (xs, add_syntax vars'' ctxt'') end;
 
 in
 
 val add_fixes = gen_fixes cert_var;
 val add_fixes_cmd = gen_fixes read_var;
 
 end;
 
 
 
 (** assumptions **)
 
 local
 
 fun gen_assms prep_propp exp args ctxt =
   let
     val (propss, binds) = prep_propp ctxt (map snd args);
     val props = flat propss;
   in
     ctxt
     |> fold Variable.declare_term props
     |> tap (Variable.warn_extra_tfrees ctxt)
     |> fold_burrow (Assumption.add_assms exp o map (Thm.cterm_of ctxt)) propss
     |-> (fn premss =>
       auto_bind_facts props
       #> fold Variable.bind_term binds
       #> note_thmss "" (map fst args ~~ map (map (fn th => ([th], []))) premss))
   end;
 
 in
 
 val add_assms = gen_assms cert_propp;
 val add_assms_cmd = gen_assms read_propp;
 
 end;
 
 
 
 (** cases **)
 
 fun dest_cases prev_ctxt ctxt =
   let
     val serial_of = #serial oo (Name_Space.the_entry o Name_Space.space_of_table);
     val ignored =
       (case prev_ctxt of
         NONE => Inttab.empty
       | SOME ctxt0 =>
           let val cases0 = cases_of ctxt0 in
-            Name_Space.fold_table (fn (a, _) => Inttab.insert_set (serial_of cases0 a))
-              cases0 Inttab.empty
+            Inttab.build (cases0 |> Name_Space.fold_table (fn (a, _) =>
+              Inttab.insert_set (serial_of cases0 a)))
           end);
      val cases = cases_of ctxt;
   in
     Name_Space.fold_table (fn (a, c) =>
       let val i = serial_of cases a
       in not (Inttab.defined ignored i) ? cons (i, (a, c)) end) cases []
     |> sort (int_ord o apply2 #1) |> map #2
   end;
 
 local
 
 fun drop_schematic (b as (xi, SOME t)) = if Term.exists_subterm is_Var t then (xi, NONE) else b
   | drop_schematic b = b;
 
 fun update_case _ ("", _) cases = cases
   | update_case _ (name, NONE) cases = Name_Space.del_table name cases
   | update_case context (name, SOME c) cases =
       #2 (Name_Space.define context false (Binding.name name, c) cases);
 
 fun fix (b, T) ctxt =
   let val ([x], ctxt') = add_fixes [(b, SOME T, NoSyn)] ctxt
   in (Free (x, T), ctxt') end;
 
 in
 
 fun update_cases args ctxt =
   let val context = Context.Proof ctxt |> Name_Space.map_naming (K Name_Space.global_naming);
   in map_cases (fold (update_case context) args) ctxt end;
 
 fun case_result c ctxt =
   let
     val Rule_Cases.Case {fixes, ...} = c;
     val (ts, ctxt') = ctxt |> fold_map fix fixes;
     val Rule_Cases.Case {assumes, binds, cases, ...} = Rule_Cases.apply ts c;
   in
     ctxt'
     |> fold (maybe_bind_term o drop_schematic) binds
     |> update_cases (map (apsnd SOME) cases)
     |> pair (assumes, (binds, cases))
   end;
 
 val apply_case = apfst fst oo case_result;
 
 fun check_case ctxt internal (name, pos) param_specs =
   let
     val (_, Rule_Cases.Case {fixes, assumes, binds, cases}) =
       Name_Space.check (Context.Proof ctxt) (cases_of ctxt) (name, pos);
 
     val _ = List.app (fn NONE => () | SOME b => ignore (check_var internal b)) param_specs;
     fun replace (opt_x :: xs) ((y, T) :: ys) = (the_default y opt_x, T) :: replace xs ys
       | replace [] ys = ys
       | replace (_ :: _) [] =
           error ("Too many parameters for case " ^ quote name ^ Position.here pos);
     val fixes' = replace param_specs fixes;
     val binds' = map drop_schematic binds;
   in
     if null (fold (Term.add_tvarsT o snd) fixes []) andalso
       null (fold (fold Term.add_vars o snd) assumes []) then
         Rule_Cases.Case {fixes = fixes', assumes = assumes, binds = binds', cases = cases}
     else error ("Illegal schematic variable(s) in case " ^ quote name ^ Position.here pos)
   end;
 
 end;
 
 
 (* structured statements *)
 
 type stmt =
  {vars: ((binding * typ option * mixfix) * (string * term)) list,
   propss: term list list,
   binds: (indexname * term) list,
   result_binds: (indexname * term) list};
 
 type statement =
  {fixes: (string * term) list,
   assumes: term list list,
   shows: term list list,
   result_binds: (indexname * term option) list,
   text: term,
   result_text: term};
 
 local
 
 fun export_binds ctxt' ctxt params binds =
   let
     val rhss =
       map (the_list o Option.map (Logic.close_term params) o snd) binds
       |> burrow (Variable.export_terms ctxt' ctxt)
       |> map (try the_single);
   in map fst binds ~~ rhss end;
 
 fun prep_stmt prep_var prep_propp raw_vars raw_propps ctxt =
   let
     val (vars, vars_ctxt) = fold_map prep_var raw_vars ctxt;
     val xs = map (Variable.check_name o #1) vars;
     val (xs', fixes_ctxt) = add_fixes vars vars_ctxt;
 
     val (propss, binds) = prep_propp fixes_ctxt raw_propps;
     val (ps, params_ctxt) = fixes_ctxt
       |> (fold o fold) Variable.declare_term propss
       |> fold_map inferred_param xs';
     val params = xs ~~ map Free ps;
 
     val vars' = map2 (fn (b, _, mx) => fn (_, T) => (b, SOME T, mx)) vars ps;
     val binds' = binds
       |> map (apsnd SOME)
       |> export_binds params_ctxt ctxt params
       |> map (apsnd the);
 
     val _ = Variable.warn_extra_tfrees fixes_ctxt params_ctxt;
     val result : stmt =
       {vars = vars' ~~ params, propss = propss, binds = binds, result_binds = binds'};
   in (result, params_ctxt) end;
 
 fun prep_statement prep_var prep_propp raw_fixes raw_assumes raw_shows ctxt =
   let
     val ((fixes, (assumes, shows), binds), ctxt') = ctxt
       |> prep_stmt prep_var prep_propp raw_fixes (raw_assumes @ raw_shows)
       |-> (fn {vars, propss, binds, ...} =>
         fold Variable.bind_term binds #>
         pair (map #2 vars, chop (length raw_assumes) propss, binds));
     val binds' =
       (Auto_Bind.facts ctxt' (flat shows) @
         (case try List.last (flat shows) of
           NONE => []
         | SOME prop => map (apsnd (SOME o Auto_Bind.abs_params prop)) binds))
       |> export_binds ctxt' ctxt fixes;
 
     val text = Logic.close_prop fixes (flat assumes) (Logic.mk_conjunction_list (flat shows));
     val text' = singleton (Variable.export_terms ctxt' ctxt) text;
 
     val result : statement =
      {fixes = fixes,
       assumes = assumes,
       shows = shows,
       result_binds = binds',
       text = text,
       result_text = text'};
   in (result, ctxt') end;
 
 in
 
 val cert_stmt = prep_stmt cert_var cert_propp;
 val read_stmt = prep_stmt read_var read_propp;
 val cert_statement = prep_statement cert_var cert_propp;
 val read_statement = prep_statement read_var read_propp;
 
 end;
 
 
 
 (** print context information **)
 
 (* local syntax *)
 
 val print_syntax = Syntax.print_syntax o syn_of;
 
 
 (* abbreviations *)
 
 fun pretty_abbrevs verbose show_globals ctxt =
   let
     val space = const_space ctxt;
     val (constants, global_constants) =
       apply2 (#constants o Consts.dest) (#consts (rep_data ctxt));
     val globals = Symtab.make global_constants;
     fun add_abbr (_, (_, NONE)) = I
       | add_abbr (c, (T, SOME t)) =
           if not show_globals andalso Symtab.defined globals c then I
           else cons (c, Logic.mk_equals (Const (c, T), t));
     val abbrevs = Name_Space.markup_entries verbose ctxt space (fold add_abbr constants []);
   in
     if null abbrevs then []
     else [Pretty.big_list "abbreviations:" (map (pretty_term_abbrev ctxt o #2) abbrevs)]
   end;
 
 fun print_abbrevs verbose = Pretty.writeln_chunks o pretty_abbrevs verbose true;
 
 
 (* term bindings *)
 
 fun pretty_term_bindings ctxt =
   let
     val binds = Variable.binds_of ctxt;
     fun prt_bind (xi, (T, t)) = pretty_term_abbrev ctxt (Logic.mk_equals (Var (xi, T), t));
   in
     if Vartab.is_empty binds then []
     else [Pretty.big_list "term bindings:" (map prt_bind (Vartab.dest binds))]
   end;
 
 
 (* local facts *)
 
 fun pretty_local_facts verbose ctxt =
   let
     val facts = facts_of ctxt;
     val props = map #1 (Facts.props facts);
     val local_facts =
       (if null props then [] else [("<unnamed>", props)]) @
       Facts.dest_static verbose [Global_Theory.facts_of (theory_of ctxt)] facts;
   in
     if null local_facts then []
     else
       [Pretty.big_list "local facts:"
         (map #1 (sort_by (#1 o #2) (map (`(pretty_fact ctxt)) local_facts)))]
   end;
 
 fun print_local_facts verbose ctxt =
   Pretty.writeln_chunks (pretty_local_facts verbose ctxt);
 
 
 (* named local contexts *)
 
 local
 
 fun pretty_case (name, (fixes, ((asms, (lets, cs)), ctxt))) =
   let
     val prt_name = pretty_name ctxt;
     val prt_term = Syntax.pretty_term ctxt;
 
     fun prt_let (xi, t) = Pretty.block
       [Pretty.quote (prt_term (Var (xi, Term.fastype_of t))), Pretty.str " =", Pretty.brk 1,
         Pretty.quote (prt_term t)];
 
     fun prt_asm (a, ts) =
       Pretty.block (Pretty.breaks
         ((if a = "" then [] else [prt_name a, Pretty.str ":"]) @
           map (Pretty.quote o prt_term) ts));
 
     fun prt_sect _ _ _ [] = []
       | prt_sect head sep prt xs =
           [Pretty.block (Pretty.breaks (head ::
             flat (separate sep (map (single o prt) xs))))];
   in
     Pretty.block
       (prt_name name :: Pretty.str ":" :: Pretty.fbrk ::
         Pretty.fbreaks
           (prt_sect (Pretty.keyword1 "fix") [] (prt_name o Binding.name_of o fst) fixes @
            prt_sect (Pretty.keyword1 "let") [Pretty.keyword2 "and"] prt_let
              (map_filter (fn (xi, SOME t) => SOME (xi, t) | _ => NONE) lets) @
            (if forall (null o #2) asms then []
             else prt_sect (Pretty.keyword1 "assume") [Pretty.keyword2 "and"] prt_asm asms) @
            prt_sect (Pretty.str "subcases:") [] (prt_name o fst) cs))
   end;
 
 in
 
 fun pretty_cases ctxt =
   let
     val cases =
       dest_cases NONE ctxt |> map (fn (name, c as Rule_Cases.Case {fixes, ...}) =>
         (name, (fixes, case_result c ctxt)));
   in
     if null cases then []
     else [Pretty.big_list "cases:" (map pretty_case cases)]
   end;
 
 end;
 
 fun print_cases_proof ctxt0 ctxt =
   let
     fun trim_name x = if Name.is_internal x then Name.clean x else "_";
     val trim_names = map trim_name #> drop_suffix (equal "_");
 
     fun print_case name xs =
       (case trim_names xs of
         [] => print_name ctxt name
       | xs' => enclose "(" ")" (space_implode " " (map (print_name ctxt) (name :: xs'))));
 
     fun is_case x t =
       x = Rule_Cases.case_conclN andalso not (Term.exists_subterm Term.is_Var t);
 
     fun indentation depth = prefix (Symbol.spaces (2 * depth));
 
     fun print_proof depth (name, Rule_Cases.Case {fixes, binds, cases, ...}) =
           let
             val indent = indentation depth;
             val head = indent ("case " ^ print_case name (map (Binding.name_of o #1) fixes));
             val tail =
               if null cases then
                 let val concl =
                   if exists (fn ((x, _), SOME t) => is_case x t | _ => false) binds
                   then Rule_Cases.case_conclN else Auto_Bind.thesisN
                 in indent ("then show ?" ^ concl ^ " sorry") end
               else print_proofs depth cases;
           in head ^ "\n" ^ tail end
     and print_proofs 0 [] = ""
       | print_proofs depth cases =
           let
             val indent = indentation depth;
             val body = map (print_proof (depth + 1)) cases |> separate (indent "next")
           in
             if depth = 0 then body @ [indent "qed"]
             else if length cases = 1 then body
             else indent "{" :: body @ [indent "}"]
           end |> cat_lines;
   in
     (case print_proofs 0 (dest_cases (SOME ctxt0) ctxt) of
       "" => ""
     | s => "Proof outline with cases:\n" ^ Active.sendback_markup_command s)
   end;
 
 
 (* core context *)
 
 val debug = Config.declare_bool ("Proof_Context.debug", \<^here>) (K false);
 val verbose = Config.declare_bool ("Proof_Context.verbose", \<^here>) (K false);
 
 fun pretty_ctxt ctxt =
   if not (Config.get ctxt debug) then []
   else
     let
       val prt_term = Syntax.pretty_term ctxt;
 
       (*structures*)
       val {structs, ...} = Syntax_Trans.get_idents ctxt;
       val prt_structs =
         if null structs then []
         else [Pretty.block (Pretty.str "structures:" :: Pretty.brk 1 ::
           Pretty.commas (map Pretty.str structs))];
 
       (*fixes*)
       fun prt_fix (x, x') =
         if x = x' then Pretty.str x
         else Pretty.block [Pretty.str x, Pretty.str " =", Pretty.brk 1, prt_term (Syntax.free x')];
       val fixes =
         filter_out ((Name.is_internal orf member (op =) structs) o #1)
           (Variable.dest_fixes ctxt);
       val prt_fixes =
         if null fixes then []
         else [Pretty.block (Pretty.str "fixed variables:" :: Pretty.brk 1 ::
           Pretty.commas (map prt_fix fixes))];
 
       (*assumptions*)
       val prt_assms =
         (case Assumption.all_prems_of ctxt of
           [] => []
         | prems => [Pretty.big_list "assumptions:" [pretty_fact ctxt ("", prems)]]);
     in prt_structs @ prt_fixes @ prt_assms end;
 
 
 (* main context *)
 
 fun pretty_context ctxt =
   let
     val verbose = Config.get ctxt verbose;
     fun verb f x = if verbose then f (x ()) else [];
 
     val prt_term = Syntax.pretty_term ctxt;
     val prt_typ = Syntax.pretty_typ ctxt;
     val prt_sort = Syntax.pretty_sort ctxt;
 
     (*theory*)
     val pretty_thy = Pretty.block
       [Pretty.str "theory:", Pretty.brk 1, Context.pretty_thy (theory_of ctxt)];
 
     (*defaults*)
     fun prt_atom prt prtT (x, X) = Pretty.block
       [prt x, Pretty.str " ::", Pretty.brk 1, prtT X];
 
     fun prt_var (x, ~1) = prt_term (Syntax.free x)
       | prt_var xi = prt_term (Syntax.var xi);
 
     fun prt_varT (x, ~1) = prt_typ (TFree (x, []))
       | prt_varT xi = prt_typ (TVar (xi, []));
 
     val prt_defT = prt_atom prt_var prt_typ;
     val prt_defS = prt_atom prt_varT prt_sort;
 
     val (types, sorts) = Variable.constraints_of ctxt;
   in
     verb single (K pretty_thy) @
     pretty_ctxt ctxt @
     verb (pretty_abbrevs true false) (K ctxt) @
     verb pretty_term_bindings (K ctxt) @
     verb (pretty_local_facts true) (K ctxt) @
     verb pretty_cases (K ctxt) @
     verb single (fn () => Pretty.big_list "type constraints:" (map prt_defT (Vartab.dest types))) @
     verb single (fn () => Pretty.big_list "default sorts:" (map prt_defS (Vartab.dest sorts)))
   end;
 
 end;
 
 val show_abbrevs = Proof_Context.show_abbrevs;
diff --git a/src/Pure/Isar/specification.ML b/src/Pure/Isar/specification.ML
--- a/src/Pure/Isar/specification.ML
+++ b/src/Pure/Isar/specification.ML
@@ -1,478 +1,478 @@
 (*  Title:      Pure/Isar/specification.ML
     Author:     Makarius
 
 Derived local theory specifications --- with type-inference and
 toplevel polymorphism.
 *)
 
 signature SPECIFICATION =
 sig
   val read_props: string list -> (binding * string option * mixfix) list -> Proof.context ->
     term list * Proof.context
   val check_spec_open: (binding * typ option * mixfix) list ->
     (binding * typ option * mixfix) list -> term list -> term -> Proof.context ->
     ((binding * typ option * mixfix) list * string list * (string -> Position.T list) * term) *
     Proof.context
   val read_spec_open: (binding * string option * mixfix) list ->
     (binding * string option * mixfix) list -> string list -> string -> Proof.context ->
     ((binding * typ option * mixfix) list * string list * (string -> Position.T list) * term) *
     Proof.context
   type multi_specs =
     ((Attrib.binding * term) * term list * (binding * typ option * mixfix) list) list
   type multi_specs_cmd =
     ((Attrib.binding * string) * string list * (binding * string option * mixfix) list) list
   val check_multi_specs: (binding * typ option * mixfix) list -> multi_specs -> Proof.context ->
     (((binding * typ) * mixfix) list * (Attrib.binding * term) list) * Proof.context
   val read_multi_specs: (binding * string option * mixfix) list -> multi_specs_cmd -> Proof.context ->
     (((binding * typ) * mixfix) list * (Attrib.binding * term) list) * Proof.context
   val axiomatization: (binding * typ option * mixfix) list ->
     (binding * typ option * mixfix) list -> term list ->
     (Attrib.binding * term) list -> theory -> (term list * thm list) * theory
   val axiomatization_cmd: (binding * string option * mixfix) list ->
     (binding * string option * mixfix) list -> string list ->
     (Attrib.binding * string) list -> theory -> (term list * thm list) * theory
   val axiom: Attrib.binding * term -> theory -> thm * theory
   val definition: (binding * typ option * mixfix) option ->
     (binding * typ option * mixfix) list -> term list -> Attrib.binding * term ->
     local_theory -> (term * (string * thm)) * local_theory
   val definition': (binding * typ option * mixfix) option ->
     (binding * typ option * mixfix) list ->  term list -> Attrib.binding * term ->
     bool -> local_theory -> (term * (string * thm)) * local_theory
   val definition_cmd: (binding * string option * mixfix) option ->
     (binding * string option * mixfix) list -> string list -> Attrib.binding * string ->
     bool -> local_theory -> (term * (string * thm)) * local_theory
   val abbreviation: Syntax.mode -> (binding * typ option * mixfix) option ->
     (binding * typ option * mixfix) list -> term -> bool -> local_theory -> local_theory
   val abbreviation_cmd: Syntax.mode -> (binding * string option * mixfix) option ->
     (binding * string option * mixfix) list -> string -> bool -> local_theory -> local_theory
   val alias: binding * string -> local_theory -> local_theory
   val alias_cmd: binding * (xstring * Position.T) -> local_theory -> local_theory
   val type_alias: binding * string -> local_theory -> local_theory
   val type_alias_cmd: binding * (xstring * Position.T) -> local_theory -> local_theory
   val type_notation: bool -> Syntax.mode -> (typ * mixfix) list -> local_theory -> local_theory
   val type_notation_cmd: bool -> Syntax.mode -> (string * mixfix) list ->
     local_theory -> local_theory
   val notation: bool -> Syntax.mode -> (term * mixfix) list -> local_theory -> local_theory
   val notation_cmd: bool -> Syntax.mode -> (string * mixfix) list -> local_theory -> local_theory
   val theorems: string ->
     (Attrib.binding * Attrib.thms) list ->
     (binding * typ option * mixfix) list ->
     bool -> local_theory -> (string * thm list) list * local_theory
   val theorems_cmd: string ->
     (Attrib.binding * (Facts.ref * Token.src list) list) list ->
     (binding * string option * mixfix) list ->
     bool -> local_theory -> (string * thm list) list * local_theory
   val theorem: bool -> string -> Method.text option ->
     (thm list list -> local_theory -> local_theory) -> Attrib.binding ->
     string list -> Element.context_i list -> Element.statement_i ->
     bool -> local_theory -> Proof.state
   val theorem_cmd: bool -> string -> Method.text option ->
     (thm list list -> local_theory -> local_theory) -> Attrib.binding ->
     (xstring * Position.T) list -> Element.context list -> Element.statement ->
     bool -> local_theory -> Proof.state
   val schematic_theorem: bool -> string -> Method.text option ->
     (thm list list -> local_theory -> local_theory) -> Attrib.binding ->
     string list -> Element.context_i list -> Element.statement_i ->
     bool -> local_theory -> Proof.state
   val schematic_theorem_cmd: bool -> string -> Method.text option ->
     (thm list list -> local_theory -> local_theory) -> Attrib.binding ->
     (xstring * Position.T) list -> Element.context list -> Element.statement ->
     bool -> local_theory -> Proof.state
 end;
 
 structure Specification: SPECIFICATION =
 struct
 
 (* prepare propositions *)
 
 fun read_props raw_props raw_fixes ctxt =
   let
     val (_, ctxt1) = ctxt |> Proof_Context.add_fixes_cmd raw_fixes;
     val props1 = map (Syntax.parse_prop ctxt1) raw_props;
     val (props2, ctxt2) = ctxt1 |> fold_map Variable.fix_dummy_patterns props1;
     val props3 = Syntax.check_props ctxt2 props2;
     val ctxt3 = ctxt2 |> fold Variable.declare_term props3;
   in (props3, ctxt3) end;
 
 
 (* prepare specification *)
 
 fun get_positions ctxt x =
   let
     fun get Cs (Const ("_type_constraint_", C) $ t) = get (C :: Cs) t
       | get Cs (Free (y, T)) =
           if x = y then
             map_filter Term_Position.decode_positionT
               (T :: map (Type.constraint_type ctxt) Cs)
           else []
       | get _ (t $ u) = get [] t @ get [] u
       | get _ (Abs (_, _, t)) = get [] t
       | get _ _ = [];
   in get [] end;
 
 local
 
 fun prep_decls prep_var raw_vars ctxt =
   let
     val (vars, ctxt') = fold_map prep_var raw_vars ctxt;
     val (xs, ctxt'') = ctxt'
       |> Context_Position.set_visible false
       |> Proof_Context.add_fixes vars
       ||> Context_Position.restore_visible ctxt';
     val _ =
       Context_Position.reports ctxt''
         (map (Binding.pos_of o #1) vars ~~
           map (Variable.markup_entity_def ctxt'' ##> Properties.remove Markup.kindN) xs);
   in ((vars, xs), ctxt'') end;
 
 fun close_form ctxt ys prems concl =
   let
     val xs = rev (fold (Variable.add_free_names ctxt) (prems @ [concl]) (rev ys));
 
     val pos_props = Logic.strip_imp_concl concl :: Logic.strip_imp_prems concl @ prems;
     fun get_pos x = maps (get_positions ctxt x) pos_props;
     val _ = Context_Position.reports ctxt (maps (Syntax_Phases.reports_of_scope o get_pos) xs);
   in Logic.close_prop_constraint (Variable.default_type ctxt) (xs ~~ xs) prems concl end;
 
 fun dummy_frees ctxt xs tss =
   let
     val names =
       Variable.names_of ((fold o fold) Variable.declare_term tss ctxt)
       |> fold Name.declare xs;
     val (tss', _) = (fold_map o fold_map) Term.free_dummy_patterns tss names;
   in tss' end;
 
 fun prep_spec_open prep_var parse_prop raw_vars raw_params raw_prems raw_concl ctxt =
   let
     val ((vars, xs), vars_ctxt) = prep_decls prep_var raw_vars ctxt;
     val (ys, params_ctxt) = vars_ctxt |> fold_map prep_var raw_params |-> Proof_Context.add_fixes;
 
     val props =
       map (parse_prop params_ctxt) (raw_concl :: raw_prems)
       |> singleton (dummy_frees params_ctxt (xs @ ys));
 
     val concl :: prems = Syntax.check_props params_ctxt props;
     val spec = Logic.list_implies (prems, concl);
     val spec_ctxt = Variable.declare_term spec params_ctxt;
 
     fun get_pos x = maps (get_positions spec_ctxt x) props;
   in ((vars, xs, get_pos, spec), spec_ctxt) end;
 
 fun prep_specs prep_var parse_prop prep_att raw_vars raw_specss ctxt =
   let
     val ((vars, xs), vars_ctxt) = prep_decls prep_var raw_vars ctxt;
 
     val propss0 =
       raw_specss |> map (fn ((_, raw_concl), raw_prems, raw_params) =>
         let val (ys, ctxt') = vars_ctxt |> fold_map prep_var raw_params |-> Proof_Context.add_fixes
         in (ys, map (pair ctxt') (raw_concl :: raw_prems)) end);
     val props =
       burrow (grouped 10 Par_List.map_independent (uncurry parse_prop)) (map #2 propss0)
       |> dummy_frees vars_ctxt xs
       |> map2 (fn (ys, _) => fn concl :: prems => close_form vars_ctxt ys prems concl) propss0;
 
     val specs = Syntax.check_props vars_ctxt props;
     val specs_ctxt = vars_ctxt |> fold Variable.declare_term specs;
 
     val ps = specs_ctxt |> fold_map Proof_Context.inferred_param xs |> fst;
     val params = map2 (fn (b, _, mx) => fn (_, T) => ((b, T), mx)) vars ps;
     val name_atts: Attrib.binding list =
       map (fn ((name, atts), _) => (name, map (prep_att ctxt) atts)) (map #1 raw_specss);
   in ((params, name_atts ~~ specs), specs_ctxt) end;
 
 in
 
 val check_spec_open = prep_spec_open Proof_Context.cert_var (K I);
 val read_spec_open = prep_spec_open Proof_Context.read_var Syntax.parse_prop;
 
 type multi_specs =
   ((Attrib.binding * term) * term list * (binding * typ option * mixfix) list) list;
 type multi_specs_cmd =
   ((Attrib.binding * string) * string list * (binding * string option * mixfix) list) list;
 
 fun check_multi_specs xs specs =
   prep_specs Proof_Context.cert_var (K I) (K I) xs specs;
 
 fun read_multi_specs xs specs =
   prep_specs Proof_Context.read_var Syntax.parse_prop Attrib.check_src xs specs;
 
 end;
 
 
 (* axiomatization -- within global theory *)
 
 fun gen_axioms prep_stmt prep_att raw_decls raw_fixes raw_prems raw_concls thy =
   let
     (*specification*)
     val ({vars, propss = [prems, concls], ...}, vars_ctxt) =
       Proof_Context.init_global thy
       |> prep_stmt (raw_decls @ raw_fixes) ((map o map) (rpair []) [raw_prems, map snd raw_concls]);
     val (decls, fixes) = chop (length raw_decls) vars;
 
     val frees =
       rev ((fold o fold) (Variable.add_frees vars_ctxt) [prems, concls] [])
       |> map (fn (x, T) => (x, Free (x, T)));
     val close = Logic.close_prop (map #2 fixes @ frees) prems;
     val specs =
       map ((apsnd o map) (prep_att vars_ctxt) o fst) raw_concls ~~ map close concls;
 
     val spec_name =
       Binding.conglomerate (if null decls then map (#1 o #1) specs else map (#1 o #1) decls);
 
 
     (*consts*)
     val (consts, consts_thy) = thy
       |> fold_map (fn ((b, _, mx), (_, t)) => Theory.specify_const ((b, Term.type_of t), mx)) decls;
     val subst = Term.subst_atomic (map (#2 o #2) decls ~~ consts);
 
     (*axioms*)
     val (axioms, axioms_thy) =
       (specs, consts_thy) |-> fold_map (fn ((b, atts), prop) =>
         Thm.add_axiom_global (b, subst prop) #>> (fn (_, th) => ((b, atts), [([th], [])])));
 
     (*facts*)
     val (facts, facts_lthy) = axioms_thy
       |> Named_Target.theory_init
       |> Spec_Rules.add spec_name Spec_Rules.Unknown consts (maps (maps #1 o #2) axioms)
       |> Local_Theory.notes axioms;
 
   in ((consts, map (the_single o #2) facts), Local_Theory.exit_global facts_lthy) end;
 
 val axiomatization = gen_axioms Proof_Context.cert_stmt (K I);
 val axiomatization_cmd = gen_axioms Proof_Context.read_stmt Attrib.check_src;
 
 fun axiom (b, ax) = axiomatization [] [] [] [(b, ax)] #>> (hd o snd);
 
 
 (* definition *)
 
 fun gen_def prep_spec prep_att raw_var raw_params raw_prems ((a, raw_atts), raw_spec) int lthy =
   let
     val atts = map (prep_att lthy) raw_atts;
 
     val ((vars, xs, get_pos, spec), _) = lthy
       |> prep_spec (the_list raw_var) raw_params raw_prems raw_spec;
     val (((x, T), rhs), prove) = Local_Defs.derived_def lthy get_pos {conditional = true} spec;
     val _ = Name.reject_internal (x, []);
     val (b, mx) =
       (case (vars, xs) of
         ([], []) => (Binding.make (x, (case get_pos x of [] => Position.none | p :: _ => p)), NoSyn)
       | ([(b, _, mx)], [y]) =>
           if x = y then (b, mx)
           else
             error ("Head of definition " ^ quote x ^ " differs from declaration " ^ quote y ^
               Position.here (Binding.pos_of b)));
     val const_name = Local_Theory.full_name lthy b;
 
     val name = Thm.def_binding_optional b a;
     val ((lhs, (_, raw_th)), lthy2) = lthy
       |> Local_Theory.define_internal ((b, mx), ((Binding.suffix_name "_raw" name, []), rhs));
 
     val th = prove lthy2 raw_th;
     val lthy3 = lthy2 |> Spec_Rules.add name Spec_Rules.equational [lhs] [th];
 
     val ([(def_name, [th'])], lthy4) = lthy3
       |> Local_Theory.notes [((name, atts), [([th], [])])];
 
     val lthy5 = lthy4
       |> Code.declare_default_eqns [(th', true)];
 
     val lhs' = Morphism.term (Local_Theory.target_morphism lthy5) lhs;
 
     val _ =
       Proof_Display.print_consts int (Position.thread_data ()) lthy5
-        (Term_Subst.Frees.defined (Term_Subst.add_frees lhs' Term_Subst.Frees.empty)) [(x, T)];
+        (Term_Subst.Frees.defined (Term_Subst.Frees.build (Term_Subst.add_frees lhs'))) [(x, T)];
   in ((lhs, (def_name, th')), lthy5) end;
 
 val definition' = gen_def check_spec_open (K I);
 fun definition xs ys As B = definition' xs ys As B false;
 val definition_cmd = gen_def read_spec_open Attrib.check_src;
 
 
 (* abbreviation *)
 
 fun gen_abbrev prep_spec mode raw_var raw_params raw_spec int lthy =
   let
     val lthy1 = lthy |> Proof_Context.set_syntax_mode mode;
     val ((vars, xs, get_pos, spec), _) = lthy
       |> Proof_Context.set_mode Proof_Context.mode_abbrev
       |> prep_spec (the_list raw_var) raw_params [] raw_spec;
     val ((x, T), rhs) = Local_Defs.abs_def (#2 (Local_Defs.cert_def lthy1 get_pos spec));
     val _ = Name.reject_internal (x, []);
     val (b, mx) =
       (case (vars, xs) of
         ([], []) => (Binding.make (x, (case get_pos x of [] => Position.none | p :: _ => p)), NoSyn)
       | ([(b, _, mx)], [y]) =>
           if x = y then (b, mx)
           else
             error ("Head of abbreviation " ^ quote x ^ " differs from declaration " ^ quote y ^
               Position.here (Binding.pos_of b)));
     val lthy2 = lthy1
       |> Local_Theory.abbrev mode ((b, mx), rhs) |> snd
       |> Proof_Context.restore_syntax_mode lthy;
 
     val _ = Proof_Display.print_consts int (Position.thread_data ()) lthy2 (K false) [(x, T)];
   in lthy2 end;
 
 val abbreviation = gen_abbrev check_spec_open;
 val abbreviation_cmd = gen_abbrev read_spec_open;
 
 
 (* alias *)
 
 fun gen_alias decl check (b, arg) lthy =
   let
     val (c, reports) = check {proper = true, strict = false} lthy arg;
     val _ = Context_Position.reports lthy reports;
   in decl b c lthy end;
 
 val alias =
   gen_alias Local_Theory.const_alias (K (K (fn c => (c, []))));
 val alias_cmd =
   gen_alias Local_Theory.const_alias
     (fn flags => fn ctxt => fn (c, pos) =>
       apfst (#1 o dest_Const) (Proof_Context.check_const flags ctxt (c, [pos])));
 
 val type_alias =
   gen_alias Local_Theory.type_alias (K (K (fn c => (c, []))));
 val type_alias_cmd =
   gen_alias Local_Theory.type_alias (apfst (#1 o dest_Type) ooo Proof_Context.check_type_name);
 
 
 (* notation *)
 
 local
 
 fun gen_type_notation prep_type add mode args lthy =
   lthy |> Local_Theory.type_notation add mode (map (apfst (prep_type lthy)) args);
 
 fun gen_notation prep_const add mode args lthy =
   lthy |> Local_Theory.notation add mode (map (apfst (prep_const lthy)) args);
 
 in
 
 val type_notation = gen_type_notation (K I);
 val type_notation_cmd =
   gen_type_notation (Proof_Context.read_type_name {proper = true, strict = false});
 
 val notation = gen_notation (K I);
 val notation_cmd = gen_notation (Proof_Context.read_const {proper = false, strict = false});
 
 end;
 
 
 (* fact statements *)
 
 local
 
 fun gen_theorems prep_fact prep_att add_fixes
     kind raw_facts raw_fixes int lthy =
   let
     val facts = raw_facts |> map (fn ((name, atts), bs) =>
       ((name, map (prep_att lthy) atts),
         bs |> map (fn (b, more_atts) => (prep_fact lthy b, map (prep_att lthy) more_atts))));
     val (_, ctxt') = add_fixes raw_fixes lthy;
 
     val facts' = facts
       |> Attrib.partial_evaluation ctxt'
       |> Attrib.transform_facts (Proof_Context.export_morphism ctxt' lthy);
     val (res, lthy') = lthy |> Local_Theory.notes_kind kind facts';
     val _ = Proof_Display.print_results int (Position.thread_data ()) lthy' ((kind, ""), res);
   in (res, lthy') end;
 
 in
 
 val theorems = gen_theorems (K I) (K I) Proof_Context.add_fixes;
 val theorems_cmd = gen_theorems Proof_Context.get_fact Attrib.check_src Proof_Context.add_fixes_cmd;
 
 end;
 
 
 (* complex goal statements *)
 
 local
 
 fun prep_statement prep_att prep_stmt raw_elems raw_stmt ctxt =
   let
     val (stmt, elems_ctxt) = prep_stmt raw_elems raw_stmt ctxt;
     val prems = Assumption.local_prems_of elems_ctxt ctxt;
     val stmt_ctxt = fold (fold (Proof_Context.augment o fst) o snd) stmt elems_ctxt;
   in
     (case raw_stmt of
       Element.Shows _ =>
         let val stmt' = Attrib.map_specs (map prep_att) stmt
         in (([], prems, stmt', NONE), stmt_ctxt) end
     | Element.Obtains raw_obtains =>
         let
           val asms_ctxt = stmt_ctxt
             |> fold (fn ((name, _), asm) =>
                 snd o Proof_Context.add_assms Assumption.assume_export
                   [((name, [Context_Rules.intro_query NONE]), asm)]) stmt;
           val that = Assumption.local_prems_of asms_ctxt stmt_ctxt;
           val ([(_, that')], that_ctxt) = asms_ctxt
             |> Proof_Context.set_stmt true
             |> Proof_Context.note_thmss "" [((Binding.name Auto_Bind.thatN, []), [(that, [])])]
             ||> Proof_Context.restore_stmt asms_ctxt;
 
           val stmt' = [(Binding.empty_atts, [(#2 (#1 (Obtain.obtain_thesis ctxt)), [])])];
         in ((Obtain.obtains_attribs raw_obtains, prems, stmt', SOME that'), that_ctxt) end)
   end;
 
 fun gen_theorem schematic bundle_includes prep_att prep_stmt
     long kind before_qed after_qed (name, raw_atts) raw_includes raw_elems raw_concl int lthy =
   let
     val _ = Local_Theory.assert lthy;
 
     val elems = raw_elems |> map (Element.map_ctxt_attrib (prep_att lthy));
     val ((more_atts, prems, stmt, facts), goal_ctxt) = lthy
       |> bundle_includes raw_includes
       |> prep_statement (prep_att lthy) prep_stmt elems raw_concl;
     val atts = more_atts @ map (prep_att lthy) raw_atts;
 
     val pos = Position.thread_data ();
     fun after_qed' results goal_ctxt' =
       let
         val results' =
           burrow (map (Goal.norm_result lthy) o Proof_Context.export goal_ctxt' lthy) results;
         val (res, lthy') =
           if forall (Binding.is_empty_atts o fst) stmt then (map (pair "") results', lthy)
           else
             Local_Theory.notes_kind kind
               (map2 (fn (b, _) => fn ths => (b, [(ths, [])])) stmt results') lthy;
         val lthy'' =
           if Binding.is_empty_atts (name, atts) then
             (Proof_Display.print_results int pos lthy' ((kind, ""), res); lthy')
           else
             let
               val ([(res_name, _)], lthy'') =
                 Local_Theory.notes_kind kind [((name, atts), [(maps #2 res, [])])] lthy';
               val _ = Proof_Display.print_results int pos lthy' ((kind, res_name), res);
             in lthy'' end;
       in after_qed results' lthy'' end;
 
     val prems_name = if long then Auto_Bind.assmsN else Auto_Bind.thatN;
   in
     goal_ctxt
     |> not (null prems) ?
       (Proof_Context.note_thmss "" [((Binding.name prems_name, []), [(prems, [])])] #> snd)
     |> Proof.theorem before_qed after_qed' (map snd stmt)
     |> (case facts of NONE => I | SOME ths => Proof.refine_insert ths)
     |> tap (fn state => not schematic andalso Proof.schematic_goal state andalso
         error "Illegal schematic goal statement")
   end;
 
 in
 
 val theorem =
   gen_theorem false Bundle.includes (K I) Expression.cert_statement;
 val theorem_cmd =
   gen_theorem false Bundle.includes_cmd Attrib.check_src Expression.read_statement;
 
 val schematic_theorem =
   gen_theorem true Bundle.includes (K I) Expression.cert_statement;
 val schematic_theorem_cmd =
   gen_theorem true Bundle.includes_cmd Attrib.check_src Expression.read_statement;
 
 end;
 
 end;
diff --git a/src/Pure/Isar/subgoal.ML b/src/Pure/Isar/subgoal.ML
--- a/src/Pure/Isar/subgoal.ML
+++ b/src/Pure/Isar/subgoal.ML
@@ -1,257 +1,257 @@
 (*  Title:      Pure/Isar/subgoal.ML
     Author:     Makarius
     Author:     Daniel Matichuk, NICTA/UNSW
 
 Tactical operations with explicit subgoal focus, based on canonical
 proof decomposition.  The "visible" part of the text within the
 context is fixed, the remaining goal may be schematic.
 
 Isar subgoal command for proof structure within unstructured proof
 scripts.
 *)
 
 signature SUBGOAL =
 sig
   type focus =
    {context: Proof.context, params: (string * cterm) list, prems: thm list, asms: cterm list,
     concl: cterm, schematics: ((indexname * sort) * ctyp) list * ((indexname * typ) * cterm) list}
   val focus_params: Proof.context -> int -> binding list option -> thm -> focus * thm
   val focus_params_fixed: Proof.context -> int -> binding list option -> thm -> focus * thm
   val focus_prems: Proof.context -> int -> binding list option -> thm -> focus * thm
   val focus: Proof.context -> int -> binding list option -> thm -> focus * thm
   val retrofit: Proof.context -> Proof.context -> (string * cterm) list -> cterm list ->
     int -> thm -> thm -> thm Seq.seq
   val FOCUS_PARAMS: (focus -> tactic) -> Proof.context -> int -> tactic
   val FOCUS_PARAMS_FIXED: (focus -> tactic) -> Proof.context -> int -> tactic
   val FOCUS_PREMS: (focus -> tactic) -> Proof.context -> int -> tactic
   val FOCUS: (focus -> tactic) -> Proof.context -> int -> tactic
   val SUBPROOF: (focus -> tactic) -> Proof.context -> int -> tactic
   val subgoal: Attrib.binding -> Attrib.binding option ->
     bool * (string option * Position.T) list -> Proof.state -> focus * Proof.state
   val subgoal_cmd: Attrib.binding -> Attrib.binding option ->
     bool * (string option * Position.T) list -> Proof.state -> focus * Proof.state
 end;
 
 structure Subgoal: SUBGOAL =
 struct
 
 (* focus *)
 
 type focus =
  {context: Proof.context, params: (string * cterm) list, prems: thm list, asms: cterm list,
   concl: cterm, schematics: ((indexname * sort) * ctyp) list * ((indexname * typ) * cterm) list};
 
 fun gen_focus (do_prems, do_concl) ctxt i bindings raw_st =
   let
     val st = raw_st
       |> Thm.solve_constraints
       |> Thm.transfer' ctxt
       |> Raw_Simplifier.norm_hhf_protect ctxt;
     val ((schematic_types, [st']), ctxt1) = Variable.importT [st] ctxt;
     val ((params, goal), ctxt2) = Variable.focus_cterm bindings (Thm.cprem_of st' i) ctxt1;
 
     val (asms, concl) =
       if do_prems then (Drule.strip_imp_prems goal, Drule.strip_imp_concl goal)
       else ([], goal);
     val text = asms @ (if do_concl then [concl] else []);
 
     val ((_, inst), ctxt3) = Variable.import_inst true (map Thm.term_of text) ctxt2;
     val schematic_terms = Term_Subst.Vars.fold (fn (v, t) => cons (v, Thm.cterm_of ctxt3 t)) inst [];
 
     val schematics = (schematic_types, schematic_terms);
     val asms' = map (Thm.instantiate_cterm schematics) asms;
     val concl' = Thm.instantiate_cterm schematics concl;
     val (prems, context) = Assumption.add_assumes asms' ctxt3;
   in
     ({context = context, params = params, prems = prems,
       asms = asms', concl = concl', schematics = schematics}, Goal.init concl')
   end;
 
 val focus_params = gen_focus (false, false);
 val focus_params_fixed = gen_focus (false, true);
 val focus_prems = gen_focus (true, false);
 val focus = gen_focus (true, true);
 
 
 (* lift and retrofit *)
 
 (*
      B [?'b, ?y]
   ----------------
   B ['b, y params]
 *)
 fun lift_import idx params th ctxt =
   let
     val ((_, [th']), ctxt') = Variable.importT [th] ctxt;
 
     val Ts = map Thm.typ_of_cterm params;
     val ts = map Thm.term_of params;
 
     val prop = Thm.full_prop_of th';
-    val concl_vars = Term_Subst.add_vars (Logic.strip_imp_concl prop) Term_Subst.Vars.empty;
+    val concl_vars = Term_Subst.Vars.build (Term_Subst.add_vars (Logic.strip_imp_concl prop));
     val vars = rev (Term.add_vars prop []);
     val (ys, ctxt'') = Variable.variant_fixes (map (Name.clean o #1 o #1) vars) ctxt';
 
     fun var_inst v y =
       let
         val ((x, i), T) = v;
         val (U, args) =
           if Term_Subst.Vars.defined concl_vars v then (T, [])
           else (Ts ---> T, ts);
         val u = Free (y, U);
         in ((Var v, list_comb (u, args)), (u, Var ((x, i + idx), U))) end;
     val (inst1, inst2) =
       split_list (map (apply2 (apply2 (Thm.cterm_of ctxt))) (map2 var_inst vars ys));
 
     val th'' = Thm.instantiate ([], map (apfst (Term.dest_Var o Thm.term_of)) inst1) th';
   in ((inst2, th''), ctxt'') end;
 
 (*
        [x, A x]
           :
        B x \<Longrightarrow> C
   ------------------
   [\<And>x. A x \<Longrightarrow> B x]
           :
           C
 *)
 fun lift_subgoals ctxt params asms th =
   let
     fun lift ct = fold_rev (Thm.all_name ctxt) params (Drule.list_implies (asms, ct));
     val unlift =
       fold (Thm.elim_implies o Thm.assume) asms o
       Drule.forall_elim_list (map #2 params) o Thm.assume;
     val subgoals = map lift (Drule.strip_imp_prems (Thm.cprop_of th));
     val th' = fold (Thm.elim_implies o unlift) subgoals th;
   in (subgoals, th') end;
 
 fun retrofit ctxt1 ctxt0 params asms i st1 st0 =
   let
     val idx = Thm.maxidx_of st0 + 1;
     val ps = map #2 params;
     val ((subgoal_inst, st2), ctxt2) = lift_import idx ps st1 ctxt1;
     val (subgoals, st3) = lift_subgoals ctxt2 params asms st2;
     val result = st3
       |> Goal.conclude
       |> Drule.implies_intr_list asms
       |> Drule.forall_intr_list ps
       |> Drule.implies_intr_list subgoals
       |> fold_rev (Thm.forall_intr o #1) subgoal_inst
       |> fold (Thm.forall_elim o #2) subgoal_inst
       |> Thm.adjust_maxidx_thm idx
       |> singleton (Variable.export ctxt2 ctxt0);
   in
     Thm.bicompose (SOME ctxt0) {flatten = true, match = false, incremented = false}
       (false, result, Thm.nprems_of st1) i st0
   end;
 
 
 (* tacticals *)
 
 fun GEN_FOCUS flags tac ctxt i st =
   if Thm.nprems_of st < i then Seq.empty
   else
     let val (args as {context = ctxt', params, asms, ...}, st') =
       gen_focus flags (ctxt |> Variable.set_bound_focus true) i NONE st;
     in Seq.lifts (retrofit ctxt' ctxt params asms i) (tac args st') st end;
 
 val FOCUS_PARAMS = GEN_FOCUS (false, false);
 val FOCUS_PARAMS_FIXED = GEN_FOCUS (false, true);
 val FOCUS_PREMS = GEN_FOCUS (true, false);
 val FOCUS = GEN_FOCUS (true, true);
 
 fun SUBPROOF tac ctxt = FOCUS (Seq.map (Goal.check_finished ctxt) oo tac) ctxt;
 
 
 (* Isar subgoal command *)
 
 local
 
 fun param_bindings ctxt (param_suffix, raw_param_specs) st =
   let
     val _ = if Thm.no_prems st then error "No subgoals!" else ();
     val subgoal = #1 (Logic.dest_implies (Thm.prop_of st));
     val subgoal_params =
       map (apfst (Name.internal o Name.clean)) (Term.strip_all_vars subgoal)
       |> Term.variant_frees subgoal |> map #1;
 
     val n = length subgoal_params;
     val m = length raw_param_specs;
     val _ =
       m <= n orelse
         error ("Excessive subgoal parameter specification" ^
           Position.here_list (map snd (drop n raw_param_specs)));
 
     val param_specs =
       raw_param_specs |> map
         (fn (NONE, _) => NONE
           | (SOME x, pos) =>
               let
                 val b = #1 (#1 (Proof_Context.cert_var (Binding.make (x, pos), NONE, NoSyn) ctxt));
                 val _ = Variable.check_name b;
               in SOME b end)
       |> param_suffix ? append (replicate (n - m) NONE);
 
     fun bindings (SOME x :: xs) (_ :: ys) = x :: bindings xs ys
       | bindings (NONE :: xs) (y :: ys) = Binding.name y :: bindings xs ys
       | bindings _ ys = map Binding.name ys;
   in bindings param_specs subgoal_params end;
 
 fun gen_subgoal prep_atts raw_result_binding raw_prems_binding param_specs state =
   let
     val _ = Proof.assert_backward state;
 
     val state1 = state |> Proof.refine_insert [];
     val {context = ctxt, facts = facts, goal = st} = Proof.raw_goal state1;
 
     val result_binding = apsnd (map (prep_atts ctxt)) raw_result_binding;
     val (prems_binding, do_prems) =
       (case raw_prems_binding of
         SOME (b, raw_atts) => ((b, map (prep_atts ctxt) raw_atts), true)
       | NONE => (Binding.empty_atts, false));
 
     val (subgoal_focus, _) =
       (if do_prems then focus else focus_params_fixed) ctxt
         1 (SOME (param_bindings ctxt param_specs st)) st;
 
     fun after_qed (ctxt'', [[result]]) =
       Proof.end_block #> (fn state' =>
         let
           val ctxt' = Proof.context_of state';
           val results' =
             Proof_Context.export ctxt'' ctxt' (Conjunction.elim_conjunctions result);
         in
           state'
           |> Proof.refine_primitive (fn _ => fn _ =>
             retrofit ctxt'' ctxt' (#params subgoal_focus) (#asms subgoal_focus) 1
               (Goal.protect 0 result) st
             |> Seq.hd)
           |> Proof.map_context
             (#2 o Proof_Context.note_thmss "" [(result_binding, [(results', [])])])
         end)
       #> Proof.reset_facts
       #> Proof.enter_backward;
   in
     state1
     |> Proof.enter_forward
     |> Proof.using_facts []
     |> Proof.begin_block
     |> Proof.map_context (fn _ =>
       #context subgoal_focus
       |> Proof_Context.note_thmss "" [(prems_binding, [(#prems subgoal_focus, [])])] |> #2)
     |> Proof.internal_goal (K (K ())) (Proof_Context.get_mode ctxt) true "subgoal"
         NONE after_qed [] [] [(Binding.empty_atts, [(Thm.term_of (#concl subgoal_focus), [])])] |> #2
     |> Proof.using_facts facts
     |> pair subgoal_focus
   end;
 
 in
 
 val subgoal = gen_subgoal Attrib.attribute;
 val subgoal_cmd = gen_subgoal Attrib.attribute_cmd;
 
 end;
 
 end;
 
 val SUBPROOF = Subgoal.SUBPROOF;
diff --git a/src/Pure/PIDE/document.ML b/src/Pure/PIDE/document.ML
--- a/src/Pure/PIDE/document.ML
+++ b/src/Pure/PIDE/document.ML
@@ -1,921 +1,921 @@
 (*  Title:      Pure/PIDE/document.ML
     Author:     Makarius
 
 Document as collection of named nodes, each consisting of an editable
 list of commands, associated with asynchronous execution process.
 *)
 
 signature DOCUMENT =
 sig
   val timing: bool Unsynchronized.ref
   type node_header = {master: string, header: Thy_Header.header, errors: string list}
   type overlay = Document_ID.command * (string * string list)
   datatype node_edit =
     Edits of (Document_ID.command option * Document_ID.command option) list |
     Deps of node_header |
     Perspective of bool * Document_ID.command list * overlay list
   type edit = string * node_edit
   type state
   val init_state: state
   val define_blob: string -> string -> state -> state
   type blob_digest = {file_node: string, src_path: Path.T, digest: string option} Exn.result
   type command =
    {command_id: Document_ID.command,
     name: string,
     parents: string list,
     blobs_digests: blob_digest list,
     blobs_index: int,
     tokens: ((int * int) * string) list}
   val define_command: command -> state -> state
   val command_exec: state -> string -> Document_ID.command -> Command.exec option
   val remove_versions: Document_ID.version list -> state -> state
   val start_execution: state -> state
   val update: Document_ID.version -> Document_ID.version -> edit list -> string list -> state ->
     string list * Document_ID.exec list * (Document_ID.command * Document_ID.exec list) list * state
   val state: unit -> state
   val change_state: (state -> state) -> unit
 end;
 
 structure Document: DOCUMENT =
 struct
 
 val timing = Unsynchronized.ref false;
 fun timeit msg e = cond_timeit (! timing) msg e;
 
 
 
 (** document structure **)
 
 fun err_dup kind id = error ("Duplicate " ^ kind ^ ": " ^ Document_ID.print id);
 fun err_undef kind id = error ("Undefined " ^ kind ^ ": " ^ Document_ID.print id);
 
 type node_header =
   {master: string, header: Thy_Header.header, errors: string list};
 
 type perspective =
  {required: bool,  (*required node*)
   visible: Inttab.set,  (*visible commands*)
   visible_last: Document_ID.command option,  (*last visible command*)
   overlays: (string * string list) list Inttab.table};  (*command id -> print functions with args*)
 
 structure Entries = Linear_Set(type key = Document_ID.command val ord = int_ord);
 
 abstype node = Node of
  {header: node_header,  (*master directory, theory header, errors*)
   keywords: Keyword.keywords option,  (*outer syntax keywords*)
   perspective: perspective,  (*command perspective*)
   entries: Command.exec option Entries.T,  (*command entries with executions*)
   result: (Document_ID.command * Command.eval) option,  (*result of last execution*)
   consolidated: unit lazy}  (*consolidated status of eval forks*)
 and version = Version of node String_Graph.T  (*development graph wrt. static imports*)
 with
 
 fun make_node (header, keywords, perspective, entries, result, consolidated) =
   Node {header = header, keywords = keywords, perspective = perspective,
     entries = entries, result = result, consolidated = consolidated};
 
 fun map_node f (Node {header, keywords, perspective, entries, result, consolidated}) =
   make_node (f (header, keywords, perspective, entries, result, consolidated));
 
 fun make_perspective (required, command_ids, overlays) : perspective =
  {required = required,
   visible = Inttab.make_set command_ids,
   visible_last = try List.last command_ids,
   overlays = Inttab.make_list overlays};
 
 val no_header: node_header =
   {master = "", header = Thy_Header.make ("", Position.none) [] [], errors = []};
 val no_perspective = make_perspective (false, [], []);
 
 val empty_node =
   make_node (no_header, NONE, no_perspective, Entries.empty, NONE, Lazy.value ());
 
 fun is_no_perspective ({required, visible, visible_last, overlays}: perspective) =
   not required andalso
   Inttab.is_empty visible andalso
   is_none visible_last andalso
   Inttab.is_empty overlays;
 
 fun is_empty_node (Node {header, keywords, perspective, entries, result, consolidated}) =
   header = no_header andalso
   is_none keywords andalso
   is_no_perspective perspective andalso
   Entries.is_empty entries andalso
   is_none result andalso
   Lazy.is_finished consolidated;
 
 
 (* basic components *)
 
 fun master_directory (Node {header = {master, ...}, ...}) =
   (case try Url.explode master of
     SOME (Url.File path) => path
   | _ => Path.current);
 
 fun set_header master header errors =
   map_node (fn (_, keywords, perspective, entries, result, consolidated) =>
     ({master = master, header = header, errors = errors},
       keywords, perspective, entries, result, consolidated));
 
 fun get_header (Node {header, ...}) = header;
 
 fun set_keywords keywords =
   map_node (fn (header, _, perspective, entries, result, consolidated) =>
     (header, keywords, perspective, entries, result, consolidated));
 
 fun get_keywords (Node {keywords, ...}) = keywords;
 
 fun read_header node span =
   let
     val {header, errors, ...} = get_header node;
     val _ =
       if null errors then ()
       else
         cat_lines errors |>
         (case Position.id_of (Position.thread_data ()) of
           NONE => I
         | SOME id => Protocol_Message.command_positions_yxml id)
         |> error;
     val {name = (name, _), imports, ...} = header;
     val {name = (_, pos), imports = imports', keywords} =
       Thy_Header.read_tokens Position.none span;
     val imports'' = (map #1 imports ~~ map #2 imports') handle ListPair.UnequalLengths => imports;
   in Thy_Header.make (name, pos) imports'' keywords end;
 
 fun get_perspective (Node {perspective, ...}) = perspective;
 
 fun set_perspective args =
   map_node (fn (header, keywords, _, entries, result, consolidated) =>
     (header, keywords, make_perspective args, entries, result, consolidated));
 
 val required_node = #required o get_perspective;
 val visible_command = Inttab.defined o #visible o get_perspective;
 val visible_last = #visible_last o get_perspective;
 val visible_node = is_some o visible_last
 val overlays = Inttab.lookup_list o #overlays o get_perspective;
 
 fun map_entries f =
   map_node (fn (header, keywords, perspective, entries, result, consolidated) =>
     (header, keywords, perspective, f entries, result, consolidated));
 
 fun get_entries (Node {entries, ...}) = entries;
 
 fun iterate_entries f = Entries.iterate NONE f o get_entries;
 fun iterate_entries_after start f (Node {entries, ...}) =
   (case Entries.get_after entries start of
     NONE => I
   | SOME id => Entries.iterate (SOME id) f entries);
 
 fun get_result (Node {result, ...}) = result;
 
 fun set_result result =
   map_node (fn (header, keywords, perspective, entries, _, consolidated) =>
     (header, keywords, perspective, entries, result, consolidated));
 
 fun pending_result node =
   (case get_result node of
     SOME (_, eval) => not (Command.eval_finished eval)
   | NONE => false);
 
 fun finished_result node =
   (case get_result node of
     SOME (_, eval) => Command.eval_finished eval
   | NONE => false);
 
 fun finished_result_theory node =
   if finished_result node then
     let
       val (result_id, eval) = the (get_result node);
       val st = Command.eval_result_state eval;
     in SOME (result_id, Toplevel.end_theory Position.none st) handle ERROR _ => NONE end
   else NONE;
 
 val reset_consolidated =
   map_node (fn (header, keywords, perspective, entries, result, _) =>
     (header, keywords, perspective, entries, result, Lazy.lazy I));
 
 fun commit_consolidated (Node {consolidated, ...}) =
   (Lazy.force consolidated; Output.status [Markup.markup_only Markup.consolidated]);
 
 fun consolidated_node (Node {consolidated, ...}) = Lazy.is_finished consolidated;
 
 fun could_consolidate node =
   not (consolidated_node node) andalso is_some (finished_result_theory node);
 
 fun get_node nodes name = String_Graph.get_node nodes name
   handle String_Graph.UNDEF _ => empty_node;
 fun default_node name = String_Graph.default_node (name, empty_node);
 fun update_node name f = default_node name #> String_Graph.map_node name f;
 
 
 (* node edits and associated executions *)
 
 type overlay = Document_ID.command * (string * string list);
 
 datatype node_edit =
   Edits of (Document_ID.command option * Document_ID.command option) list |
   Deps of node_header |
   Perspective of bool * Document_ID.command list * overlay list;
 
 type edit = string * node_edit;
 
 val after_entry = Entries.get_after o get_entries;
 
 fun lookup_entry node id =
   (case Entries.lookup (get_entries node) id of
     NONE => NONE
   | SOME (exec, _) => exec);
 
 fun the_entry node id =
   (case Entries.lookup (get_entries node) id of
     NONE => err_undef "command entry" id
   | SOME (exec, _) => exec);
 
 fun assign_entry (command_id, exec) node =
   if is_none (Entries.lookup (get_entries node) command_id) then node
   else map_entries (Entries.update (command_id, exec)) node;
 
 fun reset_after id entries =
   (case Entries.get_after entries id of
     NONE => entries
   | SOME next => Entries.update (next, NONE) entries);
 
 val edit_node = map_entries o fold
   (fn (id, SOME id2) => Entries.insert_after id (id2, NONE)
     | (id, NONE) => Entries.delete_after id #> reset_after id);
 
 
 (* version operations *)
 
 val empty_version = Version String_Graph.empty;
 
 fun nodes_of (Version nodes) = nodes;
 val node_of = get_node o nodes_of;
 
 fun cycle_msg names = "Cyclic dependency of " ^ space_implode " via " (map quote names);
 
 fun edit_nodes (name, node_edit) (Version nodes) =
   Version
     (case node_edit of
       Edits edits => update_node name (edit_node edits) nodes
     | Deps {master, header, errors} =>
         let
           val imports = map fst (#imports header);
           val nodes1 = nodes
             |> default_node name
             |> fold default_node imports;
           val nodes2 = nodes1
             |> String_Graph.Keys.fold
                 (fn dep => String_Graph.del_edge (dep, name)) (String_Graph.imm_preds nodes1 name);
           val (nodes3, errors1) =
             (String_Graph.add_deps_acyclic (name, imports) nodes2, errors)
               handle String_Graph.CYCLES cs => (nodes2, errors @ map cycle_msg cs);
         in String_Graph.map_node name (set_header master header errors1) nodes3 end
     | Perspective perspective => update_node name (set_perspective perspective) nodes);
 
 fun update_keywords name nodes =
   nodes |> String_Graph.map_node name (fn node =>
     if is_empty_node node then node
     else
       let
         val {master, header, errors} = get_header node;
         val imports_keywords = map_filter (get_keywords o get_node nodes o #1) (#imports header);
         val keywords =
           Library.foldl Keyword.merge_keywords (Session.get_keywords (), imports_keywords);
         val (keywords', errors') =
           (Keyword.add_keywords (#keywords header) keywords, errors)
             handle ERROR msg =>
               (keywords, if member (op =) errors msg then errors else errors @ [msg]);
       in
         node
         |> set_header master header errors'
         |> set_keywords (SOME keywords')
       end);
 
 fun edit_keywords edits (Version nodes) =
   Version
     (fold update_keywords
       (String_Graph.all_succs nodes (map_filter (fn (a, Deps _) => SOME a | _ => NONE) edits))
       nodes);
 
 fun suppressed_node (nodes: node String_Graph.T) (name, node) =
   String_Graph.is_maximal nodes name andalso is_empty_node node;
 
 fun put_node (name, node) (Version nodes) =
   let
     val nodes1 = update_node name (K node) nodes;
     val nodes2 =
       if suppressed_node nodes1 (name, node)
       then String_Graph.del_node name nodes1
       else nodes1;
   in Version nodes2 end;
 
 end;
 
 
 
 (** main state -- document structure and execution process **)
 
 type blob_digest = {file_node: string, src_path: Path.T, digest: string option} Exn.result;
 
 type execution =
  {version_id: Document_ID.version,  (*static version id*)
   execution_id: Document_ID.execution,  (*dynamic execution id*)
   delay_request: unit future,  (*pending event timer request*)
   parallel_prints: Command.exec list};  (*parallel prints for early execution*)
 
 val no_execution: execution =
   {version_id = Document_ID.none,
    execution_id = Document_ID.none,
    delay_request = Future.value (),
    parallel_prints = []};
 
 fun new_execution version_id delay_request parallel_prints : execution =
   {version_id = version_id,
    execution_id = Execution.start (),
    delay_request = delay_request,
    parallel_prints = parallel_prints};
 
 abstype state = State of
  {versions: version Inttab.table,  (*version id -> document content*)
   blobs: (SHA1.digest * string list) Symtab.table,  (*raw digest -> digest, lines*)
   commands: (string * blob_digest list * int * Token.T list lazy) Inttab.table,
     (*command id -> name, inlined files, token index of files, command span*)
   execution: execution}  (*current execution process*)
 with
 
 fun make_state (versions, blobs, commands, execution) =
   State {versions = versions, blobs = blobs, commands = commands, execution = execution};
 
 fun map_state f (State {versions, blobs, commands, execution}) =
   make_state (f (versions, blobs, commands, execution));
 
 val init_state =
   make_state (Inttab.make [(Document_ID.none, empty_version)],
     Symtab.empty, Inttab.empty, no_execution);
 
 
 (* document versions *)
 
 fun parallel_prints_node node =
   iterate_entries (fn (_, opt_exec) => fn rev_result =>
     (case opt_exec of
       SOME (eval, prints) =>
         (case filter Command.parallel_print prints of
           [] => SOME rev_result
         | prints' => SOME ((eval, prints') :: rev_result))
     | NONE => NONE)) node [] |> rev;
 
 fun define_version version_id version assigned_nodes =
   map_state (fn (versions, blobs, commands, {delay_request, ...}) =>
     let
       val version' = fold put_node assigned_nodes version;
       val versions' = Inttab.update_new (version_id, version') versions
         handle Inttab.DUP dup => err_dup "document version" dup;
       val parallel_prints = maps (parallel_prints_node o #2) assigned_nodes;
       val execution' = new_execution version_id delay_request parallel_prints;
     in (versions', blobs, commands, execution') end);
 
 fun the_version (State {versions, ...}) version_id =
   (case Inttab.lookup versions version_id of
     NONE => err_undef "document version" version_id
   | SOME version => version);
 
 fun delete_version version_id versions =
   Inttab.delete version_id versions
     handle Inttab.UNDEF _ => err_undef "document version" version_id;
 
 
 (* inlined files *)
 
 fun define_blob digest text =
   map_state (fn (versions, blobs, commands, execution) =>
     let val blobs' = Symtab.update (digest, (SHA1.fake digest, split_lines text)) blobs
     in (versions, blobs', commands, execution) end);
 
 fun the_blob (State {blobs, ...}) digest =
   (case Symtab.lookup blobs digest of
     NONE => error ("Undefined blob: " ^ digest)
   | SOME content => content);
 
 fun resolve_blob state (blob_digest: blob_digest) =
   blob_digest |> Exn.map_res (fn {file_node, src_path, digest} =>
     {file_node = file_node, src_path = src_path, content = Option.map (the_blob state) digest});
 
 fun blob_reports pos (blob_digest: blob_digest) =
   (case blob_digest of Exn.Res {file_node, ...} => [(pos, Markup.path file_node)] | _ => []);
 
 
 (* commands *)
 
 type command =
   {command_id: Document_ID.command,
    name: string,
    parents: string list,
    blobs_digests: blob_digest list,
    blobs_index: int,
    tokens: ((int * int) * string) list};
 
 fun define_command {command_id, name, parents, blobs_digests, blobs_index, tokens} =
   map_state (fn (versions, blobs, commands, execution) =>
     let
       val id = Document_ID.print command_id;
       val span =
         Lazy.lazy_name "Document.define_command" (fn () =>
           Position.setmp_thread_data (Position.id_only id)
             (fn () =>
               let
                 val (tokens, _) = fold_map Token.make tokens (Position.id id);
                 val imports =
                   if name = Thy_Header.theoryN then
                     (#imports (Thy_Header.read_tokens Position.none tokens)
                       handle ERROR _ => [])
                   else [];
                 val _ =
                   if length parents = length imports then
                     (parents, imports) |> ListPair.app (fn (parent, (_, pos)) =>
                       let val markup =
                         (case Thy_Info.lookup_theory parent of
                           SOME thy => Theory.get_markup thy
                         | NONE =>
                             (case try Url.explode parent of
                               NONE => Markup.path parent
                             | SOME (Url.File path) => Markup.path (Path.implode path)
                             | SOME _ => Markup.path parent))
                       in Position.report pos markup end)
                   else ();
                 val _ =
                   if blobs_index < 0
                   then (*inlined errors*)
                     map_filter Exn.get_exn blobs_digests
                     |> List.app (Output.error_message o Runtime.exn_message)
                   else (*auxiliary files*)
                     let val pos = Token.pos_of (nth tokens blobs_index)
                     in Position.reports (maps (blob_reports pos) blobs_digests) end;
               in tokens end) ());
       val commands' =
         Inttab.update_new (command_id, (name, blobs_digests, blobs_index, span)) commands
           handle Inttab.DUP dup => err_dup "command" dup;
     in (versions, blobs, commands', execution) end);
 
 fun the_command (State {commands, ...}) command_id =
   (case Inttab.lookup commands command_id of
     NONE => err_undef "command" command_id
   | SOME command => command);
 
 val the_command_name = #1 oo the_command;
 
 
 (* execution *)
 
 fun get_execution (State {execution, ...}) = execution;
 fun get_execution_version state = the_version state (#version_id (get_execution state));
 
 fun command_exec state node_name command_id =
   let
     val version = get_execution_version state;
     val node = get_node (nodes_of version) node_name;
   in the_entry node command_id end;
 
 end;
 
 
 (* remove_versions *)
 
 fun remove_versions version_ids state = state |> map_state (fn (versions, _, _, execution) =>
   let
     val _ =
       member (op =) version_ids (#version_id execution) andalso
         error ("Attempt to remove execution version " ^ Document_ID.print (#version_id execution));
 
     val versions' = fold delete_version version_ids versions;
     val commands' =
-      (versions', Inttab.empty) |->
+      Inttab.build (versions' |>
         Inttab.fold (fn (_, version) => nodes_of version |>
           String_Graph.fold (fn (_, (node, _)) => node |>
             iterate_entries (fn ((_, command_id), _) =>
-              SOME o Inttab.insert (K true) (command_id, the_command state command_id))));
+              SOME o Inttab.insert (K true) (command_id, the_command state command_id)))));
     val blobs' =
-      (commands', Symtab.empty) |->
+      Symtab.build (commands' |>
         Inttab.fold (fn (_, (_, blobs, _, _)) => blobs |>
-          fold (fn Exn.Res {digest = SOME b, ...} => Symtab.update (b, the_blob state b) | _ => I));
+          fold (fn Exn.Res {digest = SOME b, ...} => Symtab.update (b, the_blob state b) | _ => I)));
 
   in (versions', blobs', commands', execution) end);
 
 
 (* document execution *)
 
 fun make_required nodes =
   let
     fun all_preds P =
       String_Graph.fold (fn (a, (node, _)) => P node ? cons a) nodes []
       |> String_Graph.all_preds nodes
       |> Symtab.make_set;
 
     val all_visible = all_preds visible_node;
     val all_required = all_preds required_node;
   in
     Symtab.fold (fn (a, ()) =>
       exists (Symtab.defined all_visible) (String_Graph.immediate_succs nodes a) ?
         Symtab.update (a, ())) all_visible all_required
   end;
 
 fun start_execution state = state |> map_state (fn (versions, blobs, commands, execution) =>
   timeit "Document.start_execution" (fn () =>
     let
       val {version_id, execution_id, delay_request, parallel_prints} = execution;
 
       val delay = seconds (Options.default_real "editor_execution_delay");
 
       val _ = Future.cancel delay_request;
       val delay_request' = Event_Timer.future {physical = true} (Time.now () + delay);
       val delay = Future.task_of delay_request';
 
       val parallel_prints' = parallel_prints
         |> map_filter (Command.exec_parallel_prints execution_id [delay]);
 
       fun finished_import (name, (node, _)) =
         finished_result node orelse is_some (Thy_Info.lookup_theory name);
 
       val nodes = nodes_of (the_version state version_id);
       val required = make_required nodes;
       val _ =
         nodes |> String_Graph.schedule
           (fn deps => fn (name, node) =>
             if Symtab.defined required name orelse visible_node node orelse pending_result node then
               let
                 val future =
                   (singleton o Future.forks)
                    {name = "theory:" ^ name,
                     group = SOME (Future.new_group NONE),
                     deps = delay :: Execution.active_tasks name @ maps (the_list o #2 o #2) deps,
                     pri = 0, interrupts = false}
                   (fn () =>
                    (Execution.worker_task_active true name;
                     if forall finished_import deps then
                       iterate_entries (fn (_, opt_exec) => fn () =>
                         (case opt_exec of
                           SOME exec =>
                             if Execution.is_running execution_id
                             then SOME (Command.exec execution_id exec)
                             else NONE
                         | NONE => NONE)) node ()
                     else ();
                     Execution.worker_task_active false name)
                       handle exn =>
                        (Output.system_message (Runtime.exn_message exn);
                         Execution.worker_task_active false name;
                         Exn.reraise exn));
               in (node, SOME (Future.task_of future)) end
             else (node, NONE));
       val execution' =
         {version_id = version_id, execution_id = execution_id,
           delay_request = delay_request', parallel_prints = parallel_prints'};
     in (versions, blobs, commands, execution') end));
 
 
 
 (** document update **)
 
 (* exec state assignment *)
 
 type assign_update = Command.exec option Inttab.table;  (*command id -> exec*)
 
 val assign_update_empty: assign_update = Inttab.empty;
 fun assign_update_defined (tab: assign_update) command_id = Inttab.defined tab command_id;
 fun assign_update_change entry (tab: assign_update) = Inttab.update entry tab;
 fun assign_update_apply (tab: assign_update) node = Inttab.fold assign_entry tab node;
 
 fun assign_update_new upd (tab: assign_update) =
   Inttab.update_new upd tab
     handle Inttab.DUP dup => err_dup "exec state assignment" dup;
 
 fun assign_update_result (tab: assign_update) =
   Inttab.fold (fn (command_id, exec) => cons (command_id, Command.exec_ids exec)) tab [];
 
 
 (* update *)
 
 local
 
 fun init_theory deps node span =
   let
     val master_dir = master_directory node;
     val header = read_header node span;
     val imports = #imports header;
 
     fun maybe_eval_result eval = Command.eval_result_state eval
       handle Fail _ => Toplevel.init_toplevel ();
 
     fun maybe_end_theory pos st = SOME (Toplevel.end_theory pos st)
       handle ERROR msg => (Output.error_message msg; NONE);
 
     val parents_reports =
       imports |> map_filter (fn (import, pos) =>
         (case Thy_Info.lookup_theory import of
           NONE =>
             maybe_end_theory pos
               (case get_result (snd (the (AList.lookup (op =) deps import))) of
                 NONE => Toplevel.init_toplevel ()
               | SOME (_, eval) => maybe_eval_result eval)
             |> Option.map (fn thy => (thy, (pos, Theory.get_markup thy)))
         | SOME thy => SOME (thy, (Position.none, Markup.empty))));
 
     val parents =
       if null parents_reports then [Theory.get_pure ()] else map #1 parents_reports;
     val _ = List.app (fn (thy, r) => Context_Position.reports_global thy [r]) parents_reports;
 
     val thy = Resources.begin_theory master_dir header parents;
     val _ = Output.status [Markup.markup_only Markup.initialized];
   in thy end;
 
 fun check_root_theory node =
   let
     val master_dir = master_directory node;
     val header = #header (get_header node);
     val header_name = #1 (#name header);
     val parent =
       if header_name = Sessions.root_name then
         SOME (Thy_Info.get_theory Sessions.theory_name)
       else if member (op =) Thy_Header.ml_roots header_name then
         SOME (Thy_Info.get_theory Thy_Header.ml_bootstrapN)
       else NONE;
   in parent |> Option.map (fn thy => Resources.begin_theory master_dir header [thy]) end;
 
 fun check_theory full name node =
   is_some (Thy_Info.lookup_theory name) orelse
   null (#errors (get_header node)) andalso (not full orelse is_some (get_result node));
 
 fun last_common keywords state node_required node0 node =
   let
     fun update_flags prev (visible, initial) =
       let
         val visible' = visible andalso prev <> visible_last node;
         val initial' = initial andalso
           (case prev of
             NONE => true
           | SOME command_id => the_command_name state command_id <> Thy_Header.theoryN);
       in (visible', initial') end;
 
     fun get_common ((prev, command_id), opt_exec) (_, ok, flags, assign_update) =
       if ok then
         let
           val flags' as (visible', _) = update_flags prev flags;
           val ok' =
             (case (lookup_entry node0 command_id, opt_exec) of
               (SOME (eval0, _), SOME (eval, _)) =>
                 Command.eval_eq (eval0, eval) andalso
                   (visible' orelse node_required orelse Command.eval_running eval)
             | _ => false);
           val assign_update' = assign_update |> ok' ?
             (case opt_exec of
               SOME (eval, prints) =>
                 let
                   val command_visible = visible_command node command_id;
                   val command_overlays = overlays node command_id;
                   val command_name = the_command_name state command_id;
                 in
                   (case
                     Command.print command_visible command_overlays keywords command_name eval prints
                    of
                     SOME prints' => assign_update_new (command_id, SOME (eval, prints'))
                   | NONE => I)
                 end
             | NONE => I);
         in SOME (prev, ok', flags', assign_update') end
       else NONE;
     val (common, ok, flags, assign_update') =
       iterate_entries get_common node (NONE, true, (true, true), assign_update_empty);
     val (common', flags') =
       if ok then
         let val last = Entries.get_after (get_entries node) common
         in (last, update_flags last flags) end
       else (common, flags);
   in (assign_update', common', flags') end;
 
 fun illegal_init _ = error "Illegal theory header";
 
 fun new_exec keywords state node proper_init command_id' (assign_update, command_exec, init) =
   if not proper_init andalso is_none init then NONE
   else
     let
       val command_visible = visible_command node command_id';
       val command_overlays = overlays node command_id';
       val (command_name, blob_digests, blobs_index, span0) = the_command state command_id';
       val blobs = map (resolve_blob state) blob_digests;
       val span = Lazy.force span0;
 
       val eval' =
         Command.eval keywords (master_directory node) (fn () => the_default illegal_init init span)
           (blobs, blobs_index) command_id' span (#1 (#2 command_exec));
       val prints' =
         perhaps (Command.print command_visible command_overlays keywords command_name eval') [];
       val exec' = (eval', prints');
 
       val assign_update' = assign_update_new (command_id', SOME exec') assign_update;
       val init' = if command_name = Thy_Header.theoryN then NONE else init;
     in SOME (assign_update', (command_id', exec'), init') end;
 
 fun removed_execs node0 (command_id, exec_ids) =
   subtract (op =) exec_ids (Command.exec_ids (lookup_entry node0 command_id));
 
 fun print_consolidation options the_command_span node_name (assign_update, node) =
   (case finished_result_theory node of
     SOME (result_id, thy) =>
       let
         val active_tasks =
           (node, false) |-> iterate_entries (fn (_, opt_exec) => fn active =>
             if active then NONE
             else
               (case opt_exec of
                 NONE => NONE
               | SOME (eval, _) =>
                   SOME (not (null (Execution.snapshot [Command.eval_exec_id eval])))));
       in
         if not active_tasks then
           let
             val consolidation =
               if Options.bool options "editor_presentation" then
                 let
                   val (_, offsets, rev_segments) =
                     iterate_entries (fn ((prev, _), opt_exec) => fn (offset, offsets, segments) =>
                       (case opt_exec of
                         SOME (eval, _) =>
                           let
                             val command_id = Command.eval_command_id eval;
                             val span = the_command_span command_id;
 
                             val st =
                               (case try (#1 o the o the_entry node o the) prev of
                                 NONE => Toplevel.init_toplevel ()
                               | SOME prev_eval => Command.eval_result_state prev_eval);
 
                             val exec_id = Command.eval_exec_id eval;
                             val tr = Command.eval_result_command eval;
                             val st' = Command.eval_result_state eval;
 
                             val offset' = offset + the_default 0 (Command_Span.symbol_length span);
                             val offsets' = offsets
                               |> Inttab.update (command_id, offset)
                               |> Inttab.update (exec_id, offset);
                             val segments' = (span, (st, tr, st')) :: segments;
                           in SOME (offset', offsets', segments') end
                       | NONE => NONE)) node (0, Inttab.empty, []);
 
                   val adjust = Inttab.lookup offsets;
                   val segments =
                     rev rev_segments |> map (fn (span, (st, tr, st')) =>
                       {span = Command_Span.adjust_offsets adjust span,
                        prev_state = st, command = tr, state = st'});
 
                   val presentation_context: Thy_Info.presentation_context =
                    {options = options,
                     file_pos = Position.file node_name,
                     adjust_pos = Position.adjust_offsets adjust,
                     segments = segments};
                 in
                   fn _ =>
                     let
                       val _ = Output.status [Markup.markup_only Markup.consolidating];
                       val res = Exn.capture (Thy_Info.apply_presentation presentation_context) thy;
                       val _ = commit_consolidated node;
                     in Exn.release res end
                 end
               else fn _ => commit_consolidated node;
 
             val result_entry =
               (case lookup_entry node result_id of
                 NONE => err_undef "result command entry" result_id
               | SOME (eval, prints) =>
                   let
                     val print = eval |> Command.print0
                       {pri = Task_Queue.urgent_pri + 1, print_fn = K consolidation};
                   in (result_id, SOME (eval, print :: prints)) end);
 
             val assign_update' = assign_update |> assign_update_change result_entry;
             val node' = node |> assign_entry result_entry;
           in (assign_update', node') end
         else (assign_update, node)
       end
   | NONE => (assign_update, node));
 in
 
 fun update old_version_id new_version_id edits consolidate state =
   Runtime.exn_trace_system (fn () =>
   let
     val options = Options.default ();
     val the_command_span = Outer_Syntax.make_span o Lazy.force o #4 o the_command state;
 
     val old_version = the_version state old_version_id;
     val new_version =
       timeit "Document.edit_nodes"
         (fn () => old_version |> fold edit_nodes edits |> edit_keywords edits);
 
     val consolidate = Symtab.defined (Symtab.make_set consolidate);
     val nodes = nodes_of new_version;
     val required = make_required nodes;
     val required0 = make_required (nodes_of old_version);
-    val edited = fold (fn (name, _) => Symtab.update (name, ())) edits Symtab.empty;
+    val edited = Symtab.build (edits |> fold (fn (name, _) => Symtab.update (name, ())));
 
     val updated = timeit "Document.update" (fn () =>
       nodes |> String_Graph.schedule
         (fn deps => fn (name, node) =>
           (singleton o Future.forks)
             {name = "Document.update", group = NONE,
               deps = map (Future.task_of o #2) deps, pri = 1, interrupts = false}
             (fn () =>
               timeit ("Document.update " ^ name) (fn () =>
                 Runtime.exn_trace_system (fn () =>
                   let
                     val root_theory = check_root_theory node;
                     val keywords = the_default (Session.get_keywords ()) (get_keywords node);
 
                     val maybe_consolidate = consolidate name andalso could_consolidate node;
                     val imports = map (apsnd Future.join) deps;
                     val imports_result_changed = exists (#4 o #1 o #2) imports;
                     val node_required = Symtab.defined required name;
                   in
                     if Symtab.defined edited name orelse maybe_consolidate orelse
                       visible_node node orelse imports_result_changed orelse
                       Symtab.defined required0 name <> node_required
                     then
                       let
                         val node0 = node_of old_version name;
                         val init = init_theory imports node;
                         val proper_init =
                           is_some root_theory orelse
                             check_theory false name node andalso
                             forall (fn (name, (_, node)) => check_theory true name node) imports;
 
                         val (print_execs, common, (still_visible, initial)) =
                           if imports_result_changed
                           then (assign_update_empty, NONE, (true, true))
                           else last_common keywords state node_required node0 node;
 
                         val common_command_exec =
                           (case common of
                             SOME id => (id, the_default Command.no_exec (the_entry node id))
                           | NONE => (Document_ID.none, Command.init_exec root_theory));
 
                         val (updated_execs, (command_id', exec'), _) =
                           (print_execs, common_command_exec, if initial then SOME init else NONE)
                           |> (still_visible orelse node_required) ?
                             iterate_entries_after common
                               (fn ((prev, id), _) => fn res =>
                                 if not node_required andalso prev = visible_last node then NONE
                                 else new_exec keywords state node proper_init id res) node;
 
                         val assign_update =
                           (node0, updated_execs) |-> iterate_entries_after common
                             (fn ((_, command_id0), exec0) => fn res =>
                               if is_none exec0 then NONE
                               else if assign_update_defined updated_execs command_id0 then SOME res
                               else SOME (assign_update_new (command_id0, NONE) res));
 
                         val last_exec =
                           if command_id' = Document_ID.none then NONE else SOME command_id';
                         val result =
                           if is_none last_exec orelse is_some (after_entry node last_exec) then NONE
                           else SOME (command_id', #1 exec');
 
                         val result_changed =
                           not (eq_option (Command.eval_eq o apply2 #2) (get_result node0, result));
                         val (assign_update', node') = node
                           |> assign_update_apply assign_update
                           |> set_result result
                           |> result_changed ? reset_consolidated
                           |> pair assign_update
                           |> (not result_changed andalso maybe_consolidate) ?
                               print_consolidation options the_command_span name;
 
                         val assign_result = assign_update_result assign_update';
                         val removed = maps (removed_execs node0) assign_result;
                         val _ = List.app Execution.cancel removed;
 
                         val assigned_node = SOME (name, node');
                       in ((removed, assign_result, assigned_node, result_changed), node') end
                     else (([], [], NONE, false), node)
                   end))))
       |> Future.joins |> map #1);
 
     val removed = maps #1 updated;
     val assign_result = maps #2 updated;
     val assigned_nodes = map_filter #3 updated;
 
     val state' = state
       |> define_version new_version_id new_version assigned_nodes;
 
   in (Symtab.keys edited, removed, assign_result, state') end);
 
 end;
 
 
 
 (** global state **)
 
 val global_state = Synchronized.var "Document.global_state" init_state;
 
 fun state () = Synchronized.value global_state;
 val change_state = Synchronized.change global_state;
 
 end;
diff --git a/src/Pure/PIDE/resources.ML b/src/Pure/PIDE/resources.ML
--- a/src/Pure/PIDE/resources.ML
+++ b/src/Pure/PIDE/resources.ML
@@ -1,441 +1,441 @@
 (*  Title:      Pure/PIDE/resources.ML
     Author:     Makarius
 
 Resources for theories and auxiliary files.
 *)
 
 signature RESOURCES =
 sig
   val default_qualifier: string
   val init_session:
     {session_positions: (string * Properties.T) list,
      session_directories: (string * string) list,
      session_chapters: (string * string) list,
      bibtex_entries: (string * string list) list,
      command_timings: Properties.T list,
      scala_functions: (string * (bool * Position.T)) list,
      global_theories: (string * string) list,
      loaded_theories: string list} -> unit
   val init_session_yxml: string -> unit
   val init_session_file: Path.T -> unit
   val finish_session_base: unit -> unit
   val global_theory: string -> string option
   val loaded_theory: string -> bool
   val check_session: Proof.context -> string * Position.T -> string
   val session_chapter: string -> string
   val last_timing: Toplevel.transition -> Time.time
   val scala_functions: unit -> string list
   val check_scala_function: Proof.context -> string * Position.T -> string * bool
   val master_directory: theory -> Path.T
   val imports_of: theory -> (string * Position.T) list
   val begin_theory: Path.T -> Thy_Header.header -> theory list -> theory
   val thy_path: Path.T -> Path.T
   val theory_qualifier: string -> string
   val theory_bibtex_entries: string -> string list
   val find_theory_file: string -> Path.T option
   val import_name: string -> Path.T -> string ->
     {node_name: Path.T, master_dir: Path.T, theory_name: string}
   val check_thy: Path.T -> string ->
    {master: Path.T * SHA1.digest, text: string, theory_pos: Position.T,
     imports: (string * Position.T) list, keywords: Thy_Header.keywords}
   val parse_files: (Path.T -> Path.T list) -> (theory -> Token.file list) parser
   val parse_file: (theory -> Token.file) parser
   val provide: Path.T * SHA1.digest -> theory -> theory
   val provide_file: Token.file -> theory -> theory
   val provide_parse_files: (Path.T -> Path.T list) -> (theory -> Token.file list * theory) parser
   val provide_parse_file: (theory -> Token.file * theory) parser
   val loaded_files_current: theory -> bool
   val check_path: Proof.context -> Path.T option -> Input.source -> Path.T
   val check_file: Proof.context -> Path.T option -> Input.source -> Path.T
   val check_dir: Proof.context -> Path.T option -> Input.source -> Path.T
   val check_session_dir: Proof.context -> Path.T option -> Input.source -> Path.T
 end;
 
 structure Resources: RESOURCES =
 struct
 
 (* command timings *)
 
 type timings = ((string * Time.time) Inttab.table) Symtab.table;  (*file -> offset -> name, time*)
 
 val empty_timings: timings = Symtab.empty;
 
 fun update_timings props =
   (case Markup.parse_command_timing_properties props of
     SOME ({file, offset, name}, time) =>
       Symtab.map_default (file, Inttab.empty)
         (Inttab.map_default (offset, (name, time)) (fn (_, t) => (name, t + time)))
   | NONE => I);
 
 fun make_timings command_timings =
   fold update_timings command_timings empty_timings;
 
 fun approximative_id name pos =
   (case (Position.file_of pos, Position.offset_of pos) of
     (SOME file, SOME offset) =>
       if name = "" then NONE else SOME {file = file, offset = offset, name = name}
   | _ => NONE);
 
 fun get_timings timings tr =
   (case approximative_id (Toplevel.name_of tr) (Toplevel.pos_of tr) of
     SOME {file, offset, name} =>
       (case Symtab.lookup timings file of
         SOME offsets =>
           (case Inttab.lookup offsets offset of
             SOME (name', time) => if name = name' then SOME time else NONE
           | NONE => NONE)
       | NONE => NONE)
   | NONE => NONE)
   |> the_default Time.zeroTime;
 
 
 (* session base *)
 
 val default_qualifier = "Draft";
 
 type entry = {pos: Position.T, serial: serial};
 
 fun make_entry props : entry =
   {pos = Position.of_properties props, serial = serial ()};
 
 val empty_session_base =
   ({session_positions = []: (string * entry) list,
     session_directories = Symtab.empty: Path.T list Symtab.table,
     session_chapters = Symtab.empty: string Symtab.table,
     bibtex_entries = Symtab.empty: string list Symtab.table,
     timings = empty_timings,
     scala_functions = Symtab.empty: (bool * Position.T) Symtab.table},
    {global_theories = Symtab.empty: string Symtab.table,
     loaded_theories = Symtab.empty: unit Symtab.table});
 
 val global_session_base =
   Synchronized.var "Sessions.base" empty_session_base;
 
 fun init_session
     {session_positions, session_directories, session_chapters, bibtex_entries,
       command_timings, scala_functions, global_theories, loaded_theories} =
   Synchronized.change global_session_base
     (fn _ =>
       ({session_positions = sort_by #1 (map (apsnd make_entry) session_positions),
         session_directories =
-          fold_rev (fn (dir, name) => Symtab.cons_list (name, Path.explode dir))
-            session_directories Symtab.empty,
+          Symtab.build (session_directories |> fold_rev (fn (dir, name) =>
+            Symtab.cons_list (name, Path.explode dir))),
         session_chapters = Symtab.make session_chapters,
         bibtex_entries = Symtab.make bibtex_entries,
         timings = make_timings command_timings,
         scala_functions = Symtab.make scala_functions},
        {global_theories = Symtab.make global_theories,
         loaded_theories = Symtab.make_set loaded_theories}));
 
 fun init_session_yxml yxml =
   let
     val (session_positions, (session_directories, (session_chapters, (bibtex_entries,
         (command_timings, (scala_functions, (global_theories, loaded_theories))))))) =
       YXML.parse_body yxml |>
         let open XML.Decode in
           (pair (list (pair string properties))
             (pair (list (pair string string)) (pair (list (pair string string))
               (pair (list (pair string (list string))) (pair (list properties)
                 (pair (list (pair string (pair bool properties)))
                   (pair (list (pair string string)) (list string))))))))
         end;
   in
     init_session
       {session_positions = session_positions,
        session_directories = session_directories,
        session_chapters = session_chapters,
        bibtex_entries = bibtex_entries,
        command_timings = command_timings,
        scala_functions = (map o apsnd o apsnd) Position.of_properties scala_functions,
        global_theories = global_theories,
        loaded_theories = loaded_theories}
   end;
 
 fun init_session_file path =
   init_session_yxml (File.read path) before File.rm path;
 
 fun finish_session_base () =
   Synchronized.change global_session_base
     (apfst (K (#1 empty_session_base)));
 
 fun get_session_base f = f (Synchronized.value global_session_base);
 fun get_session_base1 f = get_session_base (f o #1);
 fun get_session_base2 f = get_session_base (f o #2);
 
 fun global_theory a = Symtab.lookup (get_session_base2 #global_theories) a;
 fun loaded_theory a = Symtab.defined (get_session_base2 #loaded_theories) a;
 
 fun check_session ctxt arg =
   Completion.check_item "session"
     (fn (name, {pos, serial}) =>
       Position.make_entity_markup false serial Markup.sessionN (name, pos))
     (get_session_base1 #session_positions) ctxt arg;
 
 fun session_chapter name =
   the_default "Unsorted" (Symtab.lookup (get_session_base1 #session_chapters) name);
 
 fun last_timing tr = get_timings (get_session_base1 #timings) tr;
 
 
 (* Scala functions *)
 
 (*raw bootstrap environment*)
 fun scala_functions () = space_explode "," (getenv "ISABELLE_SCALA_FUNCTIONS");
 
 (*regular resources*)
 fun scala_function a =
   (a, the_default (false, Position.none) (Symtab.lookup (get_session_base1 #scala_functions) a));
 
 fun check_scala_function ctxt arg =
   let
     val funs = scala_functions () |> sort_strings |> map scala_function;
     val name = Completion.check_entity Markup.scala_functionN (map (apsnd #2) funs) ctxt arg;
     val multi =
       (case AList.lookup (op =) funs name of
         SOME (multi, _) => multi
       | NONE => false);
   in (name, multi) end;
 
 val _ = Theory.setup
  (Document_Output.antiquotation_verbatim_embedded \<^binding>\<open>scala_function\<close>
     (Scan.lift Parse.embedded_position) (#1 oo check_scala_function) #>
   ML_Antiquotation.inline_embedded \<^binding>\<open>scala_function\<close>
     (Args.context -- Scan.lift Parse.embedded_position
       >> (uncurry check_scala_function #> #1 #> ML_Syntax.print_string)) #>
   ML_Antiquotation.value_embedded \<^binding>\<open>scala\<close>
     (Args.context -- Scan.lift Args.embedded_position >> (fn (ctxt, arg) =>
       let
         val (name, multi) = check_scala_function ctxt arg;
         val func = if multi then "Scala.function" else "Scala.function1";
       in ML_Syntax.atomic (func ^ " " ^ ML_Syntax.print_string name) end)));
 
 
 (* manage source files *)
 
 type files =
  {master_dir: Path.T,  (*master directory of theory source*)
   imports: (string * Position.T) list,  (*source specification of imports*)
   provided: (Path.T * SHA1.digest) list};  (*source path, digest*)
 
 fun make_files (master_dir, imports, provided): files =
  {master_dir = master_dir, imports = imports, provided = provided};
 
 structure Files = Theory_Data
 (
   type T = files;
   val empty = make_files (Path.current, [], []);
   val extend = I;
   fun merge ({master_dir, imports, provided = provided1}, {provided = provided2, ...}) =
     let val provided' = Library.merge (op =) (provided1, provided2)
     in make_files (master_dir, imports, provided') end
 );
 
 fun map_files f =
   Files.map (fn {master_dir, imports, provided} =>
     make_files (f (master_dir, imports, provided)));
 
 
 val master_directory = #master_dir o Files.get;
 val imports_of = #imports o Files.get;
 
 fun begin_theory master_dir {name, imports, keywords} parents =
   Theory.begin_theory name parents
   |> map_files (fn _ => (Path.explode (Path.implode_symbolic master_dir), imports, []))
   |> Thy_Header.add_keywords keywords;
 
 
 (* theory files *)
 
 val thy_path = Path.ext "thy";
 
 fun theory_qualifier theory =
   (case global_theory theory of
     SOME qualifier => qualifier
   | NONE => Long_Name.qualifier theory);
 
 fun theory_name qualifier theory =
   if Long_Name.is_qualified theory orelse is_some (global_theory theory)
   then theory
   else Long_Name.qualify qualifier theory;
 
 fun theory_bibtex_entries theory =
   Symtab.lookup_list (get_session_base1 #bibtex_entries) (theory_qualifier theory);
 
 fun find_theory_file thy_name =
   let
     val thy_file = thy_path (Path.basic (Long_Name.base_name thy_name));
     val session = theory_qualifier thy_name;
     val dirs = Symtab.lookup_list (get_session_base1 #session_directories) session;
   in
     dirs |> get_first (fn dir =>
       let val path = dir + thy_file
       in if File.is_file path then SOME path else NONE end)
   end;
 
 fun make_theory_node node_name theory =
   {node_name = node_name, master_dir = Path.dir node_name, theory_name = theory};
 
 fun loaded_theory_node theory =
   {node_name = Path.basic theory, master_dir = Path.current, theory_name = theory};
 
 fun import_name qualifier dir s =
   let
     val theory = theory_name qualifier (Thy_Header.import_name s);
     fun theory_node () =
       make_theory_node (File.full_path dir (thy_path (Path.expand (Path.explode s)))) theory;
   in
     if not (Thy_Header.is_base_name s) then theory_node ()
     else if loaded_theory theory then loaded_theory_node theory
     else
       (case find_theory_file theory of
         SOME node_name => make_theory_node node_name theory
       | NONE => if Long_Name.is_qualified s then loaded_theory_node theory else theory_node ())
   end;
 
 fun check_file dir file = File.check_file (File.full_path dir file);
 
 fun check_thy dir thy_name =
   let
     val thy_base_name = Long_Name.base_name thy_name;
     val master_file =
       (case find_theory_file thy_name of
         SOME path => check_file Path.current path
       | NONE => check_file dir (thy_path (Path.basic thy_base_name)));
     val text = File.read master_file;
 
     val {name = (name, pos), imports, keywords} =
       Thy_Header.read (Path.position master_file) text;
     val _ =
       thy_base_name <> name andalso
         error ("Bad theory name " ^ quote name ^
           " for file " ^ Path.print (Path.base master_file) ^ Position.here pos);
   in
    {master = (master_file, SHA1.digest text), text = text, theory_pos = pos,
     imports = imports, keywords = keywords}
   end;
 
 
 (* load files *)
 
 fun parse_files make_paths =
   Scan.ahead Parse.not_eof -- Parse.path_input >> (fn (tok, source) => fn thy =>
     (case Token.get_files tok of
       [] =>
         let
           val master_dir = master_directory thy;
           val name = Input.string_of source;
           val pos = Input.pos_of source;
           val delimited = Input.is_delimited source;
           val src_paths = make_paths (Path.explode name);
         in map (Command.read_file master_dir pos delimited) src_paths end
     | files => map Exn.release files));
 
 val parse_file = parse_files single >> (fn f => f #> the_single);
 
 
 fun provide (src_path, id) =
   map_files (fn (master_dir, imports, provided) =>
     if AList.defined (op =) provided src_path then
       error ("Duplicate use of source file: " ^ Path.print src_path)
     else (master_dir, imports, (src_path, id) :: provided));
 
 fun provide_file (file: Token.file) = provide (#src_path file, #digest file);
 
 fun provide_parse_files make_paths =
   parse_files make_paths >> (fn files => fn thy =>
     let
       val fs = files thy;
       val thy' = fold (fn {src_path, digest, ...} => provide (src_path, digest)) fs thy;
     in (fs, thy') end);
 
 val provide_parse_file = provide_parse_files single >> (fn f => f #>> the_single);
 
 
 fun load_file thy src_path =
   let
     val full_path = check_file (master_directory thy) src_path;
     val text = File.read full_path;
     val id = SHA1.digest text;
   in ((full_path, id), text) end;
 
 fun loaded_files_current thy =
   #provided (Files.get thy) |>
     forall (fn (src_path, id) =>
       (case try (load_file thy) src_path of
         NONE => false
       | SOME ((_, id'), _) => id = id'));
 
 
 (* formal check *)
 
 fun formal_check check_file ctxt opt_dir source =
   let
     val name = Input.string_of source;
     val pos = Input.pos_of source;
     val delimited = Input.is_delimited source;
 
     val _ = Context_Position.report ctxt pos (Markup.language_path delimited);
 
     fun err msg = error (msg ^ Position.here pos);
     val dir =
       (case opt_dir of
         SOME dir => dir
       | NONE => master_directory (Proof_Context.theory_of ctxt));
     val path = dir + Path.explode name handle ERROR msg => err msg;
     val _ = Path.expand path handle ERROR msg => err msg;
     val _ = Context_Position.report ctxt pos (Markup.path (Path.implode_symbolic path));
     val _ : Path.T = check_file path handle ERROR msg => err msg;
   in path end;
 
 val check_path = formal_check I;
 val check_file = formal_check File.check_file;
 val check_dir = formal_check File.check_dir;
 
 fun check_session_dir ctxt opt_dir s =
   let
     val dir = Path.expand (check_dir ctxt opt_dir s);
     val ok =
       File.is_file (dir + Path.explode("ROOT")) orelse
       File.is_file (dir + Path.explode("ROOTS"));
   in
     if ok then dir
     else
       error ("Bad session root directory (missing ROOT or ROOTS): " ^
         Path.print dir ^ Position.here (Input.pos_of s))
   end;
 
 
 (* antiquotations *)
 
 local
 
 fun document_antiq (check: Proof.context -> Path.T option -> Input.source -> Path.T) =
   Args.context -- Scan.lift Parse.path_input >> (fn (ctxt, source) =>
    (check ctxt NONE source;
     Latex.string (Latex.output_ascii_breakable "/" (Input.string_of source))
     |> Latex.enclose_text "\\isatt{" "}"));
 
 fun ML_antiq check =
   Args.context -- Scan.lift Parse.path_input >> (fn (ctxt, source) =>
     check ctxt (SOME Path.current) source |> ML_Syntax.print_path);
 
 in
 
 val _ = Theory.setup
  (Document_Output.antiquotation_verbatim_embedded \<^binding>\<open>session\<close>
     (Scan.lift Parse.embedded_position) check_session #>
   Document_Output.antiquotation_raw_embedded \<^binding>\<open>path\<close> (document_antiq check_path) (K I) #>
   Document_Output.antiquotation_raw_embedded \<^binding>\<open>file\<close> (document_antiq check_file) (K I) #>
   Document_Output.antiquotation_raw_embedded \<^binding>\<open>dir\<close> (document_antiq check_dir) (K I) #>
   ML_Antiquotation.value_embedded \<^binding>\<open>path\<close> (ML_antiq check_path) #>
   ML_Antiquotation.value_embedded \<^binding>\<open>file\<close> (ML_antiq check_file) #>
   ML_Antiquotation.value_embedded \<^binding>\<open>dir\<close> (ML_antiq check_dir) #>
   ML_Antiquotation.value_embedded \<^binding>\<open>path_binding\<close>
     (Scan.lift (Parse.position Parse.path) >>
       (ML_Syntax.print_path_binding o Path.explode_binding)) #>
   ML_Antiquotation.value \<^binding>\<open>master_dir\<close>
     (Args.theory >> (ML_Syntax.print_path o master_directory)));
 
 end;
 
 end;
diff --git a/src/Pure/Proof/proof_checker.ML b/src/Pure/Proof/proof_checker.ML
--- a/src/Pure/Proof/proof_checker.ML
+++ b/src/Pure/Proof/proof_checker.ML
@@ -1,152 +1,152 @@
 (*  Title:      Pure/Proof/proof_checker.ML
     Author:     Stefan Berghofer, TU Muenchen
 
 Simple proof checker based only on the core inference rules
 of Isabelle/Pure.
 *)
 
 signature PROOF_CHECKER =
 sig
   val thm_of_proof : theory -> Proofterm.proof -> thm
 end;
 
 structure Proof_Checker : PROOF_CHECKER =
 struct
 
 (***** construct a theorem out of a proof term *****)
 
 fun lookup_thm thy =
-  let val tab = fold_rev Symtab.update (Global_Theory.all_thms_of thy true) Symtab.empty in
+  let val tab = Symtab.build (Global_Theory.all_thms_of thy true |> fold_rev Symtab.update) in
     fn s =>
       (case Symtab.lookup tab s of
         NONE => error ("Unknown theorem " ^ quote s)
       | SOME thm => thm)
   end;
 
 val beta_eta_convert =
   Conv.fconv_rule Drule.beta_eta_conversion;
 
 (* equality modulo renaming of type variables *)
 fun is_equal t t' =
   let
     val atoms = fold_types (fold_atyps (insert (op =))) t [];
     val atoms' = fold_types (fold_atyps (insert (op =))) t' []
   in
     length atoms = length atoms' andalso
     map_types (map_atyps (the o AList.lookup (op =) (atoms ~~ atoms'))) t aconv t'
   end;
 
 fun pretty_prf thy vs Hs prf =
   let val prf' = prf |> Proofterm.prf_subst_bounds (map Free vs) |>
     Proofterm.prf_subst_pbounds (map (Hyp o Thm.prop_of) Hs)
   in
     (Proof_Syntax.pretty_proof (Syntax.init_pretty_global thy) prf',
      Syntax.pretty_term_global thy (Proofterm.prop_of prf'))
   end;
 
 fun pretty_term thy vs _ t =
   let val t' = subst_bounds (map Free vs, t)
   in
     (Syntax.pretty_term_global thy t',
      Syntax.pretty_typ_global thy (fastype_of t'))
   end;
 
 fun appl_error thy prt vs Hs s f a =
   let
     val (pp_f, pp_fT) = pretty_prf thy vs Hs f;
     val (pp_a, pp_aT) = prt thy vs Hs a
   in
     error (cat_lines
       [s,
        "",
        Pretty.string_of (Pretty.block
          [Pretty.str "Operator:", Pretty.brk 2, pp_f,
            Pretty.str " ::", Pretty.brk 1, pp_fT]),
        Pretty.string_of (Pretty.block
          [Pretty.str "Operand:", Pretty.brk 3, pp_a,
            Pretty.str " ::", Pretty.brk 1, pp_aT]),
        ""])
   end;
 
 fun thm_of_proof thy =
   let val lookup = lookup_thm thy in
     fn prf =>
       let
         val prf_names = Proofterm.fold_proof_terms Term.declare_term_frees prf Name.context;
 
         fun thm_of_atom thm Ts =
           let
             val tvars = rev (Term.add_tvars (Thm.full_prop_of thm) []);
             val (fmap, thm') = Thm.varifyT_global' [] thm;
             val ctye =
               (tvars @ map (fn ((_, S), ixn) => (ixn, S)) fmap ~~ map (Thm.global_ctyp_of thy) Ts);
           in
             Thm.instantiate (ctye, []) (forall_intr_vars (Thm.forall_intr_frees thm'))
           end;
 
         fun thm_of _ _ (PThm ({name, prop = prop', types = SOME Ts, ...}, _)) =
               let
                 val thm = Thm.unconstrainT (Drule.implies_intr_hyps (lookup name));
                 val prop = Thm.prop_of thm;
                 val _ =
                   if is_equal prop prop' then ()
                   else
                     error ("Duplicate use of theorem name " ^ quote name ^ "\n" ^
                       Syntax.string_of_term_global thy prop ^ "\n\n" ^
                       Syntax.string_of_term_global thy prop');
               in thm_of_atom thm Ts end
 
           | thm_of _ _ (PAxm (name, _, SOME Ts)) =
               thm_of_atom (Thm.axiom thy name) Ts
 
           | thm_of _ Hs (PBound i) = nth Hs i
 
           | thm_of (vs, names) Hs (Abst (s, SOME T, prf)) =
               let
                 val (x, names') = Name.variant s names;
                 val thm = thm_of ((x, T) :: vs, names') Hs prf
               in
                 Thm.forall_intr (Thm.global_cterm_of thy (Free (x, T))) thm
               end
 
           | thm_of (vs, names) Hs (prf % SOME t) =
               let
                 val thm = thm_of (vs, names) Hs prf;
                 val ct = Thm.global_cterm_of thy (Term.subst_bounds (map Free vs, t));
               in
                 Thm.forall_elim ct thm
                 handle THM (s, _, _) => appl_error thy pretty_term vs Hs s prf t
               end
 
           | thm_of (vs, names) Hs (AbsP (_, SOME t, prf)) =
               let
                 val ct = Thm.global_cterm_of thy (Term.subst_bounds (map Free vs, t));
                 val thm = thm_of (vs, names) (Thm.assume ct :: Hs) prf;
               in
                 Thm.implies_intr ct thm
               end
 
           | thm_of vars Hs (prf %% prf') =
               let
                 val thm = beta_eta_convert (thm_of vars Hs prf);
                 val thm' = beta_eta_convert (thm_of vars Hs prf');
               in
                 Thm.implies_elim thm thm'
                 handle THM (s, _, _) => appl_error thy pretty_prf (fst vars) Hs s prf prf'
               end
 
           | thm_of _ _ (Hyp t) = Thm.assume (Thm.global_cterm_of thy t)
 
           | thm_of _ _ (PClass (T, c)) =
               if Sign.of_sort thy (T, [c])
               then Thm.of_class (Thm.global_ctyp_of thy T, c)
               else
                 error ("thm_of_proof: bad PClass proof " ^
                   Syntax.string_of_term_global thy (Logic.mk_of_class (T, c)))
 
           | thm_of _ _ _ = error "thm_of_proof: partial proof term";
 
       in beta_eta_convert (thm_of ([], prf_names) [] prf) end
   end;
 
 end;
diff --git a/src/Pure/Proof/proof_rewrite_rules.ML b/src/Pure/Proof/proof_rewrite_rules.ML
--- a/src/Pure/Proof/proof_rewrite_rules.ML
+++ b/src/Pure/Proof/proof_rewrite_rules.ML
@@ -1,394 +1,394 @@
 (*  Title:      Pure/Proof/proof_rewrite_rules.ML
     Author:     Stefan Berghofer, TU Muenchen
 
 Simplification functions for proof terms involving meta level rules.
 *)
 
 signature PROOF_REWRITE_RULES =
 sig
   val rew : bool -> typ list -> term option list -> Proofterm.proof -> (Proofterm.proof * Proofterm.proof) option
   val rprocs : bool ->
     (typ list -> term option list -> Proofterm.proof -> (Proofterm.proof * Proofterm.proof) option) list
   val rewrite_terms : (term -> term) -> Proofterm.proof -> Proofterm.proof
   val elim_defs : theory -> bool -> thm list -> Proofterm.proof -> Proofterm.proof
   val elim_vars : (typ -> term) -> Proofterm.proof -> Proofterm.proof
   val hhf_proof : term -> term -> Proofterm.proof -> Proofterm.proof
   val un_hhf_proof : term -> term -> Proofterm.proof -> Proofterm.proof
   val expand_of_sort_proof : theory -> term option list -> typ * sort -> Proofterm.proof list
   val expand_of_class_proof : theory -> term option list -> typ * class -> proof
   val expand_of_class : theory -> typ list -> term option list -> Proofterm.proof ->
     (Proofterm.proof * Proofterm.proof) option
   val standard_preproc: (proof * proof) list -> theory -> proof -> proof
 end;
 
 structure Proof_Rewrite_Rules : PROOF_REWRITE_RULES =
 struct
 
 fun rew b _ _ =
   let
     fun ?? x = if b then SOME x else NONE;
     fun ax (prf as PAxm (s, prop, _)) Ts =
       if b then PAxm (s, prop, SOME Ts) else prf;
     fun ty T =
       if b then
         (case T of
           Type (_, [Type (_, [U, _]), _]) => SOME U
         | _ => NONE)
       else NONE;
     val equal_intr_axm = ax Proofterm.equal_intr_axm [];
     val equal_elim_axm = ax Proofterm.equal_elim_axm [];
     val symmetric_axm = ax Proofterm.symmetric_axm [propT];
 
     fun rew' (PThm ({name = "Pure.protectD", ...}, _) % _ %%
         (PThm ({name = "Pure.protectI", ...}, _) % _ %% prf)) = SOME prf
       | rew' (PThm ({name = "Pure.conjunctionD1", ...}, _) % _ % _ %%
         (PThm ({name = "Pure.conjunctionI", ...}, _) % _ % _ %% prf %% _)) = SOME prf
       | rew' (PThm ({name = "Pure.conjunctionD2", ...}, _) % _ % _ %%
         (PThm ({name = "Pure.conjunctionI", ...}, _) % _ % _ %% _ %% prf)) = SOME prf
       | rew' (PAxm ("Pure.equal_elim", _, _) % _ % _ %%
         (PAxm ("Pure.equal_intr", _, _) % _ % _ %% prf %% _)) = SOME prf
       | rew' (PAxm ("Pure.symmetric", _, _) % _ % _ %%
         (PAxm ("Pure.equal_intr", _, _) % A % B %% prf1 %% prf2)) =
             SOME (equal_intr_axm % B % A %% prf2 %% prf1)
 
       | rew' (PAxm ("Pure.equal_elim", _, _) % SOME (_ $ A) % SOME (_ $ B) %%
         (PAxm ("Pure.combination", _, _) % SOME (Const ("Pure.prop", _)) %
           _ % _ % _ %% (PAxm ("Pure.reflexive", _, _) % _) %% prf1) %%
         ((tg as PThm ({name = "Pure.protectI", ...}, _)) % _ %% prf2)) =
         SOME (tg %> B %% (equal_elim_axm %> A %> B %% prf1 %% prf2))
 
       | rew' (PAxm ("Pure.equal_elim", _, _) % SOME (_ $ A) % SOME (_ $ B) %%
         (PAxm ("Pure.symmetric", _, _) % _ % _ %%
           (PAxm ("Pure.combination", _, _) % SOME (Const ("Pure.prop", _)) %
              _ % _ % _ %% (PAxm ("Pure.reflexive", _, _) % _) %% prf1)) %%
         ((tg as PThm ({name = "Pure.protectI", ...}, _)) % _ %% prf2)) =
         SOME (tg %> B %% (equal_elim_axm %> A %> B %%
           (symmetric_axm % ?? B % ?? A %% prf1) %% prf2))
 
       | rew' (PAxm ("Pure.equal_elim", _, _) % SOME X % SOME Y %%
         (PAxm ("Pure.combination", _, _) % _ % _ % _ % _ %%
           (PAxm ("Pure.combination", _, _) % SOME (Const ("Pure.imp", _)) % _ % _ % _ %%
              (PAxm ("Pure.reflexive", _, _) % _) %% prf1) %% prf2)) =
         let
           val _ $ A $ C = Envir.beta_norm X;
           val _ $ B $ D = Envir.beta_norm Y
         in SOME (AbsP ("H1", ?? X, AbsP ("H2", ?? B,
           Proofterm.equal_elim_axm %> C %> D %% Proofterm.incr_pboundvars 2 0 prf2 %%
             (PBound 1 %% (equal_elim_axm %> B %> A %%
               (Proofterm.symmetric_axm % ?? A % ?? B %% Proofterm.incr_pboundvars 2 0 prf1) %%
                 PBound 0)))))
         end
 
       | rew' (PAxm ("Pure.equal_elim", _, _) % SOME X % SOME Y %%
         (PAxm ("Pure.symmetric", _, _) % _ % _ %%
           (PAxm ("Pure.combination", _, _) % _ % _ % _ % _ %%
             (PAxm ("Pure.combination", _, _) % SOME (Const ("Pure.imp", _)) % _ % _ % _ %%
                (PAxm ("Pure.reflexive", _, _) % _) %% prf1) %% prf2))) =
         let
           val _ $ A $ C = Envir.beta_norm Y;
           val _ $ B $ D = Envir.beta_norm X
         in SOME (AbsP ("H1", ?? X, AbsP ("H2", ?? A,
           equal_elim_axm %> D %> C %%
             (symmetric_axm % ?? C % ?? D %% Proofterm.incr_pboundvars 2 0 prf2) %%
               (PBound 1 %%
                 (equal_elim_axm %> A %> B %% Proofterm.incr_pboundvars 2 0 prf1 %% PBound 0)))))
         end
 
       | rew' (PAxm ("Pure.combination", _, _) %
         SOME (imp as (imp' as Const ("Pure.imp", T)) $ X) % _ % Y % Z %%
           (PAxm ("Pure.reflexive", _, _) % _) %% prf) =
         SOME (ax Proofterm.combination_axm [propT, propT] %> imp % ?? imp % Y % Z %%
           (ax Proofterm.combination_axm [propT, propT --> propT] %> imp' % ?? imp' % ?? X % ?? X %%
              (ax Proofterm.reflexive_axm [T] % ?? imp') %%
              (ax Proofterm.reflexive_axm [propT] % ?? X)) %% prf)
 
       | rew' (PAxm ("Pure.equal_elim", _, _) % SOME X % SOME Y %%
         (PAxm ("Pure.combination", _, _) % SOME (Const ("Pure.all", _)) % _ % _ % _ %%
           (PAxm ("Pure.reflexive", _, _) % _) %%
             (PAxm ("Pure.abstract_rule", _, _) % _ % _ %% prf))) =
         let
           val Const (_, T) $ P = Envir.beta_norm X;
           val _ $ Q = Envir.beta_norm Y;
         in SOME (AbsP ("H", ?? X, Abst ("x", ty T,
             equal_elim_axm %> incr_boundvars 1 P $ Bound 0 %> incr_boundvars 1 Q $ Bound 0 %%
               (Proofterm.incr_pboundvars 1 1 prf %> Bound 0) %% (PBound 0 %> Bound 0))))
         end
 
       | rew' (PAxm ("Pure.equal_elim", _, _) % SOME X % SOME Y %%
         (PAxm ("Pure.symmetric", _, _) % _ % _ %%        
           (PAxm ("Pure.combination", _, _) % SOME (Const ("Pure.all", _)) % _ % _ % _ %%
             (PAxm ("Pure.reflexive", _, _) % _) %%
               (PAxm ("Pure.abstract_rule", _, _) % _ % _ %% prf)))) =
         let
           val Const (_, T) $ P = Envir.beta_norm X;
           val _ $ Q = Envir.beta_norm Y;
           val t = incr_boundvars 1 P $ Bound 0;
           val u = incr_boundvars 1 Q $ Bound 0
         in SOME (AbsP ("H", ?? X, Abst ("x", ty T,
           equal_elim_axm %> t %> u %%
             (symmetric_axm % ?? u % ?? t %% (Proofterm.incr_pboundvars 1 1 prf %> Bound 0))
               %% (PBound 0 %> Bound 0))))
         end
 
       | rew' (PAxm ("Pure.equal_elim", _, _) % SOME A % SOME C %%
         (PAxm ("Pure.transitive", _, _) % _ % SOME B % _ %% prf1 %% prf2) %% prf3) =
            SOME (equal_elim_axm %> B %> C %% prf2 %%
              (equal_elim_axm %> A %> B %% prf1 %% prf3))
       | rew' (PAxm ("Pure.equal_elim", _, _) % SOME A % SOME C %%
         (PAxm ("Pure.symmetric", _, _) % _ % _ %%
           (PAxm ("Pure.transitive", _, _) % _ % SOME B % _ %% prf1 %% prf2)) %% prf3) =
            SOME (equal_elim_axm %> B %> C %% (symmetric_axm % ?? C % ?? B %% prf1) %%
              (equal_elim_axm %> A %> B %% (symmetric_axm % ?? B % ?? A %% prf2) %% prf3))
 
       | rew' (PAxm ("Pure.equal_elim", _, _) % _ % _ %%
         (PAxm ("Pure.reflexive", _, _) % _) %% prf) = SOME prf
       | rew' (PAxm ("Pure.equal_elim", _, _) % _ % _ %%
         (PAxm ("Pure.symmetric", _, _) % _ % _ %%
           (PAxm ("Pure.reflexive", _, _) % _)) %% prf) = SOME prf
 
       | rew' (PAxm ("Pure.symmetric", _, _) % _ % _ %%
         (PAxm ("Pure.symmetric", _, _) % _ % _ %% prf)) = SOME prf
 
       | rew' (PAxm ("Pure.equal_elim", _, _) % _ % _ %%
         (PAxm ("Pure.equal_elim", _, _) % SOME (_ $ A $ C) % SOME (_ $ B $ D) %%
           (PAxm ("Pure.combination", _, _) % _ % _ % _ % _ %%
             (PAxm ("Pure.combination", _, _) % SOME (Const ("Pure.eq", _)) % _ % _ % _ %%
               (PAxm ("Pure.reflexive", _, _) % _) %% prf1) %% prf2) %% prf3) %% prf4) =
           SOME (equal_elim_axm %> C %> D %% prf2 %%
             (equal_elim_axm %> A %> C %% prf3 %%
               (equal_elim_axm %> B %> A %% (symmetric_axm % ?? A % ?? B %% prf1) %% prf4)))
 
       | rew' (PAxm ("Pure.equal_elim", _, _) % _ % _ %%
         (PAxm ("Pure.symmetric", _, _) % _ % _ %%
           (PAxm ("Pure.equal_elim", _, _) % SOME (_ $ A $ C) % SOME (_ $ B $ D) %%
             (PAxm ("Pure.combination", _, _) % _ % _ % _ % _ %%
               (PAxm ("Pure.combination", _, _) % SOME (Const ("Pure.eq", _)) % _ % _ % _ %%
                 (PAxm ("Pure.reflexive", _, _) % _) %% prf1) %% prf2) %% prf3)) %% prf4) =
           SOME (equal_elim_axm %> A %> B %% prf1 %%
             (equal_elim_axm %> C %> A %% (symmetric_axm % ?? A % ?? C %% prf3) %%
               (equal_elim_axm %> D %> C %% (symmetric_axm % ?? C % ?? D %% prf2) %% prf4)))
 
       | rew' (PAxm ("Pure.equal_elim", _, _) % _ % _ %%
         (PAxm ("Pure.equal_elim", _, _) % SOME (_ $ B $ D) % SOME (_ $ A $ C) %%
           (PAxm ("Pure.symmetric", _, _) % _ % _ %%
             (PAxm ("Pure.combination", _, _) % _ % _ % _ % _ %%
               (PAxm ("Pure.combination", _, _) % SOME (Const ("Pure.eq", _)) % _ % _ % _ %%
                 (PAxm ("Pure.reflexive", _, _) % _) %% prf1) %% prf2)) %% prf3) %% prf4) =
           SOME (equal_elim_axm %> D %> C %% (symmetric_axm % ?? C % ?? D %% prf2) %%
             (equal_elim_axm %> B %> D %% prf3 %%
               (equal_elim_axm %> A %> B %% prf1 %% prf4)))
 
       | rew' (PAxm ("Pure.equal_elim", _, _) % _ % _ %%
         (PAxm ("Pure.symmetric", _, _) % _ % _ %%
           (PAxm ("Pure.equal_elim", _, _) % SOME (_ $ B $ D) % SOME (_ $ A $ C) %%
             (PAxm ("Pure.symmetric", _, _) % _ % _ %%
               (PAxm ("Pure.combination", _, _) % _ % _ % _ % _ %%
                 (PAxm ("Pure.combination", _, _) % SOME (Const ("Pure.eq", _)) % _ % _ % _ %%
                   (PAxm ("Pure.reflexive", _, _) % _) %% prf1) %% prf2)) %% prf3)) %% prf4) =
           SOME (equal_elim_axm %> B %> A %% (symmetric_axm % ?? A % ?? B %% prf1) %%
             (equal_elim_axm %> D %> B %% (symmetric_axm % ?? B % ?? D %% prf3) %%
               (equal_elim_axm %> C %> D %% prf2 %% prf4)))
 
       | rew' ((prf as PAxm ("Pure.combination", _, _) %
         SOME ((eq as Const ("Pure.eq", T)) $ t) % _ % _ % _) %%
           (PAxm ("Pure.reflexive", _, _) % _)) =
         let val (U, V) = (case T of
           Type (_, [U, V]) => (U, V) | _ => (dummyT, dummyT))
         in SOME (prf %% (ax Proofterm.combination_axm [U, V] %> eq % ?? eq % ?? t % ?? t %%
           (ax Proofterm.reflexive_axm [T] % ?? eq) %% (ax Proofterm.reflexive_axm [U] % ?? t)))
         end
 
       | rew' _ = NONE;
   in rew' #> Option.map (rpair Proofterm.no_skel) end;
 
 fun rprocs b = [rew b];
 val _ = Theory.setup (fold Proofterm.add_prf_rproc (rprocs false));
 
 
 (**** apply rewriting function to all terms in proof ****)
 
 fun rewrite_terms r =
   let
     fun rew_term Ts t =
       let
         val frees =
           map Free (Name.invent (Term.declare_term_frees t Name.context) "xa" (length Ts) ~~ Ts);
         val t' = r (subst_bounds (frees, t));
         fun strip [] t = t
           | strip (_ :: xs) (Abs (_, _, t)) = strip xs t;
       in
         strip Ts (fold lambda frees t')
       end;
 
     fun rew Ts (prf1 %% prf2) = rew Ts prf1 %% rew Ts prf2
       | rew Ts (prf % SOME t) = rew Ts prf % SOME (rew_term Ts t)
       | rew Ts (Abst (s, SOME T, prf)) = Abst (s, SOME T, rew (T :: Ts) prf)
       | rew Ts (AbsP (s, SOME t, prf)) = AbsP (s, SOME (rew_term Ts t), rew Ts prf)
       | rew _ prf = prf
 
   in rew [] end;
 
 
 (**** eliminate definitions in proof ****)
 
 fun vars_of t = rev (fold_aterms (fn v as Var _ => insert (op =) v | _ => I) t []);
 
 fun insert_refl defs Ts (prf1 %% prf2) =
       let val (prf1', b) = insert_refl defs Ts prf1
       in
         if b then (prf1', true)
         else (prf1' %% fst (insert_refl defs Ts prf2), false)
       end
   | insert_refl defs Ts (Abst (s, SOME T, prf)) =
       (Abst (s, SOME T, fst (insert_refl defs (T :: Ts) prf)), false)
   | insert_refl defs Ts (AbsP (s, t, prf)) =
       (AbsP (s, t, fst (insert_refl defs Ts prf)), false)
   | insert_refl defs Ts prf =
       (case Proofterm.strip_combt prf of
         (PThm ({name = s, prop, types = SOME Ts, ...}, _), ts) =>
           if member (op =) defs s then
             let
               val vs = vars_of prop;
               val tvars = rev (Term.add_tvars prop []);
               val (_, rhs) = Logic.dest_equals (Logic.strip_imp_concl prop);
               val rhs' = Term.betapplys (subst_TVars (map fst tvars ~~ Ts)
                 (fold_rev (fn x => fn b => Abs ("", dummyT, abstract_over (x, b))) vs rhs),
                 map the ts);
             in
               (Proofterm.change_types (SOME [fastype_of1 (Ts, rhs')])
                 Proofterm.reflexive_axm %> rhs', true)
             end
           else (prf, false)
       | (_, []) => (prf, false)
       | (prf', ts) => (Proofterm.proof_combt' (fst (insert_refl defs Ts prf'), ts), false));
 
 fun elim_defs thy r defs prf =
   let
     val defs' = map (Logic.dest_equals o
       map_types Type.strip_sorts o Thm.prop_of o Drule.abs_def) defs;
     val defnames = map Thm.derivation_name defs;
     val prf' =
       if r then
         let
           val cnames = map (fst o dest_Const o fst) defs';
           val expand = Proofterm.fold_proof_atoms true
             (fn PThm ({serial, name, prop, ...}, _) =>
                 if member (op =) defnames name orelse
                   not (exists_Const (member (op =) cnames o #1) prop)
                 then I
                 else Inttab.update (serial, "")
               | _ => I) [prf] Inttab.empty;
         in Proofterm.expand_proof thy (Inttab.lookup expand o #serial) prf end
       else prf;
   in
     rewrite_terms (Pattern.rewrite_term thy defs' [])
       (fst (insert_refl defnames [] prf'))
   end;
 
 
 (**** eliminate all variables that don't occur in the proposition ****)
 
 fun elim_vars mk_default prf =
   let
     val prop = Proofterm.prop_of prf;
-    val tv = Term_Subst.add_vars prop Term_Subst.Vars.empty;
-    val tf = Term_Subst.add_frees prop Term_Subst.Frees.empty;
+    val tv = Term_Subst.Vars.build (Term_Subst.add_vars prop);
+    val tf = Term_Subst.Frees.build (Term_Subst.add_frees prop);
 
     fun hidden_variable (Var v) = not (Term_Subst.Vars.defined tv v)
       | hidden_variable (Free f) = not (Term_Subst.Frees.defined tf f)
       | hidden_variable _ = false;
 
     fun mk_default' T =
       fold_rev (Term.abs o pair "x") (binder_types T) (mk_default (body_type T));
 
     fun elim_varst (t $ u) = elim_varst t $ elim_varst u
       | elim_varst (Abs (s, T, t)) = Abs (s, T, elim_varst t)
       | elim_varst (t as Free (x, T)) = if Term_Subst.Frees.defined tf (x, T) then t else mk_default' T
       | elim_varst (t as Var (xi, T)) = if Term_Subst.Vars.defined tv (xi, T) then t else mk_default' T
       | elim_varst t = t;
   in
     Proofterm.map_proof_terms (fn t =>
       if Term.exists_subterm hidden_variable t then Envir.beta_norm (elim_varst t) else t) I prf
   end;
 
 
 (**** convert between hhf and non-hhf form ****)
 
 fun hhf_proof P Q prf =
   let
     val params = Logic.strip_params Q;
     val Hs = Logic.strip_assums_hyp P;
     val Hs' = Logic.strip_assums_hyp Q;
     val k = length Hs;
     val l = length params;
     fun mk_prf i j Hs Hs' (Const ("Pure.all", _) $ Abs (_, _, P)) prf =
           mk_prf i (j - 1) Hs Hs' P (prf %> Bound j)
       | mk_prf i j (H :: Hs) (H' :: Hs') (Const ("Pure.imp", _) $ _ $ P) prf =
           mk_prf (i - 1) j Hs Hs' P (prf %% un_hhf_proof H' H (PBound i))
       | mk_prf _ _ _ _ _ prf = prf
   in
     prf |> Proofterm.incr_pboundvars k l |> mk_prf (k - 1) (l - 1) Hs Hs' P |>
     fold_rev (fn P => fn prf => AbsP ("H", SOME P, prf)) Hs' |>
     fold_rev (fn (s, T) => fn prf => Abst (s, SOME T, prf)) params
   end
 and un_hhf_proof P Q prf =
   let
     val params = Logic.strip_params Q;
     val Hs = Logic.strip_assums_hyp P;
     val Hs' = Logic.strip_assums_hyp Q;
     val k = length Hs;
     val l = length params;
     fun mk_prf (Const ("Pure.all", _) $ Abs (s, T, P)) prf =
           Abst (s, SOME T, mk_prf P prf)
       | mk_prf (Const ("Pure.imp", _) $ P $ Q) prf =
           AbsP ("H", SOME P, mk_prf Q prf)
       | mk_prf _ prf = prf
   in
     prf |> Proofterm.incr_pboundvars k l |>
     fold (fn i => fn prf => prf %> Bound i) (l - 1 downto 0) |>
     fold (fn ((H, H'), i) => fn prf => prf %% hhf_proof H' H (PBound i))
       (Hs ~~ Hs' ~~ (k - 1 downto 0)) |>
     mk_prf Q
   end;
 
 
 (**** expand PClass proofs ****)
 
 fun expand_of_sort_proof thy hyps (T, S) =
   let
     val of_class_hyps = map (fn SOME t => try Logic.dest_of_class t | NONE => NONE) hyps;
     fun of_class_index p =
       (case find_index (fn SOME h => h = p | NONE => false) of_class_hyps of
         ~1 => raise Fail "expand_of_class_proof: missing class hypothesis"
       | i => PBound i);
 
     val sorts = AList.coalesce (op =) (rev (map_filter I of_class_hyps));
     fun get_sort T = the_default [] (AList.lookup (op =) sorts T);
     val subst = map_atyps
       (fn T as TVar (ai, _) => TVar (ai, get_sort T)
         | T as TFree (a, _) => TFree (a, get_sort T));
 
     fun reconstruct prop =
       Proofterm.reconstruct_proof thy prop #>
       Proofterm.expand_proof thy Proofterm.expand_name_empty #>
       Same.commit (Proofterm.map_proof_same Same.same Same.same of_class_index);
   in
     map2 reconstruct (Logic.mk_of_sort (T, S))
       (Proofterm.of_sort_proof (Sign.classes_of thy) (Thm.classrel_proof thy) (Thm.arity_proof thy)
         (PClass o apfst Type.strip_sorts) (subst T, S))
   end;
 
 fun expand_of_class_proof thy hyps (T, c) =
   hd (expand_of_sort_proof thy hyps (T, [c]));
 
 fun expand_of_class thy (_: typ list) hyps (PClass (T, c)) =
       SOME (expand_of_class_proof thy hyps (T, c), Proofterm.no_skel)
   | expand_of_class _ _ _ _ = NONE;
 
 
 (* standard preprocessor *)
 
 fun standard_preproc rews thy =
   Proofterm.rewrite_proof thy (rews, rprocs true @ [expand_of_class thy]);
 
 end;
diff --git a/src/Pure/Syntax/ast.ML b/src/Pure/Syntax/ast.ML
--- a/src/Pure/Syntax/ast.ML
+++ b/src/Pure/Syntax/ast.ML
@@ -1,247 +1,247 @@
 (*  Title:      Pure/Syntax/ast.ML
     Author:     Markus Wenzel, TU Muenchen
 
 Abstract syntax trees, translation rules, matching and normalization of asts.
 *)
 
 signature AST =
 sig
   datatype ast =
     Constant of string |
     Variable of string |
     Appl of ast list
   val mk_appl: ast -> ast list -> ast
   exception AST of string * ast list
   val pretty_ast: ast -> Pretty.T
   val pretty_rule: ast * ast -> Pretty.T
   val strip_positions: ast -> ast
   val head_of_rule: ast * ast -> string
   val rule_error: ast * ast -> string option
   val fold_ast: string -> ast list -> ast
   val fold_ast_p: string -> ast list * ast -> ast
   val unfold_ast: string -> ast -> ast list
   val unfold_ast_p: string -> ast -> ast list * ast
   val trace: bool Config.T
   val stats: bool Config.T
   val normalize: Proof.context -> (string -> (ast * ast) list) -> ast -> ast
 end;
 
 structure Ast: AST =
 struct
 
 (** abstract syntax trees **)
 
 (*asts come in two flavours:
    - ordinary asts representing terms and typs: Variables are (often) treated
      like Constants;
    - patterns used as lhs and rhs in rules: Variables are placeholders for
      proper asts*)
 
 datatype ast =
   Constant of string |    (*"not", "_abs", "fun"*)
   Variable of string |    (*x, ?x, 'a, ?'a*)
   Appl of ast list;       (*(f x y z), ("fun" 'a 'b), ("_abs" x t)*)
 
 (*the list of subasts of an Appl node has to contain at least 2 elements, i.e.
   there are no empty asts or nullary applications; use mk_appl for convenience*)
 fun mk_appl f [] = f
   | mk_appl f args = Appl (f :: args);
 
 (*exception for system errors involving asts*)
 exception AST of string * ast list;
 
 
 
 (** print asts in a LISP-like style **)
 
 fun pretty_ast (Constant a) = Pretty.quote (Pretty.str a)
   | pretty_ast (Variable x) =
       (case Term_Position.decode x of
         SOME pos => Term_Position.pretty pos
       | NONE => Pretty.str x)
   | pretty_ast (Appl asts) = Pretty.enclose "(" ")" (Pretty.breaks (map pretty_ast asts));
 
 fun pretty_rule (lhs, rhs) =
   Pretty.block [pretty_ast lhs, Pretty.str " \<leadsto>", Pretty.brk 1, pretty_ast rhs];
 
 val _ = ML_system_pp (fn _ => fn _ => Pretty.to_polyml o pretty_ast);
 
 
 (* strip_positions *)
 
 fun strip_positions (Appl ((t as Constant c) :: u :: (v as Variable x) :: asts)) =
       if member (op =) Term_Position.markers c andalso is_some (Term_Position.decode x)
       then mk_appl (strip_positions u) (map strip_positions asts)
       else Appl (map strip_positions (t :: u :: v :: asts))
   | strip_positions (Appl asts) = Appl (map strip_positions asts)
   | strip_positions ast = ast;
 
 
 (* head_of_ast and head_of_rule *)
 
 fun head_of_ast (Constant a) = a
   | head_of_ast (Appl (Constant a :: _)) = a
   | head_of_ast _ = "";
 
 fun head_of_rule (lhs, _) = head_of_ast lhs;
 
 
 
 (** check translation rules **)
 
 fun rule_error (lhs, rhs) =
   let
     fun add_vars (Constant _) = I
       | add_vars (Variable x) = cons x
       | add_vars (Appl asts) = fold add_vars asts;
 
     val lvars = add_vars lhs [];
     val rvars = add_vars rhs [];
   in
     if has_duplicates (op =) lvars then SOME "duplicate vars in lhs"
     else if not (subset (op =) (rvars, lvars)) then SOME "rhs contains extra variables"
     else NONE
   end;
 
 
 
 (** ast translation utilities **)
 
 (* fold asts *)
 
 fun fold_ast _ [] = raise Match
   | fold_ast _ [y] = y
   | fold_ast c (x :: xs) = Appl [Constant c, x, fold_ast c xs];
 
 fun fold_ast_p c = uncurry (fold_rev (fn x => fn xs => Appl [Constant c, x, xs]));
 
 
 (* unfold asts *)
 
 fun unfold_ast c (y as Appl [Constant c', x, xs]) =
       if c = c' then x :: unfold_ast c xs else [y]
   | unfold_ast _ y = [y];
 
 fun unfold_ast_p c (y as Appl [Constant c', x, xs]) =
       if c = c' then apfst (cons x) (unfold_ast_p c xs)
       else ([], y)
   | unfold_ast_p _ y = ([], y);
 
 
 
 (** normalization of asts **)
 
 (* match *)
 
 fun match ast pat =
   let
     exception NO_MATCH;
 
     fun mtch (Constant a) (Constant b) env =
           if a = b then env else raise NO_MATCH
       | mtch (Variable a) (Constant b) env =
           if a = b then env else raise NO_MATCH
       | mtch ast (Variable x) env = Symtab.update (x, ast) env
       | mtch (Appl asts) (Appl pats) env = mtch_lst asts pats env
       | mtch _ _ _ = raise NO_MATCH
     and mtch_lst (ast :: asts) (pat :: pats) env =
           mtch_lst asts pats (mtch ast pat env)
       | mtch_lst [] [] env = env
       | mtch_lst _ _ _ = raise NO_MATCH;
 
     val (head, args) =
       (case (ast, pat) of
         (Appl asts, Appl pats) =>
           let val a = length asts and p = length pats in
             if a > p then (Appl (take p asts), drop p asts)
             else (ast, [])
           end
       | _ => (ast, []));
   in
-    SOME (mtch head pat Symtab.empty, args) handle NO_MATCH => NONE
+    SOME (Symtab.build (mtch head pat), args) handle NO_MATCH => NONE
   end;
 
 
 (* normalize *)
 
 val trace = Config.declare_bool ("syntax_ast_trace", \<^here>) (K false);
 val stats = Config.declare_bool ("syntax_ast_stats", \<^here>) (K false);
 
 fun message head body =
   Pretty.string_of (Pretty.block [Pretty.str head, Pretty.brk 1, body]);
 
 (*the normalizer works yoyo-like: top-down, bottom-up, top-down, ...*)
 fun normalize ctxt get_rules pre_ast =
   let
     val trace = Config.get ctxt trace;
     val stats = Config.get ctxt stats;
 
     val passes = Unsynchronized.ref 0;
     val failed_matches = Unsynchronized.ref 0;
     val changes = Unsynchronized.ref 0;
 
     fun subst _ (ast as Constant _) = ast
       | subst env (Variable x) = the (Symtab.lookup env x)
       | subst env (Appl asts) = Appl (map (subst env) asts);
 
     fun try_rules ((lhs, rhs) :: pats) ast =
           (case match ast lhs of
             SOME (env, args) =>
               (Unsynchronized.inc changes; SOME (mk_appl (subst env rhs) args))
           | NONE => (Unsynchronized.inc failed_matches; try_rules pats ast))
       | try_rules [] _ = NONE;
     val try_headless_rules = try_rules (get_rules "");
 
     fun try ast a =
       (case try_rules (get_rules a) ast of
         NONE => try_headless_rules ast
       | some => some);
 
     fun rewrite (ast as Constant a) = try ast a
       | rewrite (ast as Variable a) = try ast a
       | rewrite (ast as Appl (Constant a :: _)) = try ast a
       | rewrite (ast as Appl (Variable a :: _)) = try ast a
       | rewrite ast = try_headless_rules ast;
 
     fun rewrote old_ast new_ast =
       if trace then tracing (message "rewrote:" (pretty_rule (old_ast, new_ast)))
       else ();
 
     fun norm_root ast =
       (case rewrite ast of
         SOME new_ast => (rewrote ast new_ast; norm_root new_ast)
       | NONE => ast);
 
     fun norm ast =
       (case norm_root ast of
         Appl sub_asts =>
           let
             val old_changes = ! changes;
             val new_ast = Appl (map norm sub_asts);
           in
             if old_changes = ! changes then new_ast else norm_root new_ast
           end
       | atomic_ast => atomic_ast);
 
     fun normal ast =
       let
         val old_changes = ! changes;
         val new_ast = norm ast;
       in
         Unsynchronized.inc passes;
         if old_changes = ! changes then new_ast else normal new_ast
       end;
 
 
     val _ = if trace then tracing (message "pre:" (pretty_ast pre_ast)) else ();
     val post_ast = normal pre_ast;
     val _ =
       if trace orelse stats then
         tracing (message "post:" (pretty_ast post_ast) ^ "\nnormalize: " ^
           string_of_int (! passes) ^ " passes, " ^
           string_of_int (! changes) ^ " changes, " ^
           string_of_int (! failed_matches) ^ " matches failed")
       else ();
   in post_ast end;
 
 end;
diff --git a/src/Pure/Tools/find_consts.ML b/src/Pure/Tools/find_consts.ML
--- a/src/Pure/Tools/find_consts.ML
+++ b/src/Pure/Tools/find_consts.ML
@@ -1,172 +1,172 @@
 (*  Title:      Pure/Tools/find_consts.ML
     Author:     Timothy Bourke and Gerwin Klein, NICTA
 
 Hoogle-like (https://www-users.cs.york.ac.uk/~ndm/hoogle) searching by
 type over constants, but matching is not fuzzy.
 *)
 
 signature FIND_CONSTS =
 sig
   datatype criterion =
       Strict of string
     | Loose of string
     | Name of string
   val pretty_consts: Proof.context -> (bool * criterion) list -> Pretty.T
   val query_parser: (bool * criterion) list parser
   val read_query: Position.T -> string -> (bool * criterion) list
   val find_consts : Proof.context -> (bool * criterion) list -> unit
 end;
 
 structure Find_Consts : FIND_CONSTS =
 struct
 
 (* search criteria *)
 
 datatype criterion =
     Strict of string
   | Loose of string
   | Name of string;
 
 
 (* matching types/consts *)
 
 fun matches_subtype thy typat =
   Term.exists_subtype (fn ty => Sign.typ_instance thy (ty, typat));
 
 fun check_const pred (c, (ty, _)) =
   if pred (c, ty) then SOME (Term.size_of_typ ty) else NONE;
 
 fun opt_not f (c as (_, (ty, _))) =
   if is_some (f c) then NONE else SOME (Term.size_of_typ ty);
 
 fun filter_const _ _ NONE = NONE
   | filter_const c f (SOME rank) =
       (case f c of
         NONE => NONE
       | SOME i => SOME (Int.min (rank, i)));
 
 
 (* pretty results *)
 
 fun pretty_criterion (b, c) =
   let
     fun prfx s = if b then s else "-" ^ s;
     val show_pat = quote o #1 o Input.source_content o Syntax.read_input;
   in
     (case c of
       Strict pat => Pretty.str (prfx "strict: " ^ show_pat pat)
     | Loose pat => Pretty.str (prfx (show_pat pat))
     | Name name => Pretty.str (prfx "name: " ^ quote name))
   end;
 
 fun pretty_const ctxt (c, ty) =
   let
     val ty' = Logic.unvarifyT_global ty;
     val markup = Name_Space.markup (Proof_Context.const_space ctxt) c;
   in
     Pretty.block
      [Pretty.mark markup (Pretty.str c), Pretty.str " ::", Pretty.brk 1,
       Pretty.quote (Syntax.pretty_typ ctxt ty')]
   end;
 
 
 (* find_consts *)
 
 fun pretty_consts ctxt raw_criteria =
   let
     val thy = Proof_Context.theory_of ctxt;
     val low_ranking = 10000;
 
     fun make_pattern crit =
       let
         val raw_T = Syntax.parse_typ ctxt crit;
         val t =
           Syntax.check_term
             (Proof_Context.set_mode Proof_Context.mode_pattern ctxt)
             (Term.dummy_pattern raw_T);
       in Term.type_of t end;
 
     fun make_match (Strict arg) =
           let val qty = make_pattern arg; in
             fn (_, (ty, _)) =>
               let
-                val tye = Sign.typ_match thy (qty, ty) Vartab.empty;
+                val tye = Vartab.build (Sign.typ_match thy (qty, ty));
                 val sub_size =
                   Vartab.fold (fn (_, (_, t)) => fn n => Term.size_of_typ t + n) tye 0;
               in SOME sub_size end handle Type.TYPE_MATCH => NONE
           end
       | make_match (Loose arg) =
           check_const (matches_subtype thy (make_pattern arg) o snd)
       | make_match (Name arg) = check_const (match_string arg o fst);
 
     fun make_criterion (b, crit) = (if b then I else opt_not) (make_match crit);
     val criteria = map make_criterion raw_criteria;
 
     fun user_visible (c, _) =
       if Consts.is_concealed (Proof_Context.consts_of ctxt) c
       then NONE else SOME low_ranking;
 
     fun eval_entry c =
       fold (filter_const c) (user_visible :: criteria) (SOME low_ranking);
 
     val {constants, ...} = Consts.dest (Sign.consts_of thy);
     val matches =
       fold (fn c => (case eval_entry c of NONE => I | SOME rank => cons (rank, c))) constants []
       |> sort (prod_ord (rev_order o int_ord) (string_ord o apply2 fst))
       |> map (apsnd fst o snd);
 
     val position_markup = Position.markup (Position.thread_data ()) Markup.position;
   in
     Pretty.block
       (Pretty.fbreaks
         (Pretty.mark position_markup (Pretty.keyword1 "find_consts") ::
           map pretty_criterion raw_criteria)) ::
     Pretty.str "" ::
     (if null matches then [Pretty.str "found nothing"]
      else
        Pretty.str ("found " ^ string_of_int (length matches) ^ " constant(s):") ::
        grouped 10 Par_List.map (Pretty.item o single o pretty_const ctxt) matches)
   end |> Pretty.chunks;
 
 fun find_consts ctxt args = Pretty.writeln (pretty_consts ctxt args);
 
 
 (* command syntax *)
 
 local
 
 val criterion =
   Parse.reserved "name" |-- Parse.!!! (Parse.$$$ ":" |-- Parse.name) >> Name ||
   Parse.reserved "strict" |-- Parse.!!! (Parse.$$$ ":" |-- Parse.typ) >> Strict ||
   Parse.typ >> Loose;
 
 val query_keywords =
   Keyword.add_keywords [((":", \<^here>), Keyword.no_spec)] Keyword.empty_keywords;
 
 in
 
 val query_parser = Scan.repeat ((Scan.option Parse.minus >> is_none) -- criterion);
 
 fun read_query pos str =
   Token.explode query_keywords pos str
   |> filter Token.is_proper
   |> Scan.error (Scan.finite Token.stopper (Parse.!!! (query_parser --| Scan.ahead Parse.eof)))
   |> #1;
 
 end;
 
 
 (* PIDE query operation *)
 
 val _ =
   Query_Operation.register {name = "find_consts", pri = Task_Queue.urgent_pri}
     (fn {state, args, writeln_result, ...} =>
       (case try Toplevel.context_of state of
         SOME ctxt =>
           let
             val [query_arg] = args;
             val query = read_query Position.none query_arg;
           in writeln_result (Pretty.string_of (pretty_consts ctxt query)) end
       | NONE => error "Unknown context"));
 
 end;
diff --git a/src/Pure/Tools/rule_insts.ML b/src/Pure/Tools/rule_insts.ML
--- a/src/Pure/Tools/rule_insts.ML
+++ b/src/Pure/Tools/rule_insts.ML
@@ -1,354 +1,354 @@
 (*  Title:      Pure/Tools/rule_insts.ML
     Author:     Makarius
 
 Rule instantiations -- operations within implicit rule / subgoal context.
 *)
 
 signature RULE_INSTS =
 sig
   val where_rule: Proof.context ->
     ((indexname * Position.T) * string) list ->
     (binding * string option * mixfix) list -> thm -> thm
   val of_rule: Proof.context -> string option list * string option list ->
     (binding * string option * mixfix) list -> thm -> thm
   val read_instantiate: Proof.context ->
     ((indexname * Position.T) * string) list -> string list -> thm -> thm
   val read_term: string -> Proof.context -> term * Proof.context
   val goal_context: term -> Proof.context -> (string * typ) list * Proof.context
   val res_inst_tac: Proof.context ->
     ((indexname * Position.T) * string) list -> (binding * string option * mixfix) list ->
     thm -> int -> tactic
   val eres_inst_tac: Proof.context ->
     ((indexname * Position.T) * string) list -> (binding * string option * mixfix) list ->
     thm -> int -> tactic
   val cut_inst_tac: Proof.context ->
     ((indexname * Position.T) * string) list -> (binding * string option * mixfix) list ->
     thm -> int -> tactic
   val forw_inst_tac: Proof.context ->
     ((indexname * Position.T) * string) list -> (binding * string option * mixfix) list ->
     thm -> int -> tactic
   val dres_inst_tac: Proof.context ->
     ((indexname * Position.T) * string) list -> (binding * string option * mixfix) list ->
     thm -> int -> tactic
   val thin_tac: Proof.context -> string -> (binding * string option * mixfix) list ->
     int -> tactic
   val subgoal_tac: Proof.context -> string -> (binding * string option * mixfix) list ->
     int -> tactic
   val make_elim_preserve: Proof.context -> thm -> thm
   val method:
     (Proof.context -> ((indexname * Position.T) * string) list ->
       (binding * string option * mixfix) list -> thm -> int -> tactic) ->
     (Proof.context -> thm list -> int -> tactic) ->
     (Proof.context -> Proof.method) context_parser
 end;
 
 structure Rule_Insts: RULE_INSTS =
 struct
 
 (** read instantiations **)
 
 local
 
 fun error_var msg (xi, pos) =
   error (msg ^ quote (Term.string_of_vname xi) ^ Position.here pos);
 
 fun the_sort tvars (ai, pos) : sort =
   (case Term_Subst.TVars.get_first (fn ((bi, S), ()) => if ai = bi then SOME S else NONE) tvars of
     SOME S => S
   | NONE => error_var "No such type variable in theorem: " (ai, pos));
 
 fun the_type vars (xi, pos) : typ =
   (case Vartab.lookup vars xi of
     SOME T => T
   | NONE => error_var "No such variable in theorem: " (xi, pos));
 
 fun read_type ctxt tvars ((xi, pos), s) =
   let
     val S = the_sort tvars (xi, pos);
     val T = Syntax.read_typ ctxt s;
   in
     if Sign.of_sort (Proof_Context.theory_of ctxt) (T, S) then ((xi, S), T)
     else error_var "Bad sort for instantiation of type variable: " (xi, pos)
   end;
 
 fun make_instT f (tvars: Term_Subst.TVars.set) =
   let
     fun add v =
       let
         val T = TVar v;
         val T' = f T;
       in if T = T' then I else cons (v, T') end;
   in Term_Subst.TVars.fold (add o #1) tvars [] end;
 
 fun make_inst f vars =
   let
     fun add v =
       let
         val t = Var v;
         val t' = f t;
       in if t aconv t' then I else cons (v, t') end;
   in fold add vars [] end;
 
 fun read_terms ss Ts ctxt =
   let
     fun parse T = if T = propT then Syntax.parse_prop ctxt else Syntax.parse_term ctxt;
     val (ts, ctxt') = fold_map Variable.fix_dummy_patterns (map2 parse Ts ss) ctxt;
     val ts' =
       map2 (Type.constraint o Type_Infer.paramify_vars) Ts ts
       |> Syntax.check_terms ctxt'
       |> Variable.polymorphic ctxt';
     val Ts' = map Term.fastype_of ts';
-    val tyenv = fold (Sign.typ_match (Proof_Context.theory_of ctxt)) (Ts ~~ Ts') Vartab.empty;
+    val tyenv = Vartab.build (fold (Sign.typ_match (Proof_Context.theory_of ctxt)) (Ts ~~ Ts'));
     val tyenv' = Vartab.fold (fn (xi, (S, T)) => cons ((xi, S), T)) tyenv [];
   in ((ts', tyenv'), ctxt') end;
 
 in
 
 fun read_term s ctxt =
   let
     val (t, ctxt') = Variable.fix_dummy_patterns (Syntax.parse_term ctxt s) ctxt;
     val t' = Syntax.check_term ctxt' t;
   in (t', ctxt') end;
 
 fun read_insts thm raw_insts raw_fixes ctxt =
   let
     val (type_insts, term_insts) =
       List.partition (fn (((x, _), _), _) => String.isPrefix "'" x) raw_insts;
 
-    val tvars = Thm.fold_terms Term_Subst.add_tvars thm Term_Subst.TVars.empty;
-    val vars = Thm.fold_terms Term_Subst.add_vars thm Term_Subst.Vars.empty;
+    val tvars = Term_Subst.TVars.build (Thm.fold_terms Term_Subst.add_tvars thm);
+    val vars = Term_Subst.Vars.build (Thm.fold_terms Term_Subst.add_vars thm);
 
     (*eigen-context*)
     val (_, ctxt1) = ctxt
       |> Term_Subst.TVars.fold (Variable.declare_internal o Logic.mk_type o TVar o #1) tvars
       |> Term_Subst.Vars.fold (Variable.declare_internal o Var o #1) vars
       |> Proof_Context.add_fixes_cmd raw_fixes;
 
     (*explicit type instantiations*)
     val instT1 =
       Term_Subst.instantiateT (Term_Subst.TVars.table (map (read_type ctxt1 tvars) type_insts));
     val vars1 =
-      Term_Subst.Vars.fold (fn ((v, T), ()) => Vartab.insert (K true) (v, instT1 T))
-        vars Vartab.empty;
+      Vartab.build (vars |> Term_Subst.Vars.fold (fn ((v, T), ()) =>
+        Vartab.insert (K true) (v, instT1 T)));
 
     (*term instantiations*)
     val (xs, ss) = split_list term_insts;
     val Ts = map (the_type vars1) xs;
     val ((ts, inferred), ctxt2) = read_terms ss Ts ctxt1;
 
     (*implicit type instantiations*)
     val instT2 = Term_Subst.instantiateT (Term_Subst.TVars.table inferred);
     val vars2 = Vartab.fold (fn (v, T) => cons (v, instT2 T)) vars1 [];
     val inst2 =
       Term_Subst.instantiate (Term_Subst.TVars.empty,
-        fold2 (fn (xi, _) => fn t => Term_Subst.Vars.add ((xi, Term.fastype_of t), t))
-          xs ts Term_Subst.Vars.empty)
+        Term_Subst.Vars.build
+          (fold2 (fn (xi, _) => fn t => Term_Subst.Vars.add ((xi, Term.fastype_of t), t)) xs ts))
       #> Envir.beta_norm;
 
     val inst_tvars = make_instT (instT2 o instT1) tvars;
     val inst_vars = make_inst inst2 vars2;
   in ((inst_tvars, inst_vars), ctxt2) end;
 
 end;
 
 
 
 (** forward rules **)
 
 fun where_rule ctxt raw_insts raw_fixes thm =
   let
     val ((inst_tvars, inst_vars), ctxt') = read_insts thm raw_insts raw_fixes ctxt;
   in
     thm
     |> Drule.instantiate_normalize
       (map (apsnd (Thm.ctyp_of ctxt')) inst_tvars,
        map (apsnd (Thm.cterm_of ctxt')) inst_vars)
     |> singleton (Variable.export ctxt' ctxt)
     |> Rule_Cases.save thm
   end;
 
 fun of_rule ctxt (args, concl_args) fixes thm =
   let
     fun zip_vars _ [] = []
       | zip_vars (_ :: xs) (NONE :: rest) = zip_vars xs rest
       | zip_vars ((x, _) :: xs) (SOME t :: rest) = ((x, Position.none), t) :: zip_vars xs rest
       | zip_vars [] _ = error "More instantiations than variables in theorem";
     val insts =
       zip_vars (rev (Term.add_vars (Thm.full_prop_of thm) [])) args @
       zip_vars (rev (Term.add_vars (Thm.concl_of thm) [])) concl_args;
   in where_rule ctxt insts fixes thm end;
 
 fun read_instantiate ctxt insts xs =
   where_rule ctxt insts (map (fn x => (Binding.name x, NONE, NoSyn)) xs);
 
 
 
 (** attributes **)
 
 (* where: named instantiation *)
 
 val named_insts =
   Parse.and_list1
     (Parse.position Args.var -- (Args.$$$ "=" |-- Parse.!!! Args.embedded_inner_syntax))
     -- Parse.for_fixes;
 
 val _ = Theory.setup
   (Attrib.setup \<^binding>\<open>where\<close>
     (Scan.lift named_insts >> (fn args =>
       Thm.rule_attribute [] (fn context => uncurry (where_rule (Context.proof_of context)) args)))
     "named instantiation of theorem");
 
 
 (* of: positional instantiation (terms only) *)
 
 local
 
 val inst = Args.maybe Args.embedded_inner_syntax;
 val concl = Args.$$$ "concl" -- Args.colon;
 
 val insts =
   Scan.repeat (Scan.unless concl inst) --
   Scan.optional (concl |-- Scan.repeat inst) [];
 
 in
 
 val _ = Theory.setup
   (Attrib.setup \<^binding>\<open>of\<close>
     (Scan.lift (insts -- Parse.for_fixes) >> (fn args =>
       Thm.rule_attribute [] (fn context => uncurry (of_rule (Context.proof_of context)) args)))
     "positional instantiation of theorem");
 
 end;
 
 
 
 (** tactics **)
 
 (* goal context *)
 
 fun goal_context goal ctxt =
   let
     val ((_, params), ctxt') = ctxt
       |> Variable.declare_constraints goal
       |> Variable.improper_fixes
       |> Variable.focus_params NONE goal
       ||> Variable.restore_proper_fixes ctxt;
   in (params, ctxt') end;
 
 
 (* resolution after lifting and instantiation; may refer to parameters of the subgoal *)
 
 fun bires_inst_tac bires_flag ctxt raw_insts raw_fixes thm i st = CSUBGOAL (fn (cgoal, _) =>
   let
     (*goal context*)
     val (params, goal_ctxt) = goal_context (Thm.term_of cgoal) ctxt;
     val paramTs = map #2 params;
 
     (*instantiation context*)
     val ((inst_tvars, inst_vars), inst_ctxt) = read_insts thm raw_insts raw_fixes goal_ctxt;
     val fixed = map #1 (fold (Variable.add_newly_fixed inst_ctxt goal_ctxt o #2) inst_vars []);
 
 
     (* lift and instantiate rule *)
 
     val inc = Thm.maxidx_of st + 1;
     val lift_type = Logic.incr_tvar inc;
     fun lift_var ((a, j), T) = ((a, j + inc), paramTs ---> lift_type T);
     fun lift_term t = fold_rev Term.absfree params (Logic.incr_indexes (fixed, paramTs, inc) t);
 
     val inst_tvars' = inst_tvars
       |> map (fn (((a, i), S), T) => (((a, i + inc), S), Thm.ctyp_of inst_ctxt (lift_type T)));
     val inst_vars' = inst_vars
       |> map (fn (v, t) => (lift_var v, Thm.cterm_of inst_ctxt (lift_term t)));
 
     val thm' = Thm.lift_rule cgoal thm
       |> Drule.instantiate_normalize (inst_tvars', inst_vars')
       |> singleton (Variable.export inst_ctxt ctxt);
   in compose_tac ctxt (bires_flag, thm', Thm.nprems_of thm) i end) i st;
 
 val res_inst_tac = bires_inst_tac false;
 val eres_inst_tac = bires_inst_tac true;
 
 
 (* forward resolution *)
 
 fun make_elim_preserve ctxt rl =
   let
     val maxidx = Thm.maxidx_of rl;
     fun var x = ((x, 0), propT);
     fun cvar xi = Thm.cterm_of ctxt (Var (xi, propT));
     val revcut_rl' =
       Drule.instantiate_normalize ([], [(var "V", cvar ("V", maxidx + 1)),
         (var "W", cvar ("W", maxidx + 1))]) Drule.revcut_rl;
   in
     (case Seq.list_of
       (Thm.bicompose (SOME ctxt) {flatten = true, match = false, incremented = false}
         (false, rl, Thm.nprems_of rl) 1 revcut_rl')
      of
       [th] => th
     | _ => raise THM ("make_elim_preserve", 1, [rl]))
   end;
 
 (*instantiate and cut -- for atomic fact*)
 fun cut_inst_tac ctxt insts fixes rule =
   res_inst_tac ctxt insts fixes (make_elim_preserve ctxt rule);
 
 (*forward tactic applies a rule to an assumption without deleting it*)
 fun forw_inst_tac ctxt insts fixes rule =
   cut_inst_tac ctxt insts fixes rule THEN' assume_tac ctxt;
 
 (*dresolve tactic applies a rule to replace an assumption*)
 fun dres_inst_tac ctxt insts fixes rule =
   eres_inst_tac ctxt insts fixes (make_elim_preserve ctxt rule);
 
 
 (* derived tactics *)
 
 (*deletion of an assumption*)
 fun thin_tac ctxt s fixes =
   eres_inst_tac ctxt [((("V", 0), Position.none), s)] fixes Drule.thin_rl;
 
 (*Introduce the given proposition as lemma and subgoal*)
 fun subgoal_tac ctxt A fixes =
   DETERM o res_inst_tac ctxt [((("psi", 0), Position.none), A)] fixes cut_rl;
 
 
 (* method wrapper *)
 
 fun method inst_tac tac =
   Args.goal_spec -- Scan.optional (Scan.lift (named_insts --| Args.$$$ "in")) ([], []) --
   Attrib.thms >> (fn ((quant, (insts, fixes)), thms) => fn ctxt => METHOD (fn facts =>
     if null insts andalso null fixes
     then quant (Method.insert_tac ctxt facts THEN' tac ctxt thms)
     else
       (case thms of
         [thm] => quant (Method.insert_tac ctxt facts THEN' inst_tac ctxt insts fixes thm)
       | _ => error "Cannot have instantiations with multiple rules")));
 
 
 (* setup *)
 
 (*warning: rule_tac etc. refer to dynamic subgoal context!*)
 
 val _ = Theory.setup
  (Method.setup \<^binding>\<open>rule_tac\<close> (method res_inst_tac resolve_tac)
     "apply rule (dynamic instantiation)" #>
   Method.setup \<^binding>\<open>erule_tac\<close> (method eres_inst_tac eresolve_tac)
     "apply rule in elimination manner (dynamic instantiation)" #>
   Method.setup \<^binding>\<open>drule_tac\<close> (method dres_inst_tac dresolve_tac)
     "apply rule in destruct manner (dynamic instantiation)" #>
   Method.setup \<^binding>\<open>frule_tac\<close> (method forw_inst_tac forward_tac)
     "apply rule in forward manner (dynamic instantiation)" #>
   Method.setup \<^binding>\<open>cut_tac\<close> (method cut_inst_tac (K cut_rules_tac))
     "cut rule (dynamic instantiation)" #>
   Method.setup \<^binding>\<open>subgoal_tac\<close>
     (Args.goal_spec -- Scan.lift (Scan.repeat1 Args.embedded_inner_syntax -- Parse.for_fixes) >>
       (fn (quant, (props, fixes)) => fn ctxt =>
         SIMPLE_METHOD'' quant (EVERY' (map (fn prop => subgoal_tac ctxt prop fixes) props))))
     "insert subgoal (dynamic instantiation)" #>
   Method.setup \<^binding>\<open>thin_tac\<close>
     (Args.goal_spec -- Scan.lift (Args.embedded_inner_syntax -- Parse.for_fixes) >>
       (fn (quant, (prop, fixes)) => fn ctxt => SIMPLE_METHOD'' quant (thin_tac ctxt prop fixes)))
     "remove premise (dynamic instantiation)");
 
 end;
diff --git a/src/Pure/consts.ML b/src/Pure/consts.ML
--- a/src/Pure/consts.ML
+++ b/src/Pure/consts.ML
@@ -1,348 +1,348 @@
 (*  Title:      Pure/consts.ML
     Author:     Makarius
 
 Polymorphic constants: declarations, abbreviations, additional type
 constraints.
 *)
 
 signature CONSTS =
 sig
   type T
   val eq_consts: T * T -> bool
   val change_base: bool -> T -> T
   val change_ignore: T -> T
   val retrieve_abbrevs: T -> string list -> term -> (term * term) list
   val dest: T ->
    {const_space: Name_Space.T,
     constants: (string * (typ * term option)) list,
     constraints: (string * typ) list}
   val the_const: T -> string -> string * typ                   (*exception TYPE*)
   val the_abbreviation: T -> string -> typ * term              (*exception TYPE*)
   val type_scheme: T -> string -> typ                          (*exception TYPE*)
   val is_monomorphic: T -> string -> bool                      (*exception TYPE*)
   val the_constraint: T -> string -> typ                       (*exception TYPE*)
   val space_of: T -> Name_Space.T
   val alias: Name_Space.naming -> binding -> string -> T -> T
   val is_concealed: T -> string -> bool
   val intern: T -> xstring -> string
   val intern_syntax: T -> xstring -> string
   val check_const: Context.generic -> T -> xstring * Position.T list -> term * Position.report list
   val certify: Context.generic -> Type.tsig -> bool -> T -> term -> term  (*exception TYPE*)
   val typargs: T -> string * typ -> typ list
   val instance: T -> string * typ list -> typ
   val dummy_types: T -> term -> term
   val declare: Context.generic -> binding * typ -> T -> T
   val constrain: string * typ option -> T -> T
   val abbreviate: Context.generic -> Type.tsig -> string -> binding * term -> T -> (term * term) * T
   val revert_abbrev: string -> string -> T -> T
   val hide: bool -> string -> T -> T
   val empty: T
   val merge: T * T -> T
 end;
 
 structure Consts: CONSTS =
 struct
 
 (** consts type **)
 
 (* datatype T *)
 
 type decl = {T: typ, typargs: int list list};
 type abbrev = {rhs: term, normal_rhs: term, force_expand: bool};
 
 datatype T = Consts of
  {decls: (decl * abbrev option) Name_Space.table,
   constraints: typ Symtab.table,
   rev_abbrevs: (term * term) Item_Net.T Symtab.table};
 
 fun eq_consts
    (Consts {decls = decls1, constraints = constraints1, rev_abbrevs = rev_abbrevs1},
     Consts {decls = decls2, constraints = constraints2, rev_abbrevs = rev_abbrevs2}) =
   pointer_eq (decls1, decls2) andalso
   pointer_eq (constraints1, constraints2) andalso
   pointer_eq (rev_abbrevs1, rev_abbrevs2);
 
 fun make_consts (decls, constraints, rev_abbrevs) =
   Consts {decls = decls, constraints = constraints, rev_abbrevs = rev_abbrevs};
 
 fun map_consts f (Consts {decls, constraints, rev_abbrevs}) =
   make_consts (f (decls, constraints, rev_abbrevs));
 
 fun change_base begin = map_consts (fn (decls, constraints, rev_abbrevs) =>
   (Name_Space.change_base begin decls, constraints, rev_abbrevs));
 
 val change_ignore = map_consts (fn (decls, constraints, rev_abbrevs) =>
   (Name_Space.change_ignore decls, constraints, rev_abbrevs));
 
 
 (* reverted abbrevs *)
 
 val empty_abbrevs =
   Item_Net.init (fn ((t, u), (t', u')) => t aconv t' andalso u aconv u') (single o #1);
 
 fun update_abbrevs mode abbrs =
   Symtab.map_default (mode, empty_abbrevs) (Item_Net.update abbrs);
 
 fun retrieve_abbrevs (Consts {rev_abbrevs, ...}) modes =
   let val nets = map_filter (Symtab.lookup rev_abbrevs) modes in
     fn t =>
       let
         val retrieve =
           if Term.could_beta_eta_contract t
           then Item_Net.retrieve
           else Item_Net.retrieve_matching
       in maps (fn net => retrieve net t) nets end
   end;
 
 
 (* dest consts *)
 
 fun dest (Consts {decls, constraints, ...}) =
  {const_space = Name_Space.space_of_table decls,
   constants =
     Name_Space.fold_table (fn (c, ({T, ...}, abbr)) =>
       cons (c, (T, Option.map #rhs abbr))) decls [],
   constraints = Symtab.dest constraints};
 
 
 (* lookup consts *)
 
 fun the_entry (Consts {decls, ...}) c =
   (case Name_Space.lookup_key decls c of
     SOME entry => entry
   | NONE => raise TYPE ("Unknown constant: " ^ quote c, [], []));
 
 fun the_const consts c =
   (case the_entry consts c of
     (c', ({T, ...}, NONE)) => (c', T)
   | _ => raise TYPE ("Not a logical constant: " ^ quote c, [], []));
 
 fun the_abbreviation consts c =
   (case the_entry consts c of
     (_, ({T, ...}, SOME {rhs, ...})) => (T, rhs)
   | _ => raise TYPE ("Not an abbreviated constant: " ^ quote c, [], []));
 
 fun the_decl consts = #1 o #2 o the_entry consts;
 val type_scheme = #T oo the_decl;
 val type_arguments = #typargs oo the_decl;
 
 val is_monomorphic = null oo type_arguments;
 
 fun the_constraint (consts as Consts {constraints, ...}) c =
   (case Symtab.lookup constraints c of
     SOME T => T
   | NONE => type_scheme consts c);
 
 
 (* name space and syntax *)
 
 fun space_of (Consts {decls, ...}) = Name_Space.space_of_table decls;
 
 fun alias naming binding name = map_consts (fn (decls, constraints, rev_abbrevs) =>
   ((Name_Space.alias_table naming binding name decls), constraints, rev_abbrevs));
 
 val is_concealed = Name_Space.is_concealed o space_of;
 
 val intern = Name_Space.intern o space_of;
 
 fun intern_syntax consts s =
   (case try Lexicon.unmark_const s of
     SOME c => c
   | NONE => intern consts s);
 
 
 (* check_const *)
 
 fun check_const context consts (xname, ps) =
   let
     val Consts {decls, ...} = consts;
     val ((c, reports), _) = Name_Space.check_reports context decls (xname, ps);
     val T = type_scheme consts c handle TYPE (msg, _, _) => error (msg ^ Position.here_list ps);
   in (Const (c, T), reports) end;
 
 
 (* certify *)
 
 fun certify context tsig do_expand consts =
   let
     fun err msg (c, T) =
       raise TYPE (msg ^ " " ^ quote c ^ " :: " ^
         Syntax.string_of_typ (Syntax.init_pretty context) T, [], []);
     val certT = Type.cert_typ tsig;
     fun cert tm =
       let
         val (head, args) = Term.strip_comb tm;
         val args' = map cert args;
         fun comb head' = Term.list_comb (head', args');
       in
         (case head of
           Abs (x, T, t) => comb (Abs (x, certT T, cert t))
         | Const (c, T) =>
             let
               val T' = certT T;
               val (_, ({T = U, ...}, abbr)) = the_entry consts c;
               fun expand u =
                 Term.betapplys (Envir.expand_atom T' (U, u) handle TYPE _ =>
                   err "Illegal type for abbreviation" (c, T), args');
             in
               if not (Type.raw_instance (T', U)) then
                 err "Illegal type for constant" (c, T)
               else
                 (case abbr of
                   SOME {rhs, normal_rhs, force_expand} =>
                     if do_expand then expand normal_rhs
                     else if force_expand then expand rhs
                     else comb head
                 | _ => comb head)
             end
         | _ => comb head)
       end;
   in cert end;
 
 
 (* typargs -- view actual const type as instance of declaration *)
 
 local
 
 fun args_of (Type (_, Ts)) pos = args_of_list Ts 0 pos
   | args_of (TVar v) pos = insert (eq_fst op =) (v, rev pos)
   | args_of (TFree _) _ = I
 and args_of_list (T :: Ts) i is = args_of T (i :: is) #> args_of_list Ts (i + 1) is
   | args_of_list [] _ _ = I;
 
 fun subscript (Type (_, Ts)) (i :: is) = subscript (nth Ts i) is
   | subscript T [] = T
   | subscript _ _ = raise Subscript;
 
 in
 
 fun typargs_of T = map #2 (rev (args_of T [] []));
 
 fun typargs consts (c, T) = map (subscript T) (type_arguments consts c);
 
 end;
 
 fun instance consts (c, Ts) =
   let
     val declT = type_scheme consts c;
     val args = typargs consts (c, declT);
     val inst =
-      fold2 (fn a => fn T => Term_Subst.TVars.add (Term.dest_TVar a, T))
-        args Ts Term_Subst.TVars.empty
+      Term_Subst.TVars.build
+        (fold2 (fn a => fn T => Term_Subst.TVars.add (Term.dest_TVar a, T)) args Ts)
       handle ListPair.UnequalLengths => raise TYPE ("Consts.instance", Ts, [Const (c, dummyT)]);
   in declT |> Term_Subst.instantiateT inst end;
 
 fun dummy_types consts =
   let
     fun dummy (Const (c, T)) =
           Const (c, instance consts (c, replicate (length (typargs consts (c, T))) dummyT))
       | dummy (Free (x, _)) = Free (x, dummyT)
       | dummy (Var (xi, _)) = Var (xi, dummyT)
       | dummy (b as Bound _) = b
       | dummy (t $ u) = dummy t $ dummy u
       | dummy (Abs (a, _, b)) = Abs (a, dummyT, dummy b);
   in dummy end;
 
 
 
 (** build consts **)
 
 (* name space *)
 
 fun hide fully c = map_consts (fn (decls, constraints, rev_abbrevs) =>
   (Name_Space.hide_table fully c decls, constraints, rev_abbrevs));
 
 
 (* declarations *)
 
 fun declare context (b, declT) =
   map_consts (fn (decls, constraints, rev_abbrevs) =>
     let
       val decl = {T = declT, typargs = typargs_of declT};
       val _ = Binding.check b;
       val (_, decls') = decls |> Name_Space.define context true (b, (decl, NONE));
     in (decls', constraints, rev_abbrevs) end);
 
 
 (* constraints *)
 
 fun constrain (c, C) consts =
   consts |> map_consts (fn (decls, constraints, rev_abbrevs) =>
     (#2 (the_entry consts c) handle TYPE (msg, _, _) => error msg;
       (decls,
         constraints |> (case C of SOME T => Symtab.update (c, T) | NONE => Symtab.delete_safe c),
         rev_abbrevs)));
 
 
 (* abbreviations *)
 
 local
 
 fun strip_abss (t as Abs (x, T, b)) =
       if Term.is_dependent b then strip_abss b |>> cons (x, T)  (* FIXME decr!? *)
       else ([], t)
   | strip_abss t = ([], t);
 
 fun rev_abbrev lhs rhs =
   let
     val (xs, body) = strip_abss (Envir.beta_eta_contract rhs);
     val vars = fold (fn (x, T) => cons (Var ((x, 0), T))) (Term.rename_wrt_term body xs) [];
   in (Term.subst_bounds (rev vars, body), Term.list_comb (lhs, vars)) end;
 
 in
 
 fun abbreviate context tsig mode (b, raw_rhs) consts =
   let
     val cert_term = certify context tsig false consts;
     val expand_term = certify context tsig true consts;
     val force_expand = mode = Print_Mode.internal;
 
     val _ = Term.exists_subterm Term.is_Var raw_rhs andalso
       error ("Illegal schematic variables on rhs of abbreviation " ^ Binding.print b);
 
     val rhs = raw_rhs
       |> Term.map_types (Type.cert_typ tsig)
       |> cert_term
       |> Term.close_schematic_term;
     val normal_rhs = expand_term rhs;
     val T = Term.fastype_of rhs;
     val lhs = Const (Name_Space.full_name (Name_Space.naming_of context) b, T);
   in
     consts |> map_consts (fn (decls, constraints, rev_abbrevs) =>
       let
         val decl = {T = T, typargs = typargs_of T};
         val abbr = {rhs = rhs, normal_rhs = normal_rhs, force_expand = force_expand};
         val _ = Binding.check b;
         val (_, decls') = decls
           |> Name_Space.define context true (b, (decl, SOME abbr));
         val rev_abbrevs' = rev_abbrevs
           |> update_abbrevs mode (rev_abbrev lhs rhs);
       in (decls', constraints, rev_abbrevs') end)
     |> pair (lhs, rhs)
   end;
 
 fun revert_abbrev mode c consts = consts |> map_consts (fn (decls, constraints, rev_abbrevs) =>
   let
     val (T, rhs) = the_abbreviation consts c;
     val rev_abbrevs' = rev_abbrevs
       |> update_abbrevs mode (rev_abbrev (Const (c, T)) rhs);
   in (decls, constraints, rev_abbrevs') end);
 
 end;
 
 
 (* empty and merge *)
 
 val empty =
   make_consts (Name_Space.empty_table Markup.constantN, Symtab.empty, Symtab.empty);
 
 fun merge
    (Consts {decls = decls1, constraints = constraints1, rev_abbrevs = rev_abbrevs1},
     Consts {decls = decls2, constraints = constraints2, rev_abbrevs = rev_abbrevs2}) =
   let
     val decls' = Name_Space.merge_tables (decls1, decls2);
     val constraints' = Symtab.merge (K true) (constraints1, constraints2);
     val rev_abbrevs' = Symtab.join (K Item_Net.merge) (rev_abbrevs1, rev_abbrevs2);
   in make_consts (decls', constraints', rev_abbrevs') end;
 
 end;
diff --git a/src/Pure/defs.ML b/src/Pure/defs.ML
--- a/src/Pure/defs.ML
+++ b/src/Pure/defs.ML
@@ -1,283 +1,283 @@
 (*  Title:      Pure/defs.ML
     Author:     Makarius
 
 Global well-formedness checks for overloaded definitions (mixed constants and
 types). Recall that constant definitions may be explained syntactically within
 Pure, but type definitions require particular set-theoretic semantics.
 *)
 
 signature DEFS =
 sig
   datatype item_kind = Const | Type
   type item = item_kind * string
   type entry = item * typ list
   val item_kind_ord: item_kind ord
   val plain_args: typ list -> bool
   type context = Proof.context * (Name_Space.T * Name_Space.T)
   val global_context: theory -> context
   val space: context -> item_kind -> Name_Space.T
   val pretty_item: context -> item -> Pretty.T
   val pretty_args: Proof.context -> typ list -> Pretty.T list
   val pretty_entry: context -> entry -> Pretty.T
   type T
   type spec =
    {def: string option,
     description: string,
     pos: Position.T,
     lhs: typ list,
     rhs: entry list}
   val all_specifications_of: T -> (item * spec list) list
   val specifications_of: T -> item -> spec list
   val dest: T ->
    {restricts: (entry * string) list,
     reducts: (entry * entry list) list}
   val dest_constdefs: T list -> T -> (string * string) list
   val empty: T
   val merge: context -> T * T -> T
   val define: context -> bool -> string option -> string -> entry -> entry list -> T -> T
   val get_deps: T -> item -> (typ list * entry list) list
 end;
 
 structure Defs: DEFS =
 struct
 
 (* specification items *)
 
 datatype item_kind = Const | Type;
 type item = item_kind * string;
 type entry = item * typ list;
 
 fun item_kind_ord (Const, Type) = LESS
   | item_kind_ord (Type, Const) = GREATER
   | item_kind_ord _ = EQUAL;
 
 structure Itemtab = Table(type key = item val ord = prod_ord item_kind_ord fast_string_ord);
 
 
 (* pretty printing *)
 
 type context = Proof.context * (Name_Space.T * Name_Space.T);
 
 fun global_context thy =
   (Syntax.init_pretty_global thy, (Sign.const_space thy, Sign.type_space thy));
 
 fun space ((_, spaces): context) kind =
   if kind = Const then #1 spaces else #2 spaces;
 
 fun pretty_item (context as (ctxt, _)) (kind, name) =
   let val prt_name = Name_Space.pretty ctxt (space context kind) name in
     if kind = Const then prt_name
     else Pretty.block [Pretty.keyword1 "type", Pretty.brk 1, prt_name]
   end;
 
 fun pretty_args ctxt args =
   if null args then []
   else [Pretty.list "(" ")" (map (Syntax.pretty_typ ctxt o Logic.unvarifyT_global) args)];
 
 fun pretty_entry context (c, args) =
   Pretty.block (pretty_item context c :: pretty_args (#1 context) args);
 
 
 (* type arguments *)
 
 fun plain_args args =
   forall Term.is_TVar args andalso not (has_duplicates (op =) args);
 
 fun disjoint_args (Ts, Us) =
   not (Type.could_unifys (Ts, Us)) orelse
-    ((Type.raw_unifys (Ts, map (Logic.incr_tvar (maxidx_of_typs Ts + 1)) Us) Vartab.empty; false)
+    ((Vartab.build (Type.raw_unifys (Ts, map (Logic.incr_tvar (maxidx_of_typs Ts + 1)) Us)); false)
       handle Type.TUNIFY => true);
 
 fun match_args (Ts, Us) =
   if Type.could_matches (Ts, Us) then
     Option.map Envir.subst_type
-      (SOME (Type.raw_matches (Ts, Us) Vartab.empty) handle Type.TYPE_MATCH => NONE)
+      (SOME (Vartab.build (Type.raw_matches (Ts, Us))) handle Type.TYPE_MATCH => NONE)
   else NONE;
 
 
 (* datatype defs *)
 
 type spec =
  {def: string option,
   description: string,
   pos: Position.T,
   lhs: typ list,
   rhs: entry list};
 
 type def =
  {specs: spec Inttab.table,  (*source specifications*)
   restricts: (typ list * string) list,  (*global restrictions imposed by incomplete patterns*)
   reducts: (typ list * entry list) list};  (*specifications as reduction system*)
 
 fun make_def (specs, restricts, reducts) =
   {specs = specs, restricts = restricts, reducts = reducts}: def;
 
 fun map_def c f =
   Itemtab.default (c, make_def (Inttab.empty, [], [])) #>
   Itemtab.map_entry c (fn {specs, restricts, reducts}: def =>
     make_def (f (specs, restricts, reducts)));
 
 
 datatype T = Defs of def Itemtab.table;
 
 fun lookup_list which defs c =
   (case Itemtab.lookup defs c of
     SOME (def: def) => which def
   | NONE => []);
 
 fun all_specifications_of (Defs defs) =
   (map o apsnd) (map snd o Inttab.dest o #specs) (Itemtab.dest defs);
 
 fun specifications_of (Defs defs) = lookup_list (map snd o Inttab.dest o #specs) defs;
 
 val restricts_of = lookup_list #restricts;
 val reducts_of = lookup_list #reducts;
 
 fun dest (Defs defs) =
   let
     val restricts = Itemtab.fold (fn (c, {restricts, ...}) =>
       fold (fn (args, description) => cons ((c, args), description)) restricts) defs [];
     val reducts = Itemtab.fold (fn (c, {reducts, ...}) =>
       fold (fn (args, deps) => cons ((c, args), deps)) reducts) defs [];
   in {restricts = restricts, reducts = reducts} end;
 
 fun dest_constdefs prevs (Defs defs) =
   let
     fun prev_spec c i = prevs |> exists (fn Defs prev_defs =>
       (case Itemtab.lookup prev_defs c of
         NONE => false
       | SOME {specs, ...} => Inttab.defined specs i));
   in
     (defs, []) |-> Itemtab.fold (fn (c, {specs, ...}) =>
       specs |> Inttab.fold (fn (i, spec) =>
         if #1 c = Const andalso is_some (#def spec) andalso not (prev_spec c i)
         then cons (#2 c, the (#def spec)) else I))
   end;
 
 val empty = Defs Itemtab.empty;
 
 
 (* specifications *)
 
 fun disjoint_specs context c (i, {description = a, pos = pos_a, lhs = Ts, ...}: spec) =
   Inttab.forall (fn (j, {description = b, pos = pos_b, lhs = Us, ...}: spec) =>
     i = j orelse disjoint_args (Ts, Us) orelse
       error ("Clash of specifications for " ^
         Pretty.unformatted_string_of (pretty_item context c) ^ ":\n" ^
         "  " ^ quote a ^ Position.here pos_a ^ "\n" ^
         "  " ^ quote b ^ Position.here pos_b));
 
 fun join_specs context c ({specs = specs1, restricts, reducts}, {specs = specs2, ...}: def) =
   let
     val specs' =
       Inttab.fold (fn spec2 => (disjoint_specs context c spec2 specs1; Inttab.update spec2))
         specs2 specs1;
   in make_def (specs', restricts, reducts) end;
 
 fun update_specs context c spec = map_def c (fn (specs, restricts, reducts) =>
   (disjoint_specs context c spec specs; (Inttab.update spec specs, restricts, reducts)));
 
 
 (* normalized dependencies: reduction with well-formedness check *)
 
 local
 
 val prt = Pretty.string_of oo pretty_entry;
 
 fun err context (c, Ts) (d, Us) s1 s2 =
   error (s1 ^ " dependency of " ^ prt context (c, Ts) ^ " -> " ^ prt context (d, Us) ^ s2);
 
 fun acyclic context (c, Ts) (d, Us) =
   c <> d orelse
   is_none (match_args (Ts, Us)) orelse
   err context (c, Ts) (d, Us) "Circular" "";
 
 fun reduction context defs const deps =
   let
     fun reduct Us (Ts, rhs) =
       (case match_args (Ts, Us) of
         NONE => NONE
       | SOME subst => SOME (map (apsnd (map subst)) rhs));
     fun reducts (d, Us) = get_first (reduct Us) (reducts_of defs d);
 
     val reds = map (`reducts) deps;
     val deps' =
       if forall (is_none o #1) reds then NONE
       else SOME (fold_rev
         (fn (NONE, dp) => insert (op =) dp | (SOME dps, _) => fold (insert (op =)) dps) reds []);
     val _ = forall (acyclic context const) (the_default deps deps');
   in deps' end;
 
 fun restriction context defs (c, Ts) (d, Us) =
   plain_args Us orelse
   (case find_first (fn (Rs, _) => not (disjoint_args (Rs, Us))) (restricts_of defs d) of
     SOME (Rs, description) =>
       err context (c, Ts) (d, Us) "Malformed"
         ("\n(restriction " ^ prt context (d, Rs) ^ " from " ^ quote description ^ ")")
   | NONE => true);
 
 in
 
 fun normalize context =
   let
     fun check_def defs (c, {reducts, ...}: def) =
       reducts |> forall (fn (Ts, deps) => forall (restriction context defs (c, Ts)) deps);
     fun check_defs defs = Itemtab.forall (check_def defs) defs;
 
     fun norm_update (c, {reducts, ...}: def) (changed, defs) =
       let
         val reducts' = reducts |> map (fn (Ts, deps) =>
           (Ts, perhaps (reduction context defs (c, Ts)) deps));
       in
         if reducts = reducts' then (changed, defs)
         else (true, defs |> map_def c (fn (specs, restricts, _) => (specs, restricts, reducts')))
       end;
     fun norm_loop defs =
       (case Itemtab.fold norm_update defs (false, defs) of
         (true, defs') => norm_loop defs'
       | (false, _) => defs);
   in norm_loop #> tap check_defs end;
 
 fun dependencies context (c, args) restr deps =
   map_def c (fn (specs, restricts, reducts) =>
     let
       val restricts' = Library.merge (op =) (restricts, restr);
       val reducts' = insert (op =) (args, deps) reducts;
     in (specs, restricts', reducts') end)
   #> normalize context;
 
 end;
 
 
 (* merge *)
 
 fun merge context (Defs defs1, Defs defs2) =
   let
     fun add_deps (c, args) restr deps defs =
       if AList.defined (op =) (reducts_of defs c) args then defs
       else dependencies context (c, args) restr deps defs;
     fun add_def (c, {restricts, reducts, ...}: def) =
       fold (fn (args, deps) => add_deps (c, args) restricts deps) reducts;
   in
     Defs (Itemtab.join (join_specs context) (defs1, defs2)
       |> normalize context |> Itemtab.fold add_def defs2)
   end;
 
 
 (* define *)
 
 fun define context unchecked def description (c, args) deps (Defs defs) =
   let
     val pos = Position.thread_data ();
     val restr =
       if plain_args args orelse
         (case args of [Term.Type (_, rec_args)] => plain_args rec_args | _ => false)
       then [] else [(args, description)];
     val spec =
       (serial (), {def = def, description = description, pos = pos, lhs = args, rhs = deps});
     val defs' = defs |> update_specs context c spec;
   in Defs (defs' |> (if unchecked then I else dependencies context (c, args) restr deps)) end;
 
 fun get_deps (Defs defs) c = reducts_of defs c;
 
 end;
diff --git a/src/Pure/drule.ML b/src/Pure/drule.ML
--- a/src/Pure/drule.ML
+++ b/src/Pure/drule.ML
@@ -1,843 +1,843 @@
 (*  Title:      Pure/drule.ML
     Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
 
 Derived rules and other operations on theorems.
 *)
 
 infix 0 RL RLN MRS OF COMP INCR_COMP COMP_INCR;
 
 signature BASIC_DRULE =
 sig
   val mk_implies: cterm * cterm -> cterm
   val list_implies: cterm list * cterm -> cterm
   val strip_imp_prems: cterm -> cterm list
   val strip_imp_concl: cterm -> cterm
   val cprems_of: thm -> cterm list
   val forall_intr_list: cterm list -> thm -> thm
   val forall_intr_vars: thm -> thm
   val forall_elim_list: cterm list -> thm -> thm
   val lift_all: Proof.context -> cterm -> thm -> thm
   val implies_elim_list: thm -> thm list -> thm
   val implies_intr_list: cterm list -> thm -> thm
   val instantiate_normalize: ((indexname * sort) * ctyp) list * ((indexname * typ) * cterm) list ->
     thm -> thm
   val instantiate'_normalize: ctyp option list -> cterm option list -> thm -> thm
   val infer_instantiate_types: Proof.context -> ((indexname * typ) * cterm) list -> thm -> thm
   val infer_instantiate: Proof.context -> (indexname * cterm) list -> thm -> thm
   val infer_instantiate': Proof.context -> cterm option list -> thm -> thm
   val zero_var_indexes_list: thm list -> thm list
   val zero_var_indexes: thm -> thm
   val implies_intr_hyps: thm -> thm
   val rotate_prems: int -> thm -> thm
   val rearrange_prems: int list -> thm -> thm
   val RLN: thm list * (int * thm list) -> thm list
   val RL: thm list * thm list -> thm list
   val MRS: thm list * thm -> thm
   val OF: thm * thm list -> thm
   val COMP: thm * thm -> thm
   val INCR_COMP: thm * thm -> thm
   val COMP_INCR: thm * thm -> thm
   val size_of_thm: thm -> int
   val reflexive_thm: thm
   val symmetric_thm: thm
   val transitive_thm: thm
   val extensional: thm -> thm
   val asm_rl: thm
   val cut_rl: thm
   val revcut_rl: thm
   val thin_rl: thm
 end;
 
 signature DRULE =
 sig
   include BASIC_DRULE
   val outer_params: term -> (string * typ) list
   val generalize: Symtab.set * Symtab.set -> thm -> thm
   val list_comb: cterm * cterm list -> cterm
   val strip_comb: cterm -> cterm * cterm list
   val beta_conv: cterm -> cterm -> cterm
   val flexflex_unique: Proof.context option -> thm -> thm
   val export_without_context: thm -> thm
   val export_without_context_open: thm -> thm
   val store_thm: binding -> thm -> thm
   val store_standard_thm: binding -> thm -> thm
   val store_thm_open: binding -> thm -> thm
   val store_standard_thm_open: binding -> thm -> thm
   val multi_resolve: Proof.context option -> thm list -> thm -> thm Seq.seq
   val multi_resolves: Proof.context option -> thm list -> thm list -> thm Seq.seq
   val compose: thm * int * thm -> thm
   val equals_cong: thm
   val imp_cong: thm
   val swap_prems_eq: thm
   val imp_cong_rule: thm -> thm -> thm
   val arg_cong_rule: cterm -> thm -> thm
   val binop_cong_rule: cterm -> thm -> thm -> thm
   val fun_cong_rule: thm -> cterm -> thm
   val beta_eta_conversion: cterm -> thm
   val eta_contraction_rule: thm -> thm
   val norm_hhf_eq: thm
   val norm_hhf_eqs: thm list
   val is_norm_hhf: term -> bool
   val norm_hhf: theory -> term -> term
   val norm_hhf_cterm: Proof.context -> cterm -> cterm
   val protect: cterm -> cterm
   val protectI: thm
   val protectD: thm
   val protect_cong: thm
   val implies_intr_protected: cterm list -> thm -> thm
   val termI: thm
   val mk_term: cterm -> thm
   val dest_term: thm -> cterm
   val cterm_rule: (thm -> thm) -> cterm -> cterm
   val cterm_add_frees: cterm -> cterm list -> cterm list
   val cterm_add_vars: cterm -> cterm list -> cterm list
   val dummy_thm: thm
   val free_dummy_thm: thm
   val is_sort_constraint: term -> bool
   val sort_constraintI: thm
   val sort_constraint_eq: thm
   val with_subgoal: int -> (thm -> thm) -> thm -> thm
   val comp_no_flatten: thm * int -> int -> thm -> thm
   val rename_bvars: (string * string) list -> thm -> thm
   val rename_bvars': string option list -> thm -> thm
   val incr_indexes: thm -> thm -> thm
   val incr_indexes2: thm -> thm -> thm -> thm
   val triv_forall_equality: thm
   val distinct_prems_rl: thm
   val equal_intr_rule: thm
   val equal_elim_rule1: thm
   val equal_elim_rule2: thm
   val remdups_rl: thm
   val abs_def: thm -> thm
 end;
 
 structure Drule: DRULE =
 struct
 
 
 (** some cterm->cterm operations: faster than calling cterm_of! **)
 
 (* A1\<Longrightarrow>...An\<Longrightarrow>B  goes to  [A1,...,An], where B is not an implication *)
 fun strip_imp_prems ct =
   let val (cA, cB) = Thm.dest_implies ct
   in cA :: strip_imp_prems cB end
   handle TERM _ => [];
 
 (* A1\<Longrightarrow>...An\<Longrightarrow>B  goes to B, where B is not an implication *)
 fun strip_imp_concl ct =
   (case Thm.term_of ct of
     Const ("Pure.imp", _) $ _ $ _ => strip_imp_concl (Thm.dest_arg ct)
   | _ => ct);
 
 (*The premises of a theorem, as a cterm list*)
 val cprems_of = strip_imp_prems o Thm.cprop_of;
 
 fun certify t = Thm.global_cterm_of (Context.the_global_context ()) t;
 
 val implies = certify Logic.implies;
 fun mk_implies (A, B) = Thm.apply (Thm.apply implies A) B;
 
 (*cterm version of list_implies: [A1,...,An], B  goes to \<lbrakk>A1;...;An\<rbrakk>\<Longrightarrow>B *)
 fun list_implies([], B) = B
   | list_implies(A::As, B) = mk_implies (A, list_implies(As,B));
 
 (*cterm version of list_comb: maps  (f, [t1,...,tn])  to  f(t1,...,tn) *)
 fun list_comb (f, []) = f
   | list_comb (f, t::ts) = list_comb (Thm.apply f t, ts);
 
 (*cterm version of strip_comb: maps  f(t1,...,tn)  to  (f, [t1,...,tn]) *)
 fun strip_comb ct =
   let
     fun stripc (p as (ct, cts)) =
       let val (ct1, ct2) = Thm.dest_comb ct
       in stripc (ct1, ct2 :: cts) end handle CTERM _ => p
   in stripc (ct, []) end;
 
 (*Beta-conversion for cterms, where x is an abstraction. Simply returns the rhs
   of the meta-equality returned by the beta_conversion rule.*)
 fun beta_conv x y =
   Thm.dest_arg (Thm.cprop_of (Thm.beta_conversion false (Thm.apply x y)));
 
 
 
 (** Standardization of rules **)
 
 (*Generalization over a list of variables*)
 val forall_intr_list = fold_rev Thm.forall_intr;
 
 (*Generalization over Vars -- canonical order*)
 fun forall_intr_vars th = fold Thm.forall_intr (Thm.add_vars th []) th;
 
 fun outer_params t =
   let val vs = Term.strip_all_vars t
   in Name.variant_list [] (map (Name.clean o #1) vs) ~~ map #2 vs end;
 
 (*lift vars wrt. outermost goal parameters
   -- reverses the effect of gen_all modulo higher-order unification*)
 fun lift_all ctxt raw_goal raw_th =
   let
     val thy = Proof_Context.theory_of ctxt;
     val goal = Thm.transfer_cterm thy raw_goal;
     val th = Thm.transfer thy raw_th;
 
     val maxidx = Thm.maxidx_of th;
     val ps = outer_params (Thm.term_of goal)
       |> map (fn (x, T) => Var ((x, maxidx + 1), Logic.incr_tvar (maxidx + 1) T));
     val Ts = map Term.fastype_of ps;
     val inst =
-      (th, Term_Subst.Vars.empty) |-> (Thm.fold_terms o Term.fold_aterms)
+      Term_Subst.Vars.build (th |> (Thm.fold_terms o Term.fold_aterms)
         (fn t => fn inst =>
           (case t of
             Var (xi, T) =>
               if Term_Subst.Vars.defined inst (xi, T) then inst
               else
                 let val ct = Thm.cterm_of ctxt (Term.list_comb (Var (xi, Ts ---> T), ps))
                 in Term_Subst.Vars.update ((xi, T), ct) inst end
-          | _ => inst));
+          | _ => inst)));
   in
     th
     |> Thm.instantiate ([], Term_Subst.Vars.dest inst)
     |> fold_rev (Thm.forall_intr o Thm.cterm_of ctxt) ps
   end;
 
 (*direct generalization*)
 fun generalize names th = Thm.generalize names (Thm.maxidx_of th + 1) th;
 
 (*specialization over a list of cterms*)
 val forall_elim_list = fold Thm.forall_elim;
 
 (*maps A1,...,An |- B  to  \<lbrakk>A1;...;An\<rbrakk> \<Longrightarrow> B*)
 val implies_intr_list = fold_rev Thm.implies_intr;
 
 (*maps \<lbrakk>A1;...;An\<rbrakk> \<Longrightarrow> B and [A1,...,An]  to  B*)
 fun implies_elim_list impth ths = fold Thm.elim_implies ths impth;
 
 (*Reset Var indexes to zero, renaming to preserve distinctness*)
 fun zero_var_indexes_list [] = []
   | zero_var_indexes_list ths =
       let
         val (instT, inst) =
           Term_Subst.zero_var_indexes_inst Name.context (map Thm.full_prop_of ths);
 
         val tvars = fold Thm.add_tvars ths [];
         fun the_tvar v = the (find_first (fn cT => v = dest_TVar (Thm.typ_of cT)) tvars);
         val instT' =
           (instT, []) |-> Term_Subst.TVars.fold (fn (v, TVar (b, _)) =>
             cons (v, Thm.rename_tvar b (the_tvar v)));
 
         val vars = fold (Thm.add_vars o Thm.instantiate (instT', [])) ths [];
         fun the_var v = the (find_first (fn ct => v = dest_Var (Thm.term_of ct)) vars);
         val inst' =
           (inst, []) |-> Term_Subst.Vars.fold (fn (v, Var (b, _)) =>
             cons (v, Thm.var (b, Thm.ctyp_of_cterm (the_var v))));
       in map (Thm.adjust_maxidx_thm ~1 o Thm.instantiate (instT', inst')) ths end;
 
 val zero_var_indexes = singleton zero_var_indexes_list;
 
 
 (** Standard form of object-rule: no hypotheses, flexflex constraints,
     Frees, or outer quantifiers; all generality expressed by Vars of index 0.**)
 
 (*Discharge all hypotheses.*)
 fun implies_intr_hyps th = fold Thm.implies_intr (Thm.chyps_of th) th;
 
 (*Squash a theorem's flexflex constraints provided it can be done uniquely.
   This step can lose information.*)
 fun flexflex_unique opt_ctxt th =
   if null (Thm.tpairs_of th) then th
   else
     (case distinct Thm.eq_thm (Seq.list_of (Thm.flexflex_rule opt_ctxt th)) of
       [th] => th
     | [] => raise THM ("flexflex_unique: impossible constraints", 0, [th])
     | _ => raise THM ("flexflex_unique: multiple unifiers", 0, [th]));
 
 
 (* old-style export without context *)
 
 val export_without_context_open =
   implies_intr_hyps
   #> Thm.forall_intr_frees
   #> `Thm.maxidx_of
   #-> (fn maxidx =>
     Thm.forall_elim_vars (maxidx + 1)
     #> Thm.strip_shyps
     #> zero_var_indexes
     #> Thm.varifyT_global);
 
 val export_without_context =
   flexflex_unique NONE
   #> export_without_context_open
   #> Thm.close_derivation \<^here>;
 
 
 (*Rotates a rule's premises to the left by k*)
 fun rotate_prems 0 = I
   | rotate_prems k = Thm.permute_prems 0 k;
 
 fun with_subgoal i f = rotate_prems (i - 1) #> f #> rotate_prems (1 - i);
 
 (*Permute prems, where the i-th position in the argument list (counting from 0)
   gives the position within the original thm to be transferred to position i.
   Any remaining trailing positions are left unchanged.*)
 val rearrange_prems =
   let
     fun rearr new [] thm = thm
       | rearr new (p :: ps) thm =
           rearr (new + 1)
             (map (fn q => if new <= q andalso q < p then q + 1 else q) ps)
             (Thm.permute_prems (new + 1) (new - p) (Thm.permute_prems new (p - new) thm))
   in rearr 0 end;
 
 
 (*Resolution: multiple arguments, multiple results*)
 local
   fun res opt_ctxt th i rule =
     (Thm.biresolution opt_ctxt false [(false, th)] i rule handle THM _ => Seq.empty)
     |> Seq.map Thm.solve_constraints;
 
   fun multi_res _ _ [] rule = Seq.single rule
     | multi_res opt_ctxt i (th :: ths) rule =
         Seq.maps (res opt_ctxt th i) (multi_res opt_ctxt (i + 1) ths rule);
 in
   fun multi_resolve opt_ctxt = multi_res opt_ctxt 1;
   fun multi_resolves opt_ctxt facts rules =
     Seq.maps (multi_resolve opt_ctxt facts) (Seq.of_list rules);
 end;
 
 (*For joining lists of rules*)
 fun thas RLN (i, thbs) =
   let
     val resolve = Thm.biresolution NONE false (map (pair false) thas) i
     fun resb thb = Seq.list_of (resolve thb) handle THM _ => []
   in maps resb thbs |> map Thm.solve_constraints end;
 
 fun thas RL thbs = thas RLN (1, thbs);
 
 (*Isar-style multi-resolution*)
 fun bottom_rl OF rls =
   (case Seq.chop 2 (multi_resolve NONE rls bottom_rl) of
     ([th], _) => Thm.solve_constraints th
   | ([], _) => raise THM ("OF: no unifiers", 0, bottom_rl :: rls)
   | _ => raise THM ("OF: multiple unifiers", 0, bottom_rl :: rls));
 
 (*Resolve a list of rules against bottom_rl from right to left;
   makes proof trees*)
 fun rls MRS bottom_rl = bottom_rl OF rls;
 
 (*compose Q and \<lbrakk>...,Qi,Q(i+1),...\<rbrakk> \<Longrightarrow> R to \<lbrakk>...,Q(i+1),...\<rbrakk> \<Longrightarrow> R
   with no lifting or renaming!  Q may contain \<Longrightarrow> or meta-quantifiers
   ALWAYS deletes premise i *)
 fun compose (tha, i, thb) =
   Thm.bicompose NONE {flatten = true, match = false, incremented = false} (false, tha, 0) i thb
   |> Seq.list_of |> distinct Thm.eq_thm
   |> (fn [th] => Thm.solve_constraints th
        | _ => raise THM ("compose: unique result expected", i, [tha, thb]));
 
 
 (** theorem equality **)
 
 (*Useful "distance" function for BEST_FIRST*)
 val size_of_thm = size_of_term o Thm.full_prop_of;
 
 
 
 (*** Meta-Rewriting Rules ***)
 
 val read_prop = certify o Simple_Syntax.read_prop;
 
 fun store_thm name th =
   Context.>>> (Context.map_theory_result (Global_Theory.store_thm (name, th)));
 
 fun store_thm_open name th =
   Context.>>> (Context.map_theory_result (Global_Theory.store_thm_open (name, th)));
 
 fun store_standard_thm name th = store_thm name (export_without_context th);
 fun store_standard_thm_open name th = store_thm_open name (export_without_context_open th);
 
 val reflexive_thm =
   let val cx = certify (Var(("x",0),TVar(("'a",0),[])))
   in store_standard_thm_open (Binding.make ("reflexive", \<^here>)) (Thm.reflexive cx) end;
 
 val symmetric_thm =
   let
     val xy = read_prop "x::'a \<equiv> y::'a";
     val thm = Thm.implies_intr xy (Thm.symmetric (Thm.assume xy));
   in store_standard_thm_open (Binding.make ("symmetric", \<^here>)) thm end;
 
 val transitive_thm =
   let
     val xy = read_prop "x::'a \<equiv> y::'a";
     val yz = read_prop "y::'a \<equiv> z::'a";
     val xythm = Thm.assume xy;
     val yzthm = Thm.assume yz;
     val thm = Thm.implies_intr yz (Thm.transitive xythm yzthm);
   in store_standard_thm_open (Binding.make ("transitive", \<^here>)) thm end;
 
 fun extensional eq =
   let val eq' =
     Thm.abstract_rule "x" (Thm.dest_arg (fst (Thm.dest_equals (Thm.cprop_of eq)))) eq
   in Thm.equal_elim (Thm.eta_conversion (Thm.cprop_of eq')) eq' end;
 
 val equals_cong =
   store_standard_thm_open (Binding.make ("equals_cong", \<^here>))
     (Thm.reflexive (read_prop "x::'a \<equiv> y::'a"));
 
 val imp_cong =
   let
     val ABC = read_prop "A \<Longrightarrow> B::prop \<equiv> C::prop"
     val AB = read_prop "A \<Longrightarrow> B"
     val AC = read_prop "A \<Longrightarrow> C"
     val A = read_prop "A"
   in
     store_standard_thm_open (Binding.make ("imp_cong", \<^here>))
       (Thm.implies_intr ABC (Thm.equal_intr
         (Thm.implies_intr AB (Thm.implies_intr A
           (Thm.equal_elim (Thm.implies_elim (Thm.assume ABC) (Thm.assume A))
             (Thm.implies_elim (Thm.assume AB) (Thm.assume A)))))
         (Thm.implies_intr AC (Thm.implies_intr A
           (Thm.equal_elim (Thm.symmetric (Thm.implies_elim (Thm.assume ABC) (Thm.assume A)))
             (Thm.implies_elim (Thm.assume AC) (Thm.assume A)))))))
   end;
 
 val swap_prems_eq =
   let
     val ABC = read_prop "A \<Longrightarrow> B \<Longrightarrow> C"
     val BAC = read_prop "B \<Longrightarrow> A \<Longrightarrow> C"
     val A = read_prop "A"
     val B = read_prop "B"
   in
     store_standard_thm_open (Binding.make ("swap_prems_eq", \<^here>))
       (Thm.equal_intr
         (Thm.implies_intr ABC (Thm.implies_intr B (Thm.implies_intr A
           (Thm.implies_elim (Thm.implies_elim (Thm.assume ABC) (Thm.assume A)) (Thm.assume B)))))
         (Thm.implies_intr BAC (Thm.implies_intr A (Thm.implies_intr B
           (Thm.implies_elim (Thm.implies_elim (Thm.assume BAC) (Thm.assume B)) (Thm.assume A))))))
   end;
 
 val imp_cong_rule = Thm.combination o Thm.combination (Thm.reflexive implies);
 
 fun arg_cong_rule ct th = Thm.combination (Thm.reflexive ct) th;    (*AP_TERM in LCF/HOL*)
 fun fun_cong_rule th ct = Thm.combination th (Thm.reflexive ct);    (*AP_THM in LCF/HOL*)
 fun binop_cong_rule ct th1 th2 = Thm.combination (arg_cong_rule ct th1) th2;
 
 fun beta_eta_conversion ct =
   let val thm = Thm.beta_conversion true ct
   in Thm.transitive thm (Thm.eta_conversion (Thm.rhs_of thm)) end;
 
 (*Contract all eta-redexes in the theorem, lest they give rise to needless abstractions*)
 fun eta_contraction_rule th =
   Thm.equal_elim (Thm.eta_conversion (Thm.cprop_of th)) th;
 
 
 (* abs_def *)
 
 (*
    f ?x1 ... ?xn \<equiv> u
   --------------------
    f \<equiv> \<lambda>x1 ... xn. u
 *)
 
 local
 
 fun contract_lhs th =
   Thm.transitive (Thm.symmetric (beta_eta_conversion (#1 (Thm.dest_equals (Thm.cprop_of th))))) th;
 
 fun var_args ct =
   (case try Thm.dest_comb ct of
     SOME (f, arg) =>
       (case Thm.term_of arg of
         Var ((x, _), _) => update (eq_snd (op aconvc)) (x, arg) (var_args f)
       | _ => [])
   | NONE => []);
 
 in
 
 fun abs_def th =
   let
     val th' = contract_lhs th;
     val args = var_args (Thm.lhs_of th');
   in contract_lhs (fold (uncurry Thm.abstract_rule) args th') end;
 
 end;
 
 
 
 (*** Some useful meta-theorems ***)
 
 (*The rule V/V, obtains assumption solving for eresolve_tac*)
 val asm_rl =
   store_standard_thm_open (Binding.make ("asm_rl", \<^here>))
     (Thm.trivial (read_prop "?psi"));
 
 (*Meta-level cut rule: \<lbrakk>V \<Longrightarrow> W; V\<rbrakk> \<Longrightarrow> W *)
 val cut_rl =
   store_standard_thm_open (Binding.make ("cut_rl", \<^here>))
     (Thm.trivial (read_prop "?psi \<Longrightarrow> ?theta"));
 
 (*Generalized elim rule for one conclusion; cut_rl with reversed premises:
      \<lbrakk>PROP V; PROP V \<Longrightarrow> PROP W\<rbrakk> \<Longrightarrow> PROP W *)
 val revcut_rl =
   let
     val V = read_prop "V";
     val VW = read_prop "V \<Longrightarrow> W";
   in
     store_standard_thm_open (Binding.make ("revcut_rl", \<^here>))
       (Thm.implies_intr V
         (Thm.implies_intr VW (Thm.implies_elim (Thm.assume VW) (Thm.assume V))))
   end;
 
 (*for deleting an unwanted assumption*)
 val thin_rl =
   let
     val V = read_prop "V";
     val W = read_prop "W";
     val thm = Thm.implies_intr V (Thm.implies_intr W (Thm.assume W));
   in store_standard_thm_open (Binding.make ("thin_rl", \<^here>)) thm end;
 
 (* (\<And>x. PROP ?V) \<equiv> PROP ?V       Allows removal of redundant parameters*)
 val triv_forall_equality =
   let
     val V = read_prop "V";
     val QV = read_prop "\<And>x::'a. V";
     val x = certify (Free ("x", Term.aT []));
   in
     store_standard_thm_open (Binding.make ("triv_forall_equality", \<^here>))
       (Thm.equal_intr (Thm.implies_intr QV (Thm.forall_elim x (Thm.assume QV)))
         (Thm.implies_intr V (Thm.forall_intr x (Thm.assume V))))
   end;
 
 (* (PROP ?Phi \<Longrightarrow> PROP ?Phi \<Longrightarrow> PROP ?Psi) \<Longrightarrow>
    (PROP ?Phi \<Longrightarrow> PROP ?Psi)
 *)
 val distinct_prems_rl =
   let
     val AAB = read_prop "Phi \<Longrightarrow> Phi \<Longrightarrow> Psi";
     val A = read_prop "Phi";
   in
     store_standard_thm_open (Binding.make ("distinct_prems_rl", \<^here>))
       (implies_intr_list [AAB, A]
         (implies_elim_list (Thm.assume AAB) [Thm.assume A, Thm.assume A]))
   end;
 
 (* \<lbrakk>PROP ?phi \<Longrightarrow> PROP ?psi; PROP ?psi \<Longrightarrow> PROP ?phi\<rbrakk>
    \<Longrightarrow> PROP ?phi \<equiv> PROP ?psi
    Introduction rule for \<equiv> as a meta-theorem.
 *)
 val equal_intr_rule =
   let
     val PQ = read_prop "phi \<Longrightarrow> psi";
     val QP = read_prop "psi \<Longrightarrow> phi";
   in
     store_standard_thm_open (Binding.make ("equal_intr_rule", \<^here>))
       (Thm.implies_intr PQ
         (Thm.implies_intr QP (Thm.equal_intr (Thm.assume PQ) (Thm.assume QP))))
   end;
 
 (* PROP ?phi \<equiv> PROP ?psi \<Longrightarrow> PROP ?phi \<Longrightarrow> PROP ?psi *)
 val equal_elim_rule1 =
   let
     val eq = read_prop "phi::prop \<equiv> psi::prop";
     val P = read_prop "phi";
   in
     store_standard_thm_open (Binding.make ("equal_elim_rule1", \<^here>))
       (Thm.equal_elim (Thm.assume eq) (Thm.assume P) |> implies_intr_list [eq, P])
   end;
 
 (* PROP ?psi \<equiv> PROP ?phi \<Longrightarrow> PROP ?phi \<Longrightarrow> PROP ?psi *)
 val equal_elim_rule2 =
   store_standard_thm_open (Binding.make ("equal_elim_rule2", \<^here>))
     (symmetric_thm RS equal_elim_rule1);
 
 (* PROP ?phi \<Longrightarrow> PROP ?phi \<Longrightarrow> PROP ?psi \<Longrightarrow> PROP ?psi *)
 val remdups_rl =
   let
     val P = read_prop "phi";
     val Q = read_prop "psi";
     val thm = implies_intr_list [P, P, Q] (Thm.assume Q);
   in store_standard_thm_open (Binding.make ("remdups_rl", \<^here>)) thm end;
 
 
 
 (** embedded terms and types **)
 
 local
   val A = certify (Free ("A", propT));
   val axiom = Thm.unvarify_axiom (Context.the_global_context ());
   val prop_def = axiom "Pure.prop_def";
   val term_def = axiom "Pure.term_def";
   val sort_constraint_def = axiom "Pure.sort_constraint_def";
   val C = Thm.lhs_of sort_constraint_def;
   val T = Thm.dest_arg C;
   val CA = mk_implies (C, A);
 in
 
 (* protect *)
 
 val protect = Thm.apply (certify Logic.protectC);
 
 val protectI =
   store_standard_thm (Binding.concealed (Binding.make ("protectI", \<^here>)))
     (Thm.equal_elim (Thm.symmetric prop_def) (Thm.assume A));
 
 val protectD =
   store_standard_thm (Binding.concealed (Binding.make ("protectD", \<^here>)))
     (Thm.equal_elim prop_def (Thm.assume (protect A)));
 
 val protect_cong =
   store_standard_thm_open (Binding.make ("protect_cong", \<^here>))
     (Thm.reflexive (protect A));
 
 fun implies_intr_protected asms th =
   let val asms' = map protect asms in
     implies_elim_list
       (implies_intr_list asms th)
       (map (fn asm' => Thm.assume asm' RS protectD) asms')
     |> implies_intr_list asms'
   end;
 
 
 (* term *)
 
 val termI =
   store_standard_thm (Binding.concealed (Binding.make ("termI", \<^here>)))
     (Thm.equal_elim (Thm.symmetric term_def) (Thm.forall_intr A (Thm.trivial A)));
 
 fun mk_term ct =
   let
     val cT = Thm.ctyp_of_cterm ct;
     val T = Thm.typ_of cT;
   in Thm.instantiate ([((("'a", 0), []), cT)], [((("x", 0), T), ct)]) termI end;
 
 fun dest_term th =
   let val cprop = strip_imp_concl (Thm.cprop_of th) in
     if can Logic.dest_term (Thm.term_of cprop) then
       Thm.dest_arg cprop
     else raise THM ("dest_term", 0, [th])
   end;
 
 fun cterm_rule f = dest_term o f o mk_term;
 
 val cterm_add_frees = Thm.add_frees o mk_term;
 val cterm_add_vars = Thm.add_vars o mk_term;
 
 val dummy_thm = mk_term (certify Term.dummy_prop);
 val free_dummy_thm = Thm.tag_free_dummy dummy_thm;
 
 
 (* sort_constraint *)
 
 fun is_sort_constraint (Const ("Pure.sort_constraint", _) $ Const ("Pure.type", _)) = true
   | is_sort_constraint _ = false;
 
 val sort_constraintI =
   store_standard_thm (Binding.concealed (Binding.make ("sort_constraintI", \<^here>)))
     (Thm.equal_elim (Thm.symmetric sort_constraint_def) (mk_term T));
 
 val sort_constraint_eq =
   store_standard_thm (Binding.concealed (Binding.make ("sort_constraint_eq", \<^here>)))
     (Thm.equal_intr
       (Thm.implies_intr CA (Thm.implies_elim (Thm.assume CA)
         (Thm.unvarify_global (Context.the_global_context ()) sort_constraintI)))
       (implies_intr_list [A, C] (Thm.assume A)));
 
 end;
 
 
 (* HHF normalization *)
 
 (* (PROP ?phi \<Longrightarrow> (\<And>x. PROP ?psi x)) \<equiv> (\<And>x. PROP ?phi \<Longrightarrow> PROP ?psi x) *)
 val norm_hhf_eq =
   let
     val aT = TFree ("'a", []);
     val x = Free ("x", aT);
     val phi = Free ("phi", propT);
     val psi = Free ("psi", aT --> propT);
 
     val cx = certify x;
     val cphi = certify phi;
     val lhs = certify (Logic.mk_implies (phi, Logic.all x (psi $ x)));
     val rhs = certify (Logic.all x (Logic.mk_implies (phi, psi $ x)));
   in
     Thm.equal_intr
       (Thm.implies_elim (Thm.assume lhs) (Thm.assume cphi)
         |> Thm.forall_elim cx
         |> Thm.implies_intr cphi
         |> Thm.forall_intr cx
         |> Thm.implies_intr lhs)
       (Thm.implies_elim
           (Thm.assume rhs |> Thm.forall_elim cx) (Thm.assume cphi)
         |> Thm.forall_intr cx
         |> Thm.implies_intr cphi
         |> Thm.implies_intr rhs)
     |> store_standard_thm_open (Binding.make ("norm_hhf_eq", \<^here>))
   end;
 
 val norm_hhf_prop = Logic.dest_equals (Thm.prop_of norm_hhf_eq);
 val norm_hhf_eqs = [norm_hhf_eq, sort_constraint_eq];
 
 fun is_norm_hhf (Const ("Pure.sort_constraint", _)) = false
   | is_norm_hhf (Const ("Pure.imp", _) $ _ $ (Const ("Pure.all", _) $ _)) = false
   | is_norm_hhf (Abs _ $ _) = false
   | is_norm_hhf (t $ u) = is_norm_hhf t andalso is_norm_hhf u
   | is_norm_hhf (Abs (_, _, t)) = is_norm_hhf t
   | is_norm_hhf _ = true;
 
 fun norm_hhf thy t =
   if is_norm_hhf t then t
   else Pattern.rewrite_term thy [norm_hhf_prop] [] t;
 
 fun norm_hhf_cterm ctxt raw_ct =
   let
     val thy = Proof_Context.theory_of ctxt;
     val ct = Thm.transfer_cterm thy raw_ct;
     val t = Thm.term_of ct;
   in if is_norm_hhf t then ct else Thm.cterm_of ctxt (norm_hhf thy t) end;
 
 
 (* var indexes *)
 
 fun incr_indexes th = Thm.incr_indexes (Thm.maxidx_of th + 1);
 
 fun incr_indexes2 th1 th2 =
   Thm.incr_indexes (Int.max (Thm.maxidx_of th1, Thm.maxidx_of th2) + 1);
 
 local
 
 (*compose Q and \<lbrakk>Q1,Q2,...,Qk\<rbrakk> \<Longrightarrow> R to \<lbrakk>Q2,...,Qk\<rbrakk> \<Longrightarrow> R getting unique result*)
 fun comp incremented th1 th2 =
   Thm.bicompose NONE {flatten = true, match = false, incremented = incremented}
     (false, th1, 0) 1 th2
   |> Seq.list_of |> distinct Thm.eq_thm
   |> (fn [th] => Thm.solve_constraints th | _ => raise THM ("COMP", 1, [th1, th2]));
 
 in
 
 fun th1 COMP th2 = comp false th1 th2;
 fun th1 INCR_COMP th2 = comp true (incr_indexes th2 th1) th2;
 fun th1 COMP_INCR th2 = comp true th1 (incr_indexes th1 th2);
 
 end;
 
 fun comp_no_flatten (th, n) i rule =
   (case distinct Thm.eq_thm (Seq.list_of
       (Thm.bicompose NONE {flatten = false, match = false, incremented = true}
         (false, th, n) i (incr_indexes th rule))) of
     [th'] => Thm.solve_constraints th'
   | [] => raise THM ("comp_no_flatten", i, [th, rule])
   | _ => raise THM ("comp_no_flatten: unique result expected", i, [th, rule]));
 
 
 
 (** variations on Thm.instantiate **)
 
 fun instantiate_normalize instpair th =
   Thm.adjust_maxidx_thm ~1 (Thm.instantiate instpair th COMP_INCR asm_rl);
 
 fun instantiate'_normalize Ts ts th =
   Thm.adjust_maxidx_thm ~1 (Thm.instantiate' Ts ts th COMP_INCR asm_rl);
 
 (*instantiation with type-inference for variables*)
 fun infer_instantiate_types _ [] th = th
   | infer_instantiate_types ctxt args raw_th =
       let
         val thy = Proof_Context.theory_of ctxt;
         val th = Thm.transfer thy raw_th;
 
         fun infer ((xi, T), cu) (tyenv, maxidx) =
           let
             val _ = Thm.ctyp_of ctxt T;
             val _ = Thm.transfer_cterm thy cu;
             val U = Thm.typ_of_cterm cu;
             val maxidx' = maxidx
               |> Integer.max (#2 xi)
               |> Term.maxidx_typ T
               |> Integer.max (Thm.maxidx_of_cterm cu);
             val (tyenv', maxidx'') = Sign.typ_unify thy (T, U) (tyenv, maxidx')
               handle Type.TUNIFY =>
                 let
                   val t = Var (xi, T);
                   val u = Thm.term_of cu;
                 in
                   raise THM ("infer_instantiate_types: type " ^
                     Syntax.string_of_typ ctxt (Envir.norm_type tyenv T) ^ " of variable " ^
                     Syntax.string_of_term ctxt (Term.map_types (Envir.norm_type tyenv) t) ^
                     "\ncannot be unified with type " ^
                     Syntax.string_of_typ ctxt (Envir.norm_type tyenv U) ^ " of term " ^
                     Syntax.string_of_term ctxt (Term.map_types (Envir.norm_type tyenv) u),
                     0, [th])
                 end;
           in (tyenv', maxidx'') end;
 
         val (tyenv, _) = fold infer args (Vartab.empty, 0);
         val instT =
           Vartab.fold (fn (xi, (S, T)) =>
             cons ((xi, S), Thm.ctyp_of ctxt (Envir.norm_type tyenv T))) tyenv [];
         val inst = args |> map (fn ((xi, T), cu) =>
           ((xi, Envir.norm_type tyenv T),
             Thm.instantiate_cterm (instT, []) (Thm.transfer_cterm thy cu)));
       in instantiate_normalize (instT, inst) th end
       handle CTERM (msg, _) => raise THM (msg, 0, [raw_th])
         | TERM (msg, _) => raise THM (msg, 0, [raw_th])
         | TYPE (msg, _, _) => raise THM (msg, 0, [raw_th]);
 
 fun infer_instantiate _ [] th = th
   | infer_instantiate ctxt args th =
       let
         val vars = Term.add_vars (Thm.full_prop_of th) [];
         val dups = duplicates (eq_fst op =) vars;
         val _ = null dups orelse
           raise THM ("infer_instantiate: inconsistent types for variables " ^
             commas_quote (map (Syntax.string_of_term (Config.put show_types true ctxt) o Var) dups),
             0, [th]);
         val args' = args |> map_filter (fn (xi, cu) =>
           AList.lookup (op =) vars xi |> Option.map (fn T => ((xi, T), cu)));
       in infer_instantiate_types ctxt args' th end;
 
 fun infer_instantiate' ctxt args th =
   let
     val vars = rev (Term.add_vars (Thm.full_prop_of th) []);
     val args' = zip_options vars args
       handle ListPair.UnequalLengths =>
         raise THM ("infer_instantiate': more instantiations than variables in thm", 0, [th]);
   in infer_instantiate_types ctxt args' th end;
 
 
 
 (** renaming of bound variables **)
 
 (* replace bound variables x_i in thm by y_i *)
 (* where vs = [(x_1, y_1), ..., (x_n, y_n)]  *)
 
 fun rename_bvars [] thm = thm
   | rename_bvars vs thm =
       let
         fun rename (Abs (x, T, t)) = Abs (AList.lookup (op =) vs x |> the_default x, T, rename t)
           | rename (t $ u) = rename t $ rename u
           | rename a = a;
       in Thm.renamed_prop (rename (Thm.prop_of thm)) thm end;
 
 
 (* renaming in left-to-right order *)
 
 fun rename_bvars' xs thm =
   let
     fun rename [] t = ([], t)
       | rename (x' :: xs) (Abs (x, T, t)) =
           let val (xs', t') = rename xs t
           in (xs', Abs (the_default x x', T, t')) end
       | rename xs (t $ u) =
           let
             val (xs', t') = rename xs t;
             val (xs'', u') = rename xs' u;
           in (xs'', t' $ u') end
       | rename xs a = (xs, a);
   in
     (case rename xs (Thm.prop_of thm) of
       ([], prop') => Thm.renamed_prop prop' thm
     | _ => error "More names than abstractions in theorem")
   end;
 
 end;
 
 structure Basic_Drule: BASIC_DRULE = Drule;
 open Basic_Drule;
diff --git a/src/Pure/envir.ML b/src/Pure/envir.ML
--- a/src/Pure/envir.ML
+++ b/src/Pure/envir.ML
@@ -1,424 +1,424 @@
 (*  Title:      Pure/envir.ML
     Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
 
 Free-form environments.  The type of a term variable / sort of a type variable is
 part of its name.  The lookup function must apply type substitutions,
 since they may change the identity of a variable.
 *)
 
 signature ENVIR =
 sig
   type tenv = (typ * term) Vartab.table
   datatype env = Envir of {maxidx: int, tenv: tenv, tyenv: Type.tyenv}
   val maxidx_of: env -> int
   val term_env: env -> tenv
   val type_env: env -> Type.tyenv
   val is_empty: env -> bool
   val empty: int -> env
   val init: env
   val merge: env * env -> env
   val insert_sorts: env -> sort list -> sort list
   val genvars: string -> env * typ list -> env * term list
   val genvar: string -> env * typ -> env * term
   val lookup1: tenv -> indexname * typ -> term option
   val lookup: env -> indexname * typ -> term option
   val update: (indexname * typ) * term -> env -> env
   val above: env -> int -> bool
   val vupdate: (indexname * typ) * term -> env -> env
   val norm_type_same: Type.tyenv -> typ Same.operation
   val norm_types_same: Type.tyenv -> typ list Same.operation
   val norm_type: Type.tyenv -> typ -> typ
   val norm_term_same: env -> term Same.operation
   val norm_term: env -> term -> term
   val beta_norm: term -> term
   val head_norm: env -> term -> term
   val eta_long: typ list -> term -> term
   val eta_contract: term -> term
   val beta_eta_contract: term -> term
   val aeconv: term * term -> bool
   val body_type: env -> typ -> typ
   val binder_types: env -> typ -> typ list
   val strip_type: env -> typ -> typ list * typ
   val fastype: env -> typ list -> term -> typ
   val subst_type_same: Type.tyenv -> typ Same.operation
   val subst_term_types_same: Type.tyenv -> term Same.operation
   val subst_term_same: Type.tyenv * tenv -> term Same.operation
   val subst_type: Type.tyenv -> typ -> typ
   val subst_term_types: Type.tyenv -> term -> term
   val subst_term: Type.tyenv * tenv -> term -> term
   val expand_atom: typ -> typ * term -> term
   val expand_term: (term -> (typ * term) option) -> term -> term
   val expand_term_frees: ((string * typ) * term) list -> term -> term
 end;
 
 structure Envir: ENVIR =
 struct
 
 (** datatype env **)
 
 (*Updating can destroy environment in 2 ways!
    (1) variables out of range
    (2) circular assignments
 *)
 
 type tenv = (typ * term) Vartab.table;
 
 datatype env = Envir of
  {maxidx: int,          (*upper bound of maximum index of vars*)
   tenv: tenv,           (*assignments to Vars*)
   tyenv: Type.tyenv};   (*assignments to TVars*)
 
 fun make_env (maxidx, tenv, tyenv) =
   Envir {maxidx = maxidx, tenv = tenv, tyenv = tyenv};
 
 fun maxidx_of (Envir {maxidx, ...}) = maxidx;
 fun term_env (Envir {tenv, ...}) = tenv;
 fun type_env (Envir {tyenv, ...}) = tyenv;
 
 fun is_empty env =
   Vartab.is_empty (term_env env) andalso
   Vartab.is_empty (type_env env);
 
 
 (* build env *)
 
 fun empty maxidx = make_env (maxidx, Vartab.empty, Vartab.empty);
 val init = empty ~1;
 
 fun merge
    (Envir {maxidx = maxidx1, tenv = tenv1, tyenv = tyenv1},
     Envir {maxidx = maxidx2, tenv = tenv2, tyenv = tyenv2}) =
   make_env (Int.max (maxidx1, maxidx2),
     Vartab.merge (op =) (tenv1, tenv2),
     Vartab.merge (op =) (tyenv1, tyenv2));
 
 
 (*NB: type unification may invent new sorts*)  (* FIXME tenv!? *)
 val insert_sorts = Vartab.fold (fn (_, (_, T)) => Sorts.insert_typ T) o type_env;
 
 (*Generate a list of distinct variables.
   Increments index to make them distinct from ALL present variables. *)
 fun genvars name (Envir {maxidx, tenv, tyenv}, Ts) : env * term list =
   let
     fun genvs (_, [] : typ list) : term list = []
       | genvs (_, [T]) = [Var ((name, maxidx + 1), T)]
       | genvs (n, T :: Ts) =
           Var ((name ^ radixstring (26, "a" , n), maxidx + 1), T)
             :: genvs (n + 1, Ts);
   in (Envir {maxidx = maxidx + 1, tenv = tenv, tyenv = tyenv}, genvs (0, Ts)) end;
 
 (*Generate a variable.*)
 fun genvar name (env, T) : env * term =
   let val (env', [v]) = genvars name (env, [T])
   in (env', v) end;
 
 fun var_clash xi T T' =
   raise TYPE ("Variable has two distinct types", [], [Var (xi, T'), Var (xi, T)]);
 
 fun lookup_check check tenv (xi, T) =
   (case Vartab.lookup tenv xi of
     NONE => NONE
   | SOME (U, t) => if check (T, U) then SOME t else var_clash xi T U);
 
 (*When dealing with environments produced by matching instead
   of unification, there is no need to chase assigned TVars.
   In this case, we can simply ignore the type substitution
   and use = instead of eq_type.*)
 fun lookup1 tenv = lookup_check (op =) tenv;
 
 fun lookup (Envir {tenv, tyenv, ...}) = lookup_check (Type.unified tyenv) tenv;
 
 fun update ((xi, T), t) (Envir {maxidx, tenv, tyenv}) =
   Envir {maxidx = maxidx, tenv = Vartab.update_new (xi, (T, t)) tenv, tyenv = tyenv};
 
 (*Determine if the least index updated exceeds lim*)
 fun above (Envir {tenv, tyenv, ...}) lim =
   (case Vartab.min tenv of SOME ((_, i), _) => i > lim | NONE => true) andalso
   (case Vartab.min tyenv of SOME ((_, i), _) => i > lim | NONE => true);
 
 (*Update, checking Var-Var assignments: try to suppress higher indexes*)
 fun vupdate ((a, U), t) env =
   (case t of
     Var (nT as (name', T)) =>
       if a = name' then env     (*cycle!*)
       else if Term_Ord.indexname_ord (a, name') = LESS then
         (case lookup env nT of  (*if already assigned, chase*)
           NONE => update (nT, Var (a, T)) env
         | SOME u => vupdate ((a, U), u) env)
       else update ((a, U), t) env
   | _ => update ((a, U), t) env);
 
 
 
 (** beta normalization wrt. environment **)
 
 (*Chases variables in env.  Does not exploit sharing of variable bindings
   Does not check types, so could loop.*)
 
 local
 
 fun norm_type0 tyenv : typ Same.operation =
   let
     fun norm (Type (a, Ts)) = Type (a, Same.map norm Ts)
       | norm (TFree _) = raise Same.SAME
       | norm (TVar v) =
           (case Type.lookup tyenv v of
             SOME U => Same.commit norm U
           | NONE => raise Same.SAME);
   in norm end;
 
 fun norm_term1 tenv : term Same.operation =
   let
     fun norm (Var v) =
           (case lookup1 tenv v of
             SOME u => Same.commit norm u
           | NONE => raise Same.SAME)
       | norm (Abs (a, T, body)) = Abs (a, T, norm body)
       | norm (Abs (_, _, body) $ t) = Same.commit norm (subst_bound (t, body))
       | norm (f $ t) =
           ((case norm f of
              Abs (_, _, body) => Same.commit norm (subst_bound (t, body))
            | nf => nf $ Same.commit norm t)
           handle Same.SAME => f $ norm t)
       | norm _ = raise Same.SAME;
   in norm end;
 
 fun norm_term2 (envir as Envir {tyenv, ...}) : term Same.operation =
   let
     val normT = norm_type0 tyenv;
     fun norm (Const (a, T)) = Const (a, normT T)
       | norm (Free (a, T)) = Free (a, normT T)
       | norm (Var (xi, T)) =
           (case lookup envir (xi, T) of
             SOME u => Same.commit norm u
           | NONE => Var (xi, normT T))
       | norm (Abs (a, T, body)) =
           (Abs (a, normT T, Same.commit norm body)
             handle Same.SAME => Abs (a, T, norm body))
       | norm (Abs (_, _, body) $ t) = Same.commit norm (subst_bound (t, body))
       | norm (f $ t) =
           ((case norm f of
              Abs (_, _, body) => Same.commit norm (subst_bound (t, body))
            | nf => nf $ Same.commit norm t)
           handle Same.SAME => f $ norm t)
       | norm _ = raise Same.SAME;
   in norm end;
 
 in
 
 fun norm_type_same tyenv T =
   if Vartab.is_empty tyenv then raise Same.SAME
   else norm_type0 tyenv T;
 
 fun norm_types_same tyenv Ts =
   if Vartab.is_empty tyenv then raise Same.SAME
   else Same.map (norm_type0 tyenv) Ts;
 
 fun norm_type tyenv T = norm_type_same tyenv T handle Same.SAME => T;
 
 fun norm_term_same (envir as Envir {tenv, tyenv, ...}) =
   if Vartab.is_empty tyenv then norm_term1 tenv
   else norm_term2 envir;
 
 fun norm_term envir t = norm_term_same envir t handle Same.SAME => t;
 
 fun beta_norm t =
   if Term.could_beta_contract t then norm_term init t else t;
 
 end;
 
 
 (* head normal form for unification *)
 
 fun head_norm env =
   let
     fun norm (Var v) =
         (case lookup env v of
           SOME u => head_norm env u
         | NONE => raise Same.SAME)
       | norm (Abs (a, T, body)) = Abs (a, T, norm body)
       | norm (Abs (_, _, body) $ t) = Same.commit norm (subst_bound (t, body))
       | norm (f $ t) =
           (case norm f of
             Abs (_, _, body) => Same.commit norm (subst_bound (t, body))
           | nf => nf $ t)
       | norm _ = raise Same.SAME;
   in Same.commit norm end;
 
 
 (* eta-long beta-normal form *)
 
 fun eta_long Ts (Abs (s, T, t)) = Abs (s, T, eta_long (T :: Ts) t)
   | eta_long Ts t =
       (case strip_comb t of
         (Abs _, _) => eta_long Ts (beta_norm t)
       | (u, ts) =>
           let
             val Us = binder_types (fastype_of1 (Ts, t));
             val i = length Us;
             val long = eta_long (rev Us @ Ts);
           in
             fold_rev (Term.abs o pair "x") Us
               (list_comb (incr_boundvars i u,
                 map (long o incr_boundvars i) ts @ map (long o Bound) (i - 1 downto 0)))
           end);
 
 
 (* full eta contraction *)
 
 local
 
 fun decr lev (Bound i) = if i >= lev then Bound (i - 1) else raise Same.SAME
   | decr lev (Abs (a, T, body)) = Abs (a, T, decr (lev + 1) body)
   | decr lev (t $ u) = (decr lev t $ decrh lev u handle Same.SAME => t $ decr lev u)
   | decr _ _ = raise Same.SAME
 and decrh lev t = (decr lev t handle Same.SAME => t);
 
 fun eta (Abs (a, T, body)) =
     ((case eta body of
         body' as (f $ Bound 0) =>
           if Term.is_dependent f then Abs (a, T, body')
           else decrh 0 f
      | body' => Abs (a, T, body')) handle Same.SAME =>
         (case body of
           f $ Bound 0 =>
             if Term.is_dependent f then raise Same.SAME
             else decrh 0 f
         | _ => raise Same.SAME))
   | eta (t $ u) = (eta t $ Same.commit eta u handle Same.SAME => t $ eta u)
   | eta _ = raise Same.SAME;
 
 in
 
 fun eta_contract t =
   if Term.could_eta_contract t then Same.commit eta t else t;
 
 end;
 
 val beta_eta_contract = eta_contract o beta_norm;
 
 fun aeconv (t, u) = t aconv u orelse eta_contract t aconv eta_contract u;
 
 
 fun body_type env (Type ("fun", [_, T])) = body_type env T
   | body_type env (T as TVar v) =
       (case Type.lookup (type_env env) v of
         NONE => T
       | SOME T' => body_type env T')
   | body_type _ T = T;
 
 fun binder_types env (Type ("fun", [T, U])) = T :: binder_types env U
   | binder_types env (TVar v) =
       (case Type.lookup (type_env env) v of
         NONE => []
       | SOME T' => binder_types env T')
   | binder_types _ _ = [];
 
 fun strip_type env T = (binder_types env T, body_type env T);
 
 (*finds type of term without checking that combinations are consistent
   Ts holds types of bound variables*)
 fun fastype (Envir {tyenv, ...}) =
   let
     val funerr = "fastype: expected function type";
     fun fast Ts (f $ u) =
           (case Type.devar tyenv (fast Ts f) of
             Type ("fun", [_, T]) => T
           | TVar _ => raise TERM (funerr, [f $ u])
           | _ => raise TERM (funerr, [f $ u]))
       | fast _ (Const (_, T)) = T
       | fast _ (Free (_, T)) = T
       | fast Ts (Bound i) =
           (nth Ts i handle General.Subscript => raise TERM ("fastype: Bound", [Bound i]))
       | fast _ (Var (_, T)) = T
       | fast Ts (Abs (_, T, u)) = T --> fast (T :: Ts) u;
   in fast end;
 
 
 (** plain substitution -- without variable chasing **)
 
 local
 
 fun subst_type0 tyenv = Term_Subst.map_atypsT_same
   (fn TVar v =>
         (case Type.lookup tyenv v of
           SOME U => U
         | NONE => raise Same.SAME)
     | _ => raise Same.SAME);
 
 fun subst_term1 tenv = Term_Subst.map_aterms_same
   (fn Var v =>
         (case lookup1 tenv v of
           SOME u => u
         | NONE => raise Same.SAME)
     | _ => raise Same.SAME);
 
 fun subst_term2 tenv tyenv : term Same.operation =
   let
     val substT = subst_type0 tyenv;
     fun subst (Const (a, T)) = Const (a, substT T)
       | subst (Free (a, T)) = Free (a, substT T)
       | subst (Var (xi, T)) =
           (case lookup1 tenv (xi, T) of
             SOME u => u
           | NONE => Var (xi, substT T))
       | subst (Bound _) = raise Same.SAME
       | subst (Abs (a, T, t)) =
           (Abs (a, substT T, Same.commit subst t)
             handle Same.SAME => Abs (a, T, subst t))
       | subst (t $ u) = (subst t $ Same.commit subst u handle Same.SAME => t $ subst u);
   in subst end;
 
 in
 
 fun subst_type_same tyenv T =
   if Vartab.is_empty tyenv then raise Same.SAME
   else subst_type0 tyenv T;
 
 fun subst_term_types_same tyenv t =
   if Vartab.is_empty tyenv then raise Same.SAME
   else Term_Subst.map_types_same (subst_type0 tyenv) t;
 
 fun subst_term_same (tyenv, tenv) =
   if Vartab.is_empty tenv then subst_term_types_same tyenv
   else if Vartab.is_empty tyenv then subst_term1 tenv
   else subst_term2 tenv tyenv;
 
 fun subst_type tyenv T = subst_type_same tyenv T handle Same.SAME => T;
 fun subst_term_types tyenv t = subst_term_types_same tyenv t handle Same.SAME => t;
 fun subst_term envs t = subst_term_same envs t handle Same.SAME => t;
 
 end;
 
 
 
 (** expand defined atoms -- with local beta reduction **)
 
 fun expand_atom T (U, u) =
-  subst_term_types (Type.raw_match (U, T) Vartab.empty) u
+  subst_term_types (Vartab.build (Type.raw_match (U, T))) u
     handle Type.TYPE_MATCH => raise TYPE ("expand_atom: ill-typed replacement", [T, U], [u]);
 
 fun expand_term get =
   let
     fun expand tm =
       let
         val (head, args) = Term.strip_comb tm;
         val args' = map expand args;
         fun comb head' = Term.list_comb (head', args');
       in
         (case head of
           Abs (x, T, t) => comb (Abs (x, T, expand t))
         | _ =>
           (case get head of
             SOME def => Term.betapplys (expand_atom (Term.fastype_of head) def, args')
           | NONE => comb head))
       end;
   in expand end;
 
 fun expand_term_frees defs =
   let
     val eqs = map (fn ((x, U), u) => (x, (U, u))) defs;
     val get = fn Free (x, _) => AList.lookup (op =) eqs x | _ => NONE;
   in expand_term get end;
 
 end;
diff --git a/src/Pure/global_theory.ML b/src/Pure/global_theory.ML
--- a/src/Pure/global_theory.ML
+++ b/src/Pure/global_theory.ML
@@ -1,371 +1,371 @@
 (*  Title:      Pure/global_theory.ML
     Author:     Makarius
 
 Global theory content: stored facts.
 *)
 
 signature GLOBAL_THEORY =
 sig
   val facts_of: theory -> Facts.T
   val check_fact: theory -> xstring * Position.T -> string
   val intern_fact: theory -> xstring -> string
   val defined_fact: theory -> string -> bool
   val alias_fact: binding -> string -> theory -> theory
   val hide_fact: bool -> string -> theory -> theory
   val dest_thms: bool -> theory list -> theory -> (Thm_Name.T * thm) list
   val get_thm_names: theory -> Thm_Name.T Inttab.table
   val dest_thm_names: theory -> (Proofterm.thm_id * Thm_Name.T) list
   val lookup_thm_id: theory -> Proofterm.thm_id -> Thm_Name.T option
   val lookup_thm: theory -> thm -> (Proofterm.thm_id * Thm_Name.T) option
   val get_thms: theory -> xstring -> thm list
   val get_thm: theory -> xstring -> thm
   val transfer_theories: theory -> thm -> thm
   val all_thms_of: theory -> bool -> (string * thm) list
   val get_thm_name: theory -> Thm_Name.T * Position.T -> thm
   val burrow_fact: ('a list -> 'b list) -> ('a list * 'c) list -> ('b list * 'c) list
   val burrow_facts: ('a list -> 'b list) ->
     ('c * ('a list * 'd) list) list -> ('c * ('b list * 'd) list) list
   val name_multi: string * Position.T -> thm list -> ((string * Position.T) * thm) list
   type name_flags
   val unnamed: name_flags
   val official1: name_flags
   val official2: name_flags
   val unofficial1: name_flags
   val unofficial2: name_flags
   val name_thm: name_flags -> string * Position.T -> thm -> thm
   val name_thms: name_flags -> string * Position.T -> thm list -> thm list
   val check_thms_lazy: thm list lazy -> thm list lazy
   val add_thms_lazy: string -> (binding * thm list lazy) -> theory -> theory
   val store_thm: binding * thm -> theory -> thm * theory
   val store_thm_open: binding * thm -> theory -> thm * theory
   val add_thms: ((binding * thm) * attribute list) list -> theory -> thm list * theory
   val add_thm: (binding * thm) * attribute list -> theory -> thm * theory
   val add_thmss: ((binding * thm list) * attribute list) list -> theory -> thm list list * theory
   val add_thms_dynamic': Context.generic -> binding * (Context.generic -> thm list) ->
     theory -> string * theory
   val add_thms_dynamic: binding * (Context.generic -> thm list) -> theory -> theory
   val note_thms: string -> Thm.binding * (thm list * attribute list) list -> theory ->
     (string * thm list) * theory
   val note_thmss: string -> (Thm.binding * (thm list * attribute list) list) list -> theory ->
     (string * thm list) list * theory
   val add_defs: bool -> ((binding * term) * attribute list) list ->
     theory -> thm list * theory
   val add_defs_unchecked: bool -> ((binding * term) * attribute list) list ->
     theory -> thm list * theory
 end;
 
 structure Global_Theory: GLOBAL_THEORY =
 struct
 
 (** theory data **)
 
 structure Data = Theory_Data
 (
   type T = Facts.T * Thm_Name.T Inttab.table lazy option;
   val empty: T = (Facts.empty, NONE);
   val extend = I;
   fun merge ((facts1, _), (facts2, _)) = (Facts.merge (facts1, facts2), NONE);
 );
 
 
 (* facts *)
 
 val facts_of = #1 o Data.get;
 val map_facts = Data.map o apfst;
 
 fun check_fact thy = Facts.check (Context.Theory thy) (facts_of thy);
 val intern_fact = Facts.intern o facts_of;
 val defined_fact = Facts.defined o facts_of;
 
 fun alias_fact binding name thy =
   map_facts (Facts.alias (Sign.naming_of thy) binding name) thy;
 
 fun hide_fact fully name = map_facts (Facts.hide fully name);
 
 fun dest_thms verbose prev_thys thy =
   Facts.dest_static verbose (map facts_of prev_thys) (facts_of thy)
   |> maps (uncurry Thm_Name.make_list);
 
 
 (* thm_name vs. derivation_id *)
 
 val thm_names_of = #2 o Data.get;
 val map_thm_names = Data.map o apsnd;
 
 fun make_thm_names thy =
   (dest_thms true (Theory.parents_of thy) thy, Inttab.empty)
   |-> fold (fn (thm_name, thm) => fn thm_names =>
     (case Thm.derivation_id (Thm.transfer thy thm) of
       NONE => thm_names
     | SOME {serial, theory_name} =>
         if Context.theory_long_name thy <> theory_name then
           raise THM ("Bad theory name for derivation", 0, [thm])
         else
           (case Inttab.lookup thm_names serial of
             SOME thm_name' =>
               raise THM ("Duplicate use of derivation identity for " ^
                 Thm_Name.print thm_name ^ " vs. " ^
                 Thm_Name.print thm_name', 0, [thm])
           | NONE => Inttab.update (serial, thm_name) thm_names)));
 
 fun lazy_thm_names thy =
   (case thm_names_of thy of
     NONE => Lazy.lazy (fn () => make_thm_names thy)
   | SOME lazy_tab => lazy_tab);
 
 val get_thm_names = Lazy.force o lazy_thm_names;
 
 fun dest_thm_names thy =
   let
     val theory_name = Context.theory_long_name thy;
     fun thm_id i = Proofterm.make_thm_id (i, theory_name);
   in Inttab.fold_rev (fn (i, thm_name) => cons (thm_id i, thm_name)) (get_thm_names thy) [] end;
 
 fun lookup_thm_id thy =
   let
     val theories =
-      fold (fn thy' => Symtab.update (Context.theory_long_name thy', lazy_thm_names thy'))
-        (Theory.nodes_of thy) Symtab.empty;
+      Symtab.build (Theory.nodes_of thy |> fold (fn thy' =>
+        Symtab.update (Context.theory_long_name thy', lazy_thm_names thy')));
     fun lookup (thm_id: Proofterm.thm_id) =
       (case Symtab.lookup theories (#theory_name thm_id) of
         NONE => NONE
       | SOME lazy_tab => Inttab.lookup (Lazy.force lazy_tab) (#serial thm_id));
   in lookup end;
 
 fun lookup_thm thy =
   let val lookup = lookup_thm_id thy in
     fn thm =>
       (case Thm.derivation_id thm of
         NONE => NONE
       | SOME thm_id =>
           (case lookup thm_id of
             NONE => NONE
           | SOME thm_name => SOME (thm_id, thm_name)))
   end;
 
 val _ =
   Theory.setup
    (Theory.at_begin (fn thy =>
       if is_none (thm_names_of thy) then NONE
       else SOME (map_thm_names (K NONE) thy)) #>
     Theory.at_end (fn thy =>
       if is_some (thm_names_of thy) then NONE
       else
         let
           val lazy_tab =
             if Future.proofs_enabled 1
             then Lazy.lazy (fn () => make_thm_names thy)
             else Lazy.value (make_thm_names thy);
         in SOME (map_thm_names (K (SOME lazy_tab)) thy) end));
 
 
 (* retrieve theorems *)
 
 fun get_thms thy xname =
   #thms (Facts.retrieve (Context.Theory thy) (facts_of thy) (xname, Position.none));
 
 fun get_thm thy xname =
   Facts.the_single (xname, Position.none) (get_thms thy xname);
 
 fun transfer_theories thy =
   let
     val theories =
-      fold (fn thy' => Symtab.update (Context.theory_name thy', thy'))
-        (Theory.nodes_of thy) Symtab.empty;
+      Symtab.build (Theory.nodes_of thy |> fold (fn thy' =>
+        Symtab.update (Context.theory_name thy', thy')));
     fun transfer th =
       Thm.transfer (the_default thy (Symtab.lookup theories (Thm.theory_name th))) th;
   in transfer end;
 
 fun all_thms_of thy verbose =
   let
     val transfer = transfer_theories thy;
     val facts = facts_of thy;
     fun add (name, ths) =
       if not verbose andalso Facts.is_concealed facts name then I
       else append (map (`(Thm.get_name_hint) o transfer) ths);
   in Facts.fold_static add facts [] end;
 
 fun get_thm_name thy ((name, i), pos) =
   let
     val facts = facts_of thy;
     fun print_name () =
       Facts.markup_extern (Proof_Context.init_global thy) facts name |-> Markup.markup;
   in
     (case (Facts.lookup (Context.Theory thy) facts name, i) of
       (NONE, _) => error ("Undefined fact " ^ quote (print_name ()) ^ Position.here pos)
     | (SOME {thms = [thm], ...}, 0) => thm
     | (SOME {thms, ...}, 0) => Facts.err_single (print_name (), pos) thms
     | (SOME {thms, ...}, _) =>
         if i > 0 andalso i <= length thms then nth thms (i - 1)
         else Facts.err_selection (print_name (), pos) i thms)
     |> Thm.transfer thy
   end;
 
 
 
 (** store theorems **)
 
 (* fact specifications *)
 
 fun burrow_fact f = split_list #>> burrow f #> op ~~;
 fun burrow_facts f = split_list ##> burrow (burrow_fact f) #> op ~~;
 
 
 (* name theorems *)
 
 abstype name_flags = No_Name_Flags | Name_Flags of {pre: bool, official: bool}
 with
 
 val unnamed = No_Name_Flags;
 val official1 = Name_Flags {pre = true, official = true};
 val official2 = Name_Flags {pre = false, official = true};
 val unofficial1 = Name_Flags {pre = true, official = false};
 val unofficial2 = Name_Flags {pre = false, official = false};
 
 fun name_thm name_flags (name, pos) =
   Thm.solve_constraints #> (fn thm =>
     (case name_flags of
       No_Name_Flags => thm
     | Name_Flags {pre, official} =>
         thm
         |> (official andalso (not pre orelse Thm.raw_derivation_name thm = "")) ?
             Thm.name_derivation (name, pos)
         |> (name <> "" andalso (not pre orelse not (Thm.has_name_hint thm))) ?
             Thm.put_name_hint name));
 
 end;
 
 fun name_multi (name, pos) =
   Thm_Name.make_list name #> (map o apfst) (fn thm_name => (Thm_Name.flatten thm_name, pos));
 
 fun name_thms name_flags name_pos =
   name_multi name_pos #> map (uncurry (name_thm name_flags));
 
 
 (* apply theorems and attributes *)
 
 fun register_proofs thms thy = (thms, Thm.register_proofs (Lazy.value thms) thy);
 
 fun bind_name thy b = (Sign.full_name thy b, Binding.default_pos_of b);
 
 fun add_facts (b, fact) thy =
   let
     val (full_name, pos) = bind_name thy b;
     fun check fact =
       fact |> map_index (fn (i, thm) =>
         let
           fun err msg =
             error ("Malformed global fact " ^
               quote (full_name ^
                 (if length fact = 1 then "" else "(" ^ string_of_int (i + 1) ^ ")")) ^
               Position.here pos ^ "\n" ^ msg);
           val prop = Thm.plain_prop_of thm
             handle THM _ =>
               thm
               |> Thm.check_hyps (Context.Theory thy)
               |> Thm.full_prop_of;
         in
           ignore (Logic.unvarify_global (Term_Subst.zero_var_indexes prop))
             handle TYPE (msg, _, _) => err msg
               | TERM (msg, _) => err msg
               | ERROR msg => err msg
         end);
     val arg = (b, Lazy.map_finished (tap check) fact);
   in
     thy |> map_facts (Facts.add_static (Context.Theory thy) {strict = true, index = false} arg #> #2)
   end;
 
 fun check_thms_lazy (thms: thm list lazy) =
   if Proofterm.proofs_enabled () orelse Options.default_bool "strict_facts"
   then Lazy.force_value thms else thms;
 
 fun add_thms_lazy kind (b, thms) thy =
   if Binding.is_empty b then Thm.register_proofs (check_thms_lazy thms) thy
   else
     let
       val name_pos = bind_name thy b;
       val thms' =
         check_thms_lazy thms
         |> Lazy.map_finished (name_thms official1 name_pos #> map (Thm.kind_rule kind));
     in thy |> Thm.register_proofs thms' |> add_facts (b, thms') end;
 
 val app_facts =
   apfst flat oo fold_map (fn (thms, atts) => fn thy =>
     fold_map (Thm.theory_attributes atts) (map (Thm.transfer thy) thms) thy);
 
 fun apply_facts name_flags1 name_flags2 (b, facts) thy =
   if Binding.is_empty b then app_facts facts thy |-> register_proofs
   else
     let
       val name_pos = bind_name thy b;
       val (thms', thy') = thy
         |> app_facts (map (apfst (name_thms name_flags1 name_pos)) facts)
         |>> name_thms name_flags2 name_pos |-> register_proofs;
       val thy'' = thy' |> add_facts (b, Lazy.value thms');
     in (map (Thm.transfer thy'') thms', thy'') end;
 
 
 (* store_thm *)
 
 fun store_thm (b, th) =
   apply_facts official1 official2 (b, [([th], [])]) #>> the_single;
 
 fun store_thm_open (b, th) =
   apply_facts unofficial1 unofficial2 (b, [([th], [])]) #>> the_single;
 
 
 (* add_thms(s) *)
 
 val add_thmss =
   fold_map (fn ((b, thms), atts) => apply_facts official1 official2 (b, [(thms, atts)]));
 
 fun add_thms args =
   add_thmss (map (apfst (apsnd single)) args) #>> map the_single;
 
 val add_thm = yield_singleton add_thms;
 
 
 (* dynamic theorems *)
 
 fun add_thms_dynamic' context arg thy =
   let val (name, facts') = Facts.add_dynamic context arg (facts_of thy)
   in (name, map_facts (K facts') thy) end;
 
 fun add_thms_dynamic arg thy =
   add_thms_dynamic' (Context.Theory thy) arg thy |> snd;
 
 
 (* note_thmss *)
 
 fun note_thms kind ((b, more_atts), facts) thy =
   let
     val name = Sign.full_name thy b;
     val facts' = facts |> map (apsnd (fn atts => surround (Thm.kind kind) (atts @ more_atts)));
     val (thms', thy') = thy |> apply_facts official1 official2 (b, facts');
   in ((name, thms'), thy') end;
 
 val note_thmss = fold_map o note_thms;
 
 
 (* old-style defs *)
 
 local
 
 fun add unchecked overloaded = fold_map (fn ((b, prop), atts) => fn thy =>
   let
     val context = Defs.global_context thy;
     val ((_, def), thy') = Thm.add_def context unchecked overloaded (b, prop) thy;
     val thm = def
       |> Thm.forall_intr_frees
       |> Thm.forall_elim_vars 0
       |> Thm.varifyT_global;
   in thy' |> apply_facts unnamed official2 (b, [([thm], atts)]) |>> the_single end);
 
 in
 
 val add_defs = add false;
 val add_defs_unchecked = add true;
 
 end;
 
 end;
diff --git a/src/Pure/goal.ML b/src/Pure/goal.ML
--- a/src/Pure/goal.ML
+++ b/src/Pure/goal.ML
@@ -1,338 +1,338 @@
 (*  Title:      Pure/goal.ML
     Author:     Makarius
 
 Goals in tactical theorem proving, with support for forked proofs.
 *)
 
 signature BASIC_GOAL =
 sig
   val quick_and_dirty: bool Config.T
   val SELECT_GOAL: tactic -> int -> tactic
   val PREFER_GOAL: tactic -> int -> tactic
   val CONJUNCTS: tactic -> int -> tactic
   val PRECISE_CONJUNCTS: int -> tactic -> int -> tactic
 end;
 
 signature GOAL =
 sig
   include BASIC_GOAL
   val init: cterm -> thm
   val protect: int -> thm -> thm
   val conclude: thm -> thm
   val check_finished: Proof.context -> thm -> thm
   val finish: Proof.context -> thm -> thm
   val norm_result: Proof.context -> thm -> thm
   val skip_proofs_enabled: unit -> bool
   val future_result: Proof.context -> thm future -> term -> thm
   val prove_internal: Proof.context -> cterm list -> cterm -> (thm list -> tactic) -> thm
   val is_schematic: term -> bool
   val prove_common: Proof.context -> int option -> string list -> term list -> term list ->
     ({prems: thm list, context: Proof.context} -> tactic) -> thm list
   val prove_future: Proof.context -> string list -> term list -> term ->
     ({prems: thm list, context: Proof.context} -> tactic) -> thm
   val prove: Proof.context -> string list -> term list -> term ->
     ({prems: thm list, context: Proof.context} -> tactic) -> thm
   val prove_global_future: theory -> string list -> term list -> term ->
     ({prems: thm list, context: Proof.context} -> tactic) -> thm
   val prove_global: theory -> string list -> term list -> term ->
     ({prems: thm list, context: Proof.context} -> tactic) -> thm
   val prove_sorry: Proof.context -> string list -> term list -> term ->
     ({prems: thm list, context: Proof.context} -> tactic) -> thm
   val prove_sorry_global: theory -> string list -> term list -> term ->
     ({prems: thm list, context: Proof.context} -> tactic) -> thm
   val restrict: int -> int -> thm -> thm
   val unrestrict: int -> thm -> thm
   val conjunction_tac: int -> tactic
   val precise_conjunction_tac: int -> int -> tactic
   val recover_conjunction_tac: tactic
   val norm_hhf_tac: Proof.context -> int -> tactic
   val assume_rule_tac: Proof.context -> int -> tactic
 end;
 
 structure Goal: GOAL =
 struct
 
 (** goals **)
 
 (*
   -------- (init)
   C \<Longrightarrow> #C
 *)
 fun init C = Thm.instantiate ([], [((("A", 0), propT), C)]) Drule.protectI;
 
 (*
   A1 \<Longrightarrow> ... \<Longrightarrow> An \<Longrightarrow> C
   ------------------------ (protect n)
   A1 \<Longrightarrow> ... \<Longrightarrow> An \<Longrightarrow> #C
 *)
 fun protect n th = Drule.comp_no_flatten (th, n) 1 Drule.protectI;
 
 (*
   A \<Longrightarrow> ... \<Longrightarrow> #C
   ---------------- (conclude)
   A \<Longrightarrow> ... \<Longrightarrow> C
 *)
 fun conclude th = Drule.comp_no_flatten (th, Thm.nprems_of th) 1 Drule.protectD;
 
 (*
   #C
   --- (finish)
    C
 *)
 fun check_finished ctxt th =
   if Thm.no_prems th then th
   else
     raise THM ("Proof failed.\n" ^ Pretty.string_of (Goal_Display.pretty_goal ctxt th), 0, [th]);
 
 fun finish ctxt = check_finished ctxt #> conclude;
 
 
 
 (** results **)
 
 (* normal form *)
 
 fun norm_result ctxt =
   Drule.flexflex_unique (SOME ctxt)
   #> Raw_Simplifier.norm_hhf_protect ctxt
   #> Thm.strip_shyps
   #> Drule.zero_var_indexes;
 
 
 (* scheduling parameters *)
 
 fun skip_proofs_enabled () =
   let val skip = Options.default_bool "skip_proofs" in
     if Proofterm.proofs_enabled () andalso skip then
       (warning "Proof terms enabled -- cannot skip proofs"; false)
     else skip
   end;
 
 
 (* future_result *)
 
 fun future_result ctxt result prop =
   let
     val assms = Assumption.all_assms_of ctxt;
     val As = map Thm.term_of assms;
 
     val xs = map Free (fold Term.add_frees (prop :: As) []);
     val fixes = map (Thm.cterm_of ctxt) xs;
 
     val tfrees = fold Term.add_tfrees (prop :: As) [];
-    val tfrees_set = fold (Symtab.insert_set o #1) tfrees Symtab.empty;
+    val tfrees_set = Symtab.build (fold (Symtab.insert_set o #1) tfrees);
     val instT = map (fn (a, S) => (((a, 0), S), Thm.ctyp_of ctxt (TFree (a, S)))) tfrees;
 
     val global_prop =
       Logic.varify_types_global (fold_rev Logic.all xs (Logic.list_implies (As, prop)))
       |> Thm.cterm_of ctxt
       |> Thm.weaken_sorts' ctxt;
     val global_result = result |> Future.map
       (Drule.flexflex_unique (SOME ctxt) #>
         Drule.implies_intr_list assms #>
         Drule.forall_intr_list fixes #>
         Thm.adjust_maxidx_thm ~1 #>
         Thm.generalize (tfrees_set, Symtab.empty) 0 #>
         Thm.strip_shyps #>
         Thm.solve_constraints);
     val local_result =
       Thm.future global_result global_prop
       |> Thm.close_derivation \<^here>
       |> Thm.instantiate (instT, [])
       |> Drule.forall_elim_list fixes
       |> fold (Thm.elim_implies o Thm.assume) assms
       |> Thm.solve_constraints;
   in local_result end;
 
 
 
 (** tactical theorem proving **)
 
 (* prove_internal -- minimal checks, no normalization of result! *)
 
 fun prove_internal ctxt casms cprop tac =
   (case SINGLE (tac (map (Assumption.assume ctxt) casms)) (init cprop) of
     SOME th => Drule.implies_intr_list casms (finish ctxt th)
   | NONE => error "Tactic failed");
 
 
 (* prove variations *)
 
 fun is_schematic t =
   Term.exists_subterm Term.is_Var t orelse
   Term.exists_type (Term.exists_subtype Term.is_TVar) t;
 
 fun prove_common ctxt fork_pri xs asms props tac =
   let
     val thy = Proof_Context.theory_of ctxt;
 
     val schematic = exists is_schematic props;
     val immediate = is_none fork_pri;
     val future = Future.proofs_enabled 1 andalso not (Proofterm.proofs_enabled ());
     val skip = not immediate andalso not schematic andalso future andalso skip_proofs_enabled ();
 
     val pos = Position.thread_data ();
     fun err msg =
       cat_error msg
         ("The error(s) above occurred for the goal statement" ^ Position.here pos ^ ":\n" ^
           Syntax.string_of_term ctxt (Logic.list_implies (asms, Logic.mk_conjunction_list props)));
 
     fun cert_safe t = Thm.cterm_of ctxt (Envir.beta_norm (Term.no_dummy_patterns t))
       handle TERM (msg, _) => err msg | TYPE (msg, _, _) => err msg;
     val casms = map cert_safe asms;
     val cprops = map cert_safe props;
 
     val (prems, ctxt') = ctxt
       |> Variable.add_fixes_direct xs
       |> fold Variable.declare_term (asms @ props)
       |> Assumption.add_assumes casms
       ||> Variable.set_body true;
 
     val stmt = Thm.weaken_sorts' ctxt' (Conjunction.mk_conjunction_balanced cprops);
 
     fun tac' args st =
       if skip then ALLGOALS (Skip_Proof.cheat_tac ctxt) st before Skip_Proof.report ctxt
       else tac args st;
     fun result () =
       (case SINGLE (tac' {prems = prems, context = ctxt'}) (init stmt) of
         NONE => err "Tactic failed"
       | SOME st =>
           let
             val _ =
               Context.subthy_id (Thm.theory_id st, Context.theory_id thy) orelse
                 err "Bad background theory of goal state";
             val res =
               (finish ctxt' st
                 |> Drule.flexflex_unique (SOME ctxt')
                 |> Thm.check_shyps ctxt'
                 |> Thm.check_hyps (Context.Proof ctxt'))
               handle THM (msg, _, _) => err msg | ERROR msg => err msg;
           in
             if Unify.matches_list (Context.Proof ctxt') [Thm.term_of stmt] [Thm.prop_of res]
             then res
             else err ("Proved a different theorem: " ^ Syntax.string_of_term ctxt' (Thm.prop_of res))
           end);
     val res =
       if immediate orelse schematic orelse not future orelse skip then result ()
       else
         future_result ctxt'
           (Execution.fork {name = "Goal.prove", pos = Position.thread_data (), pri = the fork_pri}
             result)
           (Thm.term_of stmt);
   in
     res
     |> Thm.close_derivation \<^here>
     |> Conjunction.elim_balanced (length props)
     |> map (Assumption.export false ctxt' ctxt)
     |> Variable.export ctxt' ctxt
     |> map Drule.zero_var_indexes
   end;
 
 fun prove_future_pri ctxt pri xs asms prop tac =
   hd (prove_common ctxt (SOME pri) xs asms [prop] tac);
 
 fun prove_future ctxt = prove_future_pri ctxt ~1;
 
 fun prove ctxt xs asms prop tac = hd (prove_common ctxt NONE xs asms [prop] tac);
 
 fun prove_global_future thy xs asms prop tac =
   Drule.export_without_context (prove_future (Proof_Context.init_global thy) xs asms prop tac);
 
 fun prove_global thy xs asms prop tac =
   Drule.export_without_context (prove (Proof_Context.init_global thy) xs asms prop tac);
 
 
 (* skip proofs *)
 
 val quick_and_dirty = Config.declare_option_bool ("quick_and_dirty", \<^here>);
 
 fun prove_sorry ctxt xs asms prop tac =
   if Config.get ctxt quick_and_dirty then
     prove ctxt xs asms prop (fn _ => ALLGOALS (Skip_Proof.cheat_tac ctxt))
   else (if Future.proofs_enabled 1 then prove_future_pri ctxt ~2 else prove ctxt) xs asms prop tac;
 
 fun prove_sorry_global thy xs asms prop tac =
   Drule.export_without_context
     (prove_sorry (Proof_Context.init_global thy) xs asms prop tac);
 
 
 
 (** goal structure **)
 
 (* rearrange subgoals *)
 
 fun restrict i n st =
   if i < 1 orelse n < 1 orelse i + n - 1 > Thm.nprems_of st
   then raise THM ("Goal.restrict", i, [st])
   else rotate_prems (i - 1) st |> protect n;
 
 fun unrestrict i = conclude #> rotate_prems (1 - i);
 
 (*with structural marker*)
 fun SELECT_GOAL tac i st =
   if Thm.nprems_of st = 1 andalso i = 1 then tac st
   else (PRIMITIVE (restrict i 1) THEN tac THEN PRIMITIVE (unrestrict i)) st;
 
 (*without structural marker*)
 fun PREFER_GOAL tac i st =
   if i < 1 orelse i > Thm.nprems_of st then Seq.empty
   else (PRIMITIVE (rotate_prems (i - 1)) THEN tac THEN PRIMITIVE (rotate_prems (1 - i))) st;
 
 
 (* multiple goals *)
 
 fun precise_conjunction_tac 0 i = eq_assume_tac i
   | precise_conjunction_tac 1 i = SUBGOAL (K all_tac) i
   | precise_conjunction_tac n i = PRIMITIVE (Drule.with_subgoal i (Conjunction.curry_balanced n));
 
 val adhoc_conjunction_tac = REPEAT_ALL_NEW
   (SUBGOAL (fn (goal, i) =>
     if can Logic.dest_conjunction goal then resolve0_tac [Conjunction.conjunctionI] i
     else no_tac));
 
 val conjunction_tac = SUBGOAL (fn (goal, i) =>
   precise_conjunction_tac (length (Logic.dest_conjunctions goal)) i ORELSE
   TRY (adhoc_conjunction_tac i));
 
 val recover_conjunction_tac = PRIMITIVE (fn th =>
   Conjunction.uncurry_balanced (Thm.nprems_of th) th);
 
 fun PRECISE_CONJUNCTS n tac =
   SELECT_GOAL (precise_conjunction_tac n 1
     THEN tac
     THEN recover_conjunction_tac);
 
 fun CONJUNCTS tac =
   SELECT_GOAL (conjunction_tac 1
     THEN tac
     THEN recover_conjunction_tac);
 
 
 (* hhf normal form *)
 
 fun norm_hhf_tac ctxt =
   resolve_tac ctxt [Drule.asm_rl]  (*cheap approximation -- thanks to builtin Logic.flatten_params*)
   THEN' SUBGOAL (fn (t, i) =>
     if Drule.is_norm_hhf t then all_tac
     else rewrite_goal_tac ctxt Drule.norm_hhf_eqs i);
 
 
 (* non-atomic goal assumptions *)
 
 fun non_atomic (Const ("Pure.imp", _) $ _ $ _) = true
   | non_atomic (Const ("Pure.all", _) $ _) = true
   | non_atomic _ = false;
 
 fun assume_rule_tac ctxt = norm_hhf_tac ctxt THEN' CSUBGOAL (fn (goal, i) =>
   let
     val ((_, goal'), ctxt') = Variable.focus_cterm NONE goal ctxt;
     val goal'' = Drule.cterm_rule (singleton (Variable.export ctxt' ctxt)) goal';
     val Rs = filter (non_atomic o Thm.term_of) (Drule.strip_imp_prems goal'');
     val tacs = Rs |> map (fn R =>
       eresolve_tac ctxt [Raw_Simplifier.norm_hhf ctxt (Thm.trivial R)] THEN_ALL_NEW assume_tac ctxt);
   in fold_rev (curry op APPEND') tacs (K no_tac) i end);
 
 end;
 
 structure Basic_Goal: BASIC_GOAL = Goal;
 open Basic_Goal;
diff --git a/src/Pure/more_thm.ML b/src/Pure/more_thm.ML
--- a/src/Pure/more_thm.ML
+++ b/src/Pure/more_thm.ML
@@ -1,763 +1,763 @@
 (*  Title:      Pure/more_thm.ML
     Author:     Makarius
 
 Further operations on type ctyp/cterm/thm, outside the inference kernel.
 *)
 
 infix aconvc;
 
 signature BASIC_THM =
 sig
   include BASIC_THM
   val show_consts: bool Config.T
   val show_hyps: bool Config.T
   val show_tags: bool Config.T
   structure Ctermtab: TABLE
   structure Thmtab: TABLE
   val aconvc: cterm * cterm -> bool
   type attribute = Context.generic * thm -> Context.generic option * thm option
 end;
 
 signature THM =
 sig
   include THM
   structure Ctermtab: TABLE
   structure Thmtab: TABLE
   val eq_ctyp: ctyp * ctyp -> bool
   val aconvc: cterm * cterm -> bool
   val add_tvars: thm -> ctyp list -> ctyp list
   val add_frees: thm -> cterm list -> cterm list
   val add_vars: thm -> cterm list -> cterm list
   val dest_funT: ctyp -> ctyp * ctyp
   val strip_type: ctyp -> ctyp list * ctyp
   val all_name: Proof.context -> string * cterm -> cterm -> cterm
   val all: Proof.context -> cterm -> cterm -> cterm
   val mk_binop: cterm -> cterm -> cterm -> cterm
   val dest_binop: cterm -> cterm * cterm
   val dest_implies: cterm -> cterm * cterm
   val dest_equals: cterm -> cterm * cterm
   val dest_equals_lhs: cterm -> cterm
   val dest_equals_rhs: cterm -> cterm
   val lhs_of: thm -> cterm
   val rhs_of: thm -> cterm
   val fast_term_ord: cterm ord
   val term_ord: cterm ord
   val thm_ord: thm ord
   val cterm_cache: (cterm -> 'a) -> cterm -> 'a
   val thm_cache: (thm -> 'a) -> thm -> 'a
   val is_reflexive: thm -> bool
   val eq_thm: thm * thm -> bool
   val eq_thm_prop: thm * thm -> bool
   val eq_thm_strict: thm * thm -> bool
   val equiv_thm: theory -> thm * thm -> bool
   val class_triv: theory -> class -> thm
   val of_sort: ctyp * sort -> thm list
   val is_dummy: thm -> bool
   val add_thm: thm -> thm list -> thm list
   val del_thm: thm -> thm list -> thm list
   val merge_thms: thm list * thm list -> thm list
   val item_net: thm Item_Net.T
   val item_net_intro: thm Item_Net.T
   val item_net_elim: thm Item_Net.T
   val declare_hyps: cterm -> Proof.context -> Proof.context
   val assume_hyps: cterm -> Proof.context -> thm * Proof.context
   val unchecked_hyps: Proof.context -> Proof.context
   val restore_hyps: Proof.context -> Proof.context -> Proof.context
   val undeclared_hyps: Context.generic -> thm -> term list
   val check_hyps: Context.generic -> thm -> thm
   val declare_term_sorts: term -> Proof.context -> Proof.context
   val extra_shyps': Proof.context -> thm -> sort list
   val check_shyps: Proof.context -> thm -> thm
   val weaken_sorts': Proof.context -> cterm -> cterm
   val elim_implies: thm -> thm -> thm
   val forall_intr_name: string * cterm -> thm -> thm
   val forall_elim_var: int -> thm -> thm
   val forall_elim_vars: int -> thm -> thm
   val instantiate_frees: ((string * sort) * ctyp) list * ((string * typ) * cterm) list -> thm -> thm
   val instantiate': ctyp option list -> cterm option list -> thm -> thm
   val forall_intr_frees: thm -> thm
   val unvarify_global: theory -> thm -> thm
   val unvarify_axiom: theory -> string -> thm
   val rename_params_rule: string list * int -> thm -> thm
   val rename_boundvars: term -> term -> thm -> thm
   val add_axiom: Proof.context -> binding * term -> theory -> (string * thm) * theory
   val add_axiom_global: binding * term -> theory -> (string * thm) * theory
   val add_def: Defs.context -> bool -> bool -> binding * term -> theory -> (string * thm) * theory
   val add_def_global: bool -> bool -> binding * term -> theory -> (string * thm) * theory
   type attribute = Context.generic * thm -> Context.generic option * thm option
   type binding = binding * attribute list
   val tag_rule: string * string -> thm -> thm
   val untag_rule: string -> thm -> thm
   val is_free_dummy: thm -> bool
   val tag_free_dummy: thm -> thm
   val def_name: string -> string
   val def_name_optional: string -> string -> string
   val def_binding: Binding.binding -> Binding.binding
   val def_binding_optional: Binding.binding -> Binding.binding -> Binding.binding
   val make_def_binding: bool -> Binding.binding -> Binding.binding
   val has_name_hint: thm -> bool
   val get_name_hint: thm -> string
   val put_name_hint: string -> thm -> thm
   val theoremK: string
   val legacy_get_kind: thm -> string
   val kind_rule: string -> thm -> thm
   val rule_attribute: thm list -> (Context.generic -> thm -> thm) -> attribute
   val declaration_attribute: (thm -> Context.generic -> Context.generic) -> attribute
   val mixed_attribute: (Context.generic * thm -> Context.generic * thm) -> attribute
   val apply_attribute: attribute -> thm -> Context.generic -> thm * Context.generic
   val attribute_declaration: attribute -> thm -> Context.generic -> Context.generic
   val theory_attributes: attribute list -> thm -> theory -> thm * theory
   val proof_attributes: attribute list -> thm -> Proof.context -> thm * Proof.context
   val no_attributes: 'a -> 'a * 'b list
   val simple_fact: 'a -> ('a * 'b list) list
   val tag: string * string -> attribute
   val untag: string -> attribute
   val kind: string -> attribute
   val register_proofs: thm list lazy -> theory -> theory
   val consolidate_theory: theory -> unit
   val expose_theory: theory -> unit
   val show_consts: bool Config.T
   val show_hyps: bool Config.T
   val show_tags: bool Config.T
   val pretty_thm_raw: Proof.context -> {quote: bool, show_hyps: bool} -> thm -> Pretty.T
   val pretty_thm: Proof.context -> thm -> Pretty.T
   val pretty_thm_item: Proof.context -> thm -> Pretty.T
   val pretty_thm_global: theory -> thm -> Pretty.T
   val string_of_thm: Proof.context -> thm -> string
   val string_of_thm_global: theory -> thm -> string
 end;
 
 structure Thm: THM =
 struct
 
 (** basic operations **)
 
 (* collecting ctyps and cterms *)
 
 val eq_ctyp = op = o apply2 Thm.typ_of;
 val op aconvc = op aconv o apply2 Thm.term_of;
 
 val add_tvars = Thm.fold_atomic_ctyps (fn a => is_TVar (Thm.typ_of a) ? insert eq_ctyp a);
 val add_frees = Thm.fold_atomic_cterms (fn a => is_Free (Thm.term_of a) ? insert (op aconvc) a);
 val add_vars = Thm.fold_atomic_cterms (fn a => is_Var (Thm.term_of a) ? insert (op aconvc) a);
 
 
 (* ctyp operations *)
 
 fun dest_funT cT =
   (case Thm.typ_of cT of
     Type ("fun", _) => let val [A, B] = Thm.dest_ctyp cT in (A, B) end
   | T => raise TYPE ("dest_funT", [T], []));
 
 (* ctyp version of strip_type: maps  [T1,...,Tn]--->T  to   ([T1,T2,...,Tn], T) *)
 fun strip_type cT =
   (case Thm.typ_of cT of
     Type ("fun", _) =>
       let
         val (cT1, cT2) = dest_funT cT;
         val (cTs, cT') = strip_type cT2
       in (cT1 :: cTs, cT') end
   | _ => ([], cT));
 
 
 (* cterm operations *)
 
 fun all_name ctxt (x, t) A =
   let
     val T = Thm.typ_of_cterm t;
     val all_const = Thm.cterm_of ctxt (Const ("Pure.all", (T --> propT) --> propT));
   in Thm.apply all_const (Thm.lambda_name (x, t) A) end;
 
 fun all ctxt t A = all_name ctxt ("", t) A;
 
 fun mk_binop c a b = Thm.apply (Thm.apply c a) b;
 fun dest_binop ct = (Thm.dest_arg1 ct, Thm.dest_arg ct);
 
 fun dest_implies ct =
   (case Thm.term_of ct of
     Const ("Pure.imp", _) $ _ $ _ => dest_binop ct
   | _ => raise TERM ("dest_implies", [Thm.term_of ct]));
 
 fun dest_equals ct =
   (case Thm.term_of ct of
     Const ("Pure.eq", _) $ _ $ _ => dest_binop ct
   | _ => raise TERM ("dest_equals", [Thm.term_of ct]));
 
 fun dest_equals_lhs ct =
   (case Thm.term_of ct of
     Const ("Pure.eq", _) $ _ $ _ => Thm.dest_arg1 ct
   | _ => raise TERM ("dest_equals_lhs", [Thm.term_of ct]));
 
 fun dest_equals_rhs ct =
   (case Thm.term_of ct of
     Const ("Pure.eq", _) $ _ $ _ => Thm.dest_arg ct
   | _ => raise TERM ("dest_equals_rhs", [Thm.term_of ct]));
 
 val lhs_of = dest_equals_lhs o Thm.cprop_of;
 val rhs_of = dest_equals_rhs o Thm.cprop_of;
 
 
 (* certified term order *)
 
 val fast_term_ord = Term_Ord.fast_term_ord o apply2 Thm.term_of;
 val term_ord = Term_Ord.term_ord o apply2 Thm.term_of;
 
 
 (* thm order: ignores theory context! *)
 
 val thm_ord =
   Term_Ord.fast_term_ord o apply2 Thm.prop_of
   ||| list_ord (prod_ord Term_Ord.fast_term_ord Term_Ord.fast_term_ord) o apply2 Thm.tpairs_of
   ||| list_ord Term_Ord.fast_term_ord o apply2 Thm.hyps_of
   ||| list_ord Term_Ord.sort_ord o apply2 Thm.shyps_of;
 
 
 (* tables and caches *)
 
 structure Ctermtab = Table(type key = cterm val ord = fast_term_ord);
 structure Thmtab = Table(type key = thm val ord = thm_ord);
 
 fun cterm_cache f = Cache.create Ctermtab.empty Ctermtab.lookup Ctermtab.update f;
 fun thm_cache f = Cache.create Thmtab.empty Thmtab.lookup Thmtab.update f;
 
 
 (* equality *)
 
 fun is_reflexive th = op aconv (Logic.dest_equals (Thm.prop_of th))
   handle TERM _ => false;
 
 val eq_thm = is_equal o thm_ord;
 
 val eq_thm_prop = op aconv o apply2 Thm.full_prop_of;
 
 fun eq_thm_strict ths =
   eq_thm ths andalso
   Context.eq_thy_id (apply2 Thm.theory_id ths) andalso
   op = (apply2 Thm.maxidx_of ths) andalso
   op = (apply2 Thm.get_tags ths);
 
 
 (* pattern equivalence *)
 
 fun equiv_thm thy ths =
   Pattern.equiv thy (apply2 (Thm.full_prop_of o Thm.transfer thy) ths);
 
 
 (* type classes and sorts *)
 
 fun class_triv thy c =
   Thm.of_class (Thm.global_ctyp_of thy (TVar ((Name.aT, 0), [c])), c);
 
 fun of_sort (T, S) = map (fn c => Thm.of_class (T, c)) S;
 
 
 (* misc operations *)
 
 fun is_dummy thm =
   (case try Logic.dest_term (Thm.concl_of thm) of
     NONE => false
   | SOME t => Term.is_dummy_pattern (Term.head_of t));
 
 
 (* collections of theorems in canonical order *)
 
 val add_thm = update eq_thm_prop;
 val del_thm = remove eq_thm_prop;
 val merge_thms = merge eq_thm_prop;
 
 val item_net = Item_Net.init eq_thm_prop (single o Thm.full_prop_of);
 val item_net_intro = Item_Net.init eq_thm_prop (single o Thm.concl_of);
 val item_net_elim = Item_Net.init eq_thm_prop (single o Thm.major_prem_of);
 
 
 
 (** declared hyps and sort hyps **)
 
 structure Hyps = Proof_Data
 (
   type T = {checked_hyps: bool, hyps: Termtab.set, shyps: sort Ord_List.T};
   fun init _ : T = {checked_hyps = true, hyps = Termtab.empty, shyps = []};
 );
 
 fun map_hyps f = Hyps.map (fn {checked_hyps, hyps, shyps} =>
   let val (checked_hyps', hyps', shyps') = f (checked_hyps, hyps, shyps)
   in {checked_hyps = checked_hyps', hyps = hyps', shyps = shyps'} end);
 
 
 (* hyps *)
 
 fun declare_hyps raw_ct ctxt = ctxt |> map_hyps (fn (checked_hyps, hyps, shyps) =>
   let
     val ct = Thm.transfer_cterm (Proof_Context.theory_of ctxt) raw_ct;
     val hyps' = Termtab.update (Thm.term_of ct, ()) hyps;
   in (checked_hyps, hyps', shyps) end);
 
 fun assume_hyps ct ctxt = (Thm.assume ct, declare_hyps ct ctxt);
 
 val unchecked_hyps = map_hyps (fn (_, hyps, shyps) => (false, hyps, shyps));
 
 fun restore_hyps ctxt =
   map_hyps (fn (_, hyps, shyps) => (#checked_hyps (Hyps.get ctxt), hyps, shyps));
 
 fun undeclared_hyps context th =
   Thm.hyps_of th
   |> filter_out
     (case context of
       Context.Theory _ => K false
     | Context.Proof ctxt =>
         (case Hyps.get ctxt of
           {checked_hyps = false, ...} => K true
         | {hyps, ...} => Termtab.defined hyps));
 
 fun check_hyps context th =
   (case undeclared_hyps context th of
     [] => th
   | undeclared =>
       error (Pretty.string_of (Pretty.big_list "Undeclared hyps:"
         (map (Pretty.item o single o Syntax.pretty_term (Syntax.init_pretty context)) undeclared))));
 
 
 (* shyps *)
 
 fun declare_term_sorts t =
   map_hyps (fn (checked_hyps, hyps, shyps) =>
     (checked_hyps, hyps, Sorts.insert_term t shyps));
 
 fun extra_shyps' ctxt th =
   Sorts.subtract (#shyps (Hyps.get ctxt)) (Thm.extra_shyps th);
 
 fun check_shyps ctxt raw_th =
   let
     val th = Thm.strip_shyps raw_th;
     val extra_shyps = extra_shyps' ctxt th;
   in
     if null extra_shyps then th
     else error (Pretty.string_of (Pretty.block (Pretty.str "Pending sort hypotheses:" ::
       Pretty.brk 1 :: Pretty.commas (map (Syntax.pretty_sort ctxt) extra_shyps))))
   end;
 
 val weaken_sorts' = Thm.weaken_sorts o #shyps o Hyps.get;
 
 
 
 (** basic derived rules **)
 
 (*Elimination of implication
   A    A \<Longrightarrow> B
   ------------
         B
 *)
 fun elim_implies thA thAB = Thm.implies_elim thAB thA;
 
 
 (* forall_intr_name *)
 
 fun forall_intr_name (a, x) th =
   let
     val th' = Thm.forall_intr x th;
     val prop' = (case Thm.prop_of th' of all $ Abs (_, T, b) => all $ Abs (a, T, b));
   in Thm.renamed_prop prop' th' end;
 
 
 (* forall_elim_var(s) *)
 
 local
 
 fun dest_all ct =
   (case Thm.term_of ct of
     Const ("Pure.all", _) $ Abs (a, _, _) =>
       let val (x, ct') = Thm.dest_abs NONE (Thm.dest_arg ct)
       in SOME ((a, Thm.ctyp_of_cterm x), ct') end
   | _ => NONE);
 
 fun dest_all_list ct =
   (case dest_all ct of
     NONE => []
   | SOME (v, ct') => v :: dest_all_list ct');
 
 fun forall_elim_vars_list vars i th =
   let
     val used =
       (Thm.fold_terms o Term.fold_aterms)
         (fn Var ((x, j), _) => if i = j then insert (op =) x else I | _ => I) th [];
     val vars' = (Name.variant_list used (map #1 vars), vars)
       |> ListPair.map (fn (x, (_, T)) => Thm.var ((x, i), T));
   in fold Thm.forall_elim vars' th end;
 
 in
 
 fun forall_elim_vars i th =
   forall_elim_vars_list (dest_all_list (Thm.cprop_of th)) i th;
 
 fun forall_elim_var i th =
   let
     val vars =
       (case dest_all (Thm.cprop_of th) of
         SOME (v, _) => [v]
       | NONE => raise THM ("forall_elim_var", i, [th]));
   in forall_elim_vars_list vars i th end;
 
 end;
 
 
 (* instantiate frees *)
 
 fun instantiate_frees ([], []) th = th
   | instantiate_frees (instT, inst) th =
       let
         val idx = Thm.maxidx_of th + 1;
         fun index ((a, A), b) = (((a, idx), A), b);
         val insts = (map index instT, map index inst);
-        val tfrees = fold (Symtab.insert_set o #1 o #1) instT Symtab.empty;
-        val frees = fold (Symtab.insert_set o #1 o #1) inst Symtab.empty;
+        val tfrees = Symtab.build (fold (Symtab.insert_set o #1 o #1) instT);
+        val frees = Symtab.build (fold (Symtab.insert_set o #1 o #1) inst);
 
         val hyps = Thm.chyps_of th;
         val inst_cterm =
           Thm.generalize_cterm (tfrees, frees) idx #>
           Thm.instantiate_cterm insts;
       in
         th
         |> fold_rev Thm.implies_intr hyps
         |> Thm.generalize (tfrees, frees) idx
         |> Thm.instantiate insts
         |> fold (elim_implies o Thm.assume o inst_cterm) hyps
       end;
 
 
 (* instantiate by left-to-right occurrence of variables *)
 
 fun instantiate' cTs cts thm =
   let
     fun err msg =
       raise TYPE ("instantiate': " ^ msg,
         map_filter (Option.map Thm.typ_of) cTs,
         map_filter (Option.map Thm.term_of) cts);
 
     fun zip_vars xs ys =
       zip_options xs ys handle ListPair.UnequalLengths =>
         err "more instantiations than variables in thm";
 
     val thm' =
       Thm.instantiate ((zip_vars (rev (Thm.fold_terms Term.add_tvars thm [])) cTs), []) thm;
     val thm'' =
       Thm.instantiate ([], zip_vars (rev (Thm.fold_terms Term.add_vars thm' [])) cts) thm';
   in thm'' end;
 
 
 (* forall_intr_frees: generalization over all suitable Free variables *)
 
 fun forall_intr_frees th =
   let
     val fixed =
-      Term_Subst.Frees.empty
-      |> fold Term_Subst.add_frees (Thm.terms_of_tpairs (Thm.tpairs_of th))
-      |> fold Term_Subst.add_frees (Thm.hyps_of th);
+      Term_Subst.Frees.build
+       (fold Term_Subst.add_frees (Thm.terms_of_tpairs (Thm.tpairs_of th)) #>
+        fold Term_Subst.add_frees (Thm.hyps_of th));
     val frees =
       Thm.fold_atomic_cterms (fn a =>
         (case Thm.term_of a of
           Free v => not (Term_Subst.Frees.defined fixed v) ? insert (op aconvc) a
         | _ => I)) th [];
   in fold Thm.forall_intr frees th end;
 
 
 (* unvarify_global: global schematic variables *)
 
 fun unvarify_global thy th =
   let
     val prop = Thm.full_prop_of th;
     val _ = map Logic.unvarify_global (prop :: Thm.hyps_of th)
       handle TERM (msg, _) => raise THM (msg, 0, [th]);
 
     val cert = Thm.global_cterm_of thy;
     val certT = Thm.global_ctyp_of thy;
 
     val instT =
-      (prop, Term_Subst.TVars.empty) |-> (Term.fold_types o Term.fold_atyps)
+      Term_Subst.TVars.build (prop |> (Term.fold_types o Term.fold_atyps)
         (fn T => fn instT =>
           (case T of
             TVar (v as ((a, _), S)) =>
               if Term_Subst.TVars.defined instT v then instT
               else Term_Subst.TVars.update (v, TFree (a, S)) instT
-          | _ => instT));
+          | _ => instT)));
     val cinstT = Term_Subst.TVars.map (K certT) instT;
     val cinst =
-      (prop, Term_Subst.Vars.empty) |-> Term.fold_aterms
+      Term_Subst.Vars.build (prop |> Term.fold_aterms
         (fn t => fn inst =>
           (case t of
             Var ((x, i), T) =>
               let val T' = Term_Subst.instantiateT instT T
               in Term_Subst.Vars.update (((x, i), T'), cert (Free ((x, T')))) inst end
-          | _ => inst));
+          | _ => inst)));
   in Thm.instantiate (Term_Subst.TVars.dest cinstT, Term_Subst.Vars.dest cinst) th end;
 
 fun unvarify_axiom thy = unvarify_global thy o Thm.axiom thy;
 
 
 (* user renaming of parameters in a subgoal *)
 
 (*The names, if distinct, are used for the innermost parameters of subgoal i;
   preceding parameters may be renamed to make all parameters distinct.*)
 fun rename_params_rule (names, i) st =
   let
     val (_, Bs, Bi, C) = Thm.dest_state (st, i);
     val params = map #1 (Logic.strip_params Bi);
     val short = length params - length names;
     val names' =
       if short < 0 then error "More names than parameters in subgoal!"
       else Name.variant_list names (take short params) @ names;
     val free_names = Term.fold_aterms (fn Free (x, _) => insert (op =) x | _ => I) Bi [];
     val Bi' = Logic.list_rename_params names' Bi;
   in
     (case duplicates (op =) names of
       a :: _ => (warning ("Can't rename.  Bound variables not distinct: " ^ a); st)
     | [] =>
       (case inter (op =) names free_names of
         a :: _ => (warning ("Can't rename.  Bound/Free variable clash: " ^ a); st)
       | [] => Thm.renamed_prop (Logic.list_implies (Bs @ [Bi'], C)) st))
   end;
 
 
 (* preservation of bound variable names *)
 
 fun rename_boundvars pat obj th =
   (case Term.rename_abs pat obj (Thm.prop_of th) of
     NONE => th
   | SOME prop' => Thm.renamed_prop prop' th);
 
 
 
 (** specification primitives **)
 
 (* rules *)
 
 fun stripped_sorts thy t =
   let
     val tfrees = rev (Term.add_tfrees t []);
     val tfrees' = map (fn a => (a, [])) (Name.variant_list [] (map #1 tfrees));
     val recover =
       map2 (fn (a', S') => fn (a, S) => (((a', 0), S'), Thm.global_ctyp_of thy (TVar ((a, 0), S))))
         tfrees' tfrees;
     val strip = map (apply2 TFree) (tfrees ~~ tfrees');
     val t' = Term.map_types (Term.map_atyps (perhaps (AList.lookup (op =) strip))) t;
   in (strip, recover, t') end;
 
 fun add_axiom ctxt (b, prop) thy =
   let
     val _ = Sign.no_vars ctxt prop;
     val (strip, recover, prop') = stripped_sorts thy prop;
     val constraints = map (fn (TFree (_, S), T) => (T, S)) strip;
     val of_sorts = maps (fn (T as TFree (_, S), _) => of_sort (Thm.ctyp_of ctxt T, S)) strip;
 
     val thy' = thy
       |> Theory.add_axiom ctxt (b, Logic.list_implies (maps Logic.mk_of_sort constraints, prop'));
     val axm_name = Sign.full_name thy' b;
     val axm' = Thm.axiom thy' axm_name;
     val thm =
       Thm.instantiate (recover, []) axm'
       |> unvarify_global thy'
       |> fold elim_implies of_sorts;
   in ((axm_name, thm), thy') end;
 
 fun add_axiom_global arg thy = add_axiom (Syntax.init_pretty_global thy) arg thy;
 
 fun add_def (context as (ctxt, _)) unchecked overloaded (b, prop) thy =
   let
     val _ = Sign.no_vars ctxt prop;
     val prems = map (Thm.cterm_of ctxt) (Logic.strip_imp_prems prop);
     val (_, recover, concl') = stripped_sorts thy (Logic.strip_imp_concl prop);
 
     val thy' = Theory.add_def context unchecked overloaded (b, concl') thy;
     val axm_name = Sign.full_name thy' b;
     val axm' = Thm.axiom thy' axm_name;
     val thm =
       Thm.instantiate (recover, []) axm'
       |> unvarify_global thy'
       |> fold_rev Thm.implies_intr prems;
   in ((axm_name, thm), thy') end;
 
 fun add_def_global unchecked overloaded arg thy =
   add_def (Defs.global_context thy) unchecked overloaded arg thy;
 
 
 
 (** theorem tags **)
 
 (* add / delete tags *)
 
 fun tag_rule tg = Thm.map_tags (insert (op =) tg);
 fun untag_rule s = Thm.map_tags (filter_out (fn (s', _) => s = s'));
 
 
 (* free dummy thm -- for abstract closure *)
 
 val free_dummyN = "free_dummy";
 fun is_free_dummy thm = Properties.defined (Thm.get_tags thm) free_dummyN;
 val tag_free_dummy = tag_rule (free_dummyN, "");
 
 
 (* def_name *)
 
 fun def_name c = c ^ "_def";
 
 fun def_name_optional c "" = def_name c
   | def_name_optional _ name = name;
 
 val def_binding = Binding.map_name def_name #> Binding.reset_pos;
 fun def_binding_optional b name = if Binding.is_empty name then def_binding b else name;
 fun make_def_binding cond b = if cond then def_binding b else Binding.empty;
 
 
 (* unofficial theorem names *)
 
 fun has_name_hint thm = AList.defined (op =) (Thm.get_tags thm) Markup.nameN;
 fun the_name_hint thm = the (AList.lookup (op =) (Thm.get_tags thm) Markup.nameN);
 fun get_name_hint thm = if has_name_hint thm then the_name_hint thm else "??.unknown";
 
 fun put_name_hint name = untag_rule Markup.nameN #> tag_rule (Markup.nameN, name);
 
 
 (* theorem kinds *)
 
 val theoremK = "theorem";
 
 fun legacy_get_kind thm = the_default "" (Properties.get (Thm.get_tags thm) Markup.kindN);
 
 fun kind_rule k = tag_rule (Markup.kindN, k) o untag_rule Markup.kindN;
 
 
 
 (** attributes **)
 
 (*attributes subsume any kind of rules or context modifiers*)
 type attribute = Context.generic * thm -> Context.generic option * thm option;
 
 type binding = binding * attribute list;
 
 fun rule_attribute ths f (x, th) =
   (NONE,
     (case find_first is_free_dummy (th :: ths) of
       SOME th' => SOME th'
     | NONE => SOME (f x th)));
 
 fun declaration_attribute f (x, th) =
   (if is_free_dummy th then NONE else SOME (f th x), NONE);
 
 fun mixed_attribute f (x, th) =
   let val (x', th') = f (x, th) in (SOME x', SOME th') end;
 
 fun apply_attribute (att: attribute) th x =
   let val (x', th') = att (x, check_hyps x (Thm.transfer'' x th))
   in (the_default th th', the_default x x') end;
 
 fun attribute_declaration att th x = #2 (apply_attribute att th x);
 
 fun apply_attributes mk dest =
   let
     fun app [] th x = (th, x)
       | app (att :: atts) th x = apply_attribute att th (mk x) ||> dest |-> app atts;
   in app end;
 
 val theory_attributes = apply_attributes Context.Theory Context.the_theory;
 val proof_attributes = apply_attributes Context.Proof Context.the_proof;
 
 fun no_attributes x = (x, []);
 fun simple_fact x = [(x, [])];
 
 fun tag tg = rule_attribute [] (K (tag_rule tg));
 fun untag s = rule_attribute [] (K (untag_rule s));
 fun kind k = rule_attribute [] (K (k <> "" ? kind_rule k));
 
 
 
 (** forked proofs **)
 
 structure Proofs = Theory_Data
 (
   type T = thm list lazy Inttab.table;
   val empty = Inttab.empty;
   val extend = I;
   val merge = Inttab.merge (K true);
 );
 
 fun reset_proofs thy =
   if Inttab.is_empty (Proofs.get thy) then NONE
   else SOME (Proofs.put Inttab.empty thy);
 
 val _ = Theory.setup (Theory.at_begin reset_proofs);
 
 fun register_proofs ths thy =
   let val entry = (serial (), Lazy.map_finished (map Thm.trim_context) ths)
   in (Proofs.map o Inttab.update) entry thy end;
 
 fun force_proofs thy =
   Proofs.get thy |> Inttab.dest |> maps (map (Thm.transfer thy) o Lazy.force o #2);
 
 val consolidate_theory = Thm.consolidate o force_proofs;
 
 fun expose_theory thy =
   if Proofterm.export_enabled ()
   then Thm.expose_proofs thy (force_proofs thy) else ();
 
 
 
 (** print theorems **)
 
 (* options *)
 
 val show_consts = Config.declare_option_bool ("show_consts", \<^here>);
 val show_hyps = Config.declare_bool ("show_hyps", \<^here>) (K false);
 val show_tags = Config.declare_bool ("show_tags", \<^here>) (K false);
 
 
 (* pretty_thm etc. *)
 
 fun pretty_tag (name, arg) = Pretty.strs [name, quote arg];
 val pretty_tags = Pretty.list "[" "]" o map pretty_tag;
 
 fun pretty_thm_raw ctxt {quote, show_hyps = show_hyps'} raw_th =
   let
     val show_tags = Config.get ctxt show_tags;
     val show_hyps = Config.get ctxt show_hyps;
 
     val th = raw_th
       |> perhaps (try (Thm.transfer' ctxt))
       |> perhaps (try Thm.strip_shyps);
 
     val hyps = if show_hyps then Thm.hyps_of th else undeclared_hyps (Context.Proof ctxt) th;
     val extra_shyps = extra_shyps' ctxt th;
     val tags = Thm.get_tags th;
     val tpairs = Thm.tpairs_of th;
 
     val q = if quote then Pretty.quote else I;
     val prt_term = q o Syntax.pretty_term ctxt;
 
 
     val hlen = length extra_shyps + length hyps + length tpairs;
     val hsymbs =
       if hlen = 0 then []
       else if show_hyps orelse show_hyps' then
         [Pretty.brk 2, Pretty.list "[" "]"
           (map (q o Syntax.pretty_flexpair ctxt) tpairs @ map prt_term hyps @
            map (Syntax.pretty_sort ctxt) extra_shyps)]
       else [Pretty.brk 2, Pretty.str ("[" ^ replicate_string hlen "." ^ "]")];
     val tsymbs =
       if null tags orelse not show_tags then []
       else [Pretty.brk 1, pretty_tags tags];
   in Pretty.block (prt_term (Thm.prop_of th) :: (hsymbs @ tsymbs)) end;
 
 fun pretty_thm ctxt = pretty_thm_raw ctxt {quote = false, show_hyps = true};
 fun pretty_thm_item ctxt th = Pretty.item [pretty_thm ctxt th];
 
 fun pretty_thm_global thy =
   pretty_thm_raw (Syntax.init_pretty_global thy) {quote = false, show_hyps = false};
 
 val string_of_thm = Pretty.string_of oo pretty_thm;
 val string_of_thm_global = Pretty.string_of oo pretty_thm_global;
 
 
 open Thm;
 
 end;
 
 structure Basic_Thm: BASIC_THM = Thm;
 open Basic_Thm;
diff --git a/src/Pure/morphism.ML b/src/Pure/morphism.ML
--- a/src/Pure/morphism.ML
+++ b/src/Pure/morphism.ML
@@ -1,178 +1,178 @@
 (*  Title:      Pure/morphism.ML
     Author:     Makarius
 
 Abstract morphisms on formal entities.
 *)
 
 infix 1 $>
 
 signature BASIC_MORPHISM =
 sig
   type morphism
   type declaration = morphism -> Context.generic -> Context.generic
   val $> : morphism * morphism -> morphism
 end
 
 signature MORPHISM =
 sig
   include BASIC_MORPHISM
   exception MORPHISM of string * exn
   val morphism: string ->
    {binding: (binding -> binding) list,
     typ: (typ -> typ) list,
     term: (term -> term) list,
     fact: (thm list -> thm list) list} -> morphism
   val pretty: morphism -> Pretty.T
   val binding: morphism -> binding -> binding
   val binding_prefix: morphism -> (string * bool) list
   val typ: morphism -> typ -> typ
   val term: morphism -> term -> term
   val fact: morphism -> thm list -> thm list
   val thm: morphism -> thm -> thm
   val cterm: morphism -> cterm -> cterm
   val identity: morphism
   val compose: morphism -> morphism -> morphism
   val transform: morphism -> (morphism -> 'a) -> morphism -> 'a
   val form: (morphism -> 'a) -> 'a
   val binding_morphism: string -> (binding -> binding) -> morphism
   val typ_morphism: string -> (typ -> typ) -> morphism
   val term_morphism: string -> (term -> term) -> morphism
   val fact_morphism: string -> (thm list -> thm list) -> morphism
   val thm_morphism: string -> (thm -> thm) -> morphism
   val transfer_morphism: theory -> morphism
   val transfer_morphism': Proof.context -> morphism
   val transfer_morphism'': Context.generic -> morphism
   val trim_context_morphism: morphism
   val instantiate_frees_morphism:
     ((string * sort) * ctyp) list * ((string * typ) * cterm) list -> morphism
   val instantiate_morphism:
     ((indexname * sort) * ctyp) list * ((indexname * typ) * cterm) list -> morphism
 end;
 
 structure Morphism: MORPHISM =
 struct
 
 (* named functions *)
 
 type 'a funs = (string * ('a -> 'a)) list;
 
 exception MORPHISM of string * exn;
 
 fun app (name, f) x = f x
   handle exn =>
     if Exn.is_interrupt exn then Exn.reraise exn else raise MORPHISM (name, exn);
 
 fun apply fs = fold_rev app fs;
 
 
 (* type morphism *)
 
 datatype morphism = Morphism of
  {names: string list,
   binding: binding funs,
   typ: typ funs,
   term: term funs,
   fact: thm list funs};
 
 type declaration = morphism -> Context.generic -> Context.generic;
 
 fun morphism a {binding, typ, term, fact} =
   Morphism {
     names = if a = "" then [] else [a],
     binding = map (pair a) binding,
     typ = map (pair a) typ,
     term = map (pair a) term,
     fact = map (pair a) fact};
 
 fun pretty (Morphism {names, ...}) = Pretty.enum ";" "{" "}" (map Pretty.str (rev names));
 
 val _ = ML_system_pp (fn _ => fn _ => Pretty.to_polyml o pretty);
 
 fun binding (Morphism {binding, ...}) = apply binding;
 fun binding_prefix morph = Binding.name "x" |> binding morph |> Binding.prefix_of;
 fun typ (Morphism {typ, ...}) = apply typ;
 fun term (Morphism {term, ...}) = apply term;
 fun fact (Morphism {fact, ...}) = apply fact;
 val thm = singleton o fact;
 val cterm = Drule.cterm_rule o thm;
 
 
 (* morphism combinators *)
 
 val identity = morphism "" {binding = [], typ = [], term = [], fact = []};
 
 fun compose
     (Morphism {names = names1, binding = binding1, typ = typ1, term = term1, fact = fact1})
     (Morphism {names = names2, binding = binding2, typ = typ2, term = term2, fact = fact2}) =
   Morphism {
     names = names1 @ names2,
     binding = binding1 @ binding2,
     typ = typ1 @ typ2,
     term = term1 @ term2,
     fact = fact1 @ fact2};
 
 fun phi1 $> phi2 = compose phi2 phi1;
 
 fun transform phi f = fn psi => f (phi $> psi);
 fun form f = f identity;
 
 
 (* concrete morphisms *)
 
 fun binding_morphism a binding = morphism a {binding = [binding], typ = [], term = [], fact = []};
 fun typ_morphism a typ = morphism a {binding = [], typ = [typ], term = [], fact = []};
 fun term_morphism a term = morphism a {binding = [], typ = [], term = [term], fact = []};
 fun fact_morphism a fact = morphism a {binding = [], typ = [], term = [], fact = [fact]};
 fun thm_morphism a thm = morphism a {binding = [], typ = [], term = [], fact = [map thm]};
 
 val transfer_morphism = thm_morphism "transfer" o Thm.join_transfer;
 val transfer_morphism' = transfer_morphism o Proof_Context.theory_of;
 val transfer_morphism'' = transfer_morphism o Context.theory_of;
 
 val trim_context_morphism = thm_morphism "trim_context" Thm.trim_context;
 
 
 (* instantiate *)
 
 fun instantiate_frees_morphism ([], []) = identity
   | instantiate_frees_morphism (cinstT, cinst) =
       let
         val instT =
-          fold (fn (v, cT) => Term_Subst.TFrees.add (v, Thm.typ_of cT))
-            cinstT Term_Subst.TFrees.empty;
+          Term_Subst.TFrees.build
+            (cinstT |> fold (fn (v, cT) => Term_Subst.TFrees.add (v, Thm.typ_of cT)));
         val inst =
-          fold (fn (v, ct) => Term_Subst.Frees.add (v, Thm.term_of ct))
-            cinst Term_Subst.Frees.empty;
+          Term_Subst.Frees.build
+            (cinst |> fold (fn (v, ct) => Term_Subst.Frees.add (v, Thm.term_of ct)));
       in
         morphism "instantiate_frees"
           {binding = [],
            typ =
             if Term_Subst.TFrees.is_empty instT then []
             else [Term_Subst.instantiateT_frees instT],
            term = [Term_Subst.instantiate_frees (instT, inst)],
            fact = [map (Thm.instantiate_frees (cinstT, cinst))]}
       end;
 
 fun instantiate_morphism ([], []) = identity
   | instantiate_morphism (cinstT, cinst) =
       let
         val instT =
-          fold (fn (v, cT) => Term_Subst.TVars.add (v, Thm.typ_of cT))
-            cinstT Term_Subst.TVars.empty;
+          Term_Subst.TVars.build (cinstT |> fold (fn (v, cT) =>
+            Term_Subst.TVars.add (v, Thm.typ_of cT)));
         val inst =
-          fold (fn (v, ct) => Term_Subst.Vars.add (v, Thm.term_of ct))
-            cinst Term_Subst.Vars.empty;
+          Term_Subst.Vars.build (cinst |> fold (fn (v, ct) =>
+            Term_Subst.Vars.add (v, Thm.term_of ct)));
       in
         morphism "instantiate"
           {binding = [],
            typ =
             if Term_Subst.TVars.is_empty instT then []
             else [Term_Subst.instantiateT instT],
            term = [Term_Subst.instantiate (instT, inst)],
            fact = [map (Thm.instantiate (cinstT, cinst))]}
       end;
 
 end;
 
 structure Basic_Morphism: BASIC_MORPHISM = Morphism;
 open Basic_Morphism;
diff --git a/src/Pure/primitive_defs.ML b/src/Pure/primitive_defs.ML
--- a/src/Pure/primitive_defs.ML
+++ b/src/Pure/primitive_defs.ML
@@ -1,85 +1,85 @@
 (*  Title:      Pure/primitive_defs.ML
     Author:     Makarius
 
 Primitive definition forms.
 *)
 
 signature PRIMITIVE_DEFS =
 sig
   val dest_def: Proof.context ->
     {check_head: term -> bool,
      check_free_lhs: string -> bool,
      check_free_rhs: string -> bool,
      check_tfree: string -> bool} ->
     term -> (term * term) * term list * term
   val abs_def: term -> term * term
 end;
 
 structure Primitive_Defs: PRIMITIVE_DEFS =
 struct
 
 fun term_kind (Const _) = "existing constant "
   | term_kind (Free _) = "free variable "
   | term_kind (Bound _) = "bound variable "
   | term_kind _ = "";
 
 (*c x \<equiv> t[x] to \<And>x. c x \<equiv> t[x]*)
 fun dest_def ctxt {check_head, check_free_lhs, check_free_rhs, check_tfree} eq =
   let
     fun err msg = raise TERM (msg, [eq]);
     val eq_vars = Term.strip_all_vars eq;
     val eq_body = Term.strip_all_body eq;
 
     val display_terms =
       commas_quote o map (Syntax.string_of_term ctxt o Syntax_Trans.bound_vars eq_vars);
     val display_types = commas_quote o map (Syntax.string_of_typ ctxt);
 
     val (raw_lhs, rhs) = Logic.dest_equals eq_body handle TERM _ => err "Not a meta-equality (\<equiv>)";
     val lhs = Envir.beta_eta_contract raw_lhs;
     val (head, args) = Term.strip_comb lhs;
-    val head_tfrees = Term_Subst.add_tfrees head Term_Subst.TFrees.empty;
+    val head_tfrees = Term_Subst.TFrees.build (Term_Subst.add_tfrees head);
 
     fun check_arg (Bound _) = true
       | check_arg (Free (x, _)) = check_free_lhs x
       | check_arg (Const ("Pure.type", Type ("itself", [TFree _]))) = true
       | check_arg _ = false;
     fun close_arg (Bound _) t = t
       | close_arg x t = Logic.all x t;
 
     val lhs_bads = filter_out check_arg args;
     val lhs_dups = duplicates (op aconv) args;
     val rhs_extras = Term.fold_aterms (fn v as Free (x, _) =>
       if check_free_rhs x orelse member (op aconv) args v then I
       else insert (op aconv) v | _ => I) rhs [];
     val rhs_extrasT = Term.fold_aterms (Term.fold_types (fn v as TFree (a, S) =>
       if check_tfree a orelse Term_Subst.TFrees.defined head_tfrees (a, S) then I
       else insert (op =) v | _ => I)) rhs [];
   in
     if not (check_head head) then
       err ("Bad head of lhs: " ^ term_kind head ^ display_terms [head])
     else if not (null lhs_bads) then
       err ("Bad arguments on lhs: " ^ display_terms lhs_bads)
     else if not (null lhs_dups) then
       err ("Duplicate arguments on lhs: " ^ display_terms lhs_dups)
     else if not (null rhs_extras) then
       err ("Extra variables on rhs: " ^ display_terms rhs_extras)
     else if not (null rhs_extrasT) then
       err ("Extra type variables on rhs: " ^ display_types rhs_extrasT)
     else if exists_subterm (fn t => t aconv head) rhs then
       err "Entity to be defined occurs on rhs"
     else
       ((lhs, rhs), args,
         fold_rev close_arg args (Logic.list_all (eq_vars, (Logic.mk_equals (lhs, rhs)))))
   end;
 
 (*\<And>x. c x \<equiv> t[x] to c \<equiv> \<lambda>x. t[x]*)
 fun abs_def eq =
   let
     val body = Term.strip_all_body eq;
     val vars = map Free (Term.rename_wrt_term body (Term.strip_all_vars eq));
     val (lhs, rhs) = Logic.dest_equals (Term.subst_bounds (vars, body));
     val (lhs', args) = Term.strip_comb lhs;
     val rhs' = fold_rev (absfree o dest_Free) args rhs;
   in (lhs', rhs') end;
 
 end;
diff --git a/src/Pure/proofterm.ML b/src/Pure/proofterm.ML
--- a/src/Pure/proofterm.ML
+++ b/src/Pure/proofterm.ML
@@ -1,2339 +1,2340 @@
 (*  Title:      Pure/proofterm.ML
     Author:     Stefan Berghofer, TU Muenchen
 
 LF style proof terms.
 *)
 
 infix 8 % %% %>;
 
 signature PROOFTERM =
 sig
   type thm_header =
     {serial: serial, pos: Position.T list, theory_name: string, name: string,
       prop: term, types: typ list option}
   type thm_body
   type thm_node
   datatype proof =
      MinProof
    | PBound of int
    | Abst of string * typ option * proof
    | AbsP of string * term option * proof
    | % of proof * term option
    | %% of proof * proof
    | Hyp of term
    | PAxm of string * term * typ list option
    | PClass of typ * class
    | Oracle of string * term * typ list option
    | PThm of thm_header * thm_body
   and proof_body = PBody of
     {oracles: ((string * Position.T) * term option) Ord_List.T,
      thms: (serial * thm_node) Ord_List.T,
      proof: proof}
   type oracle = (string * Position.T) * term option
   type thm = serial * thm_node
   exception MIN_PROOF of unit
   val proof_of: proof_body -> proof
   val join_proof: proof_body future -> proof
   val map_proof_of: (proof -> proof) -> proof_body -> proof_body
   val thm_header: serial -> Position.T list -> string -> string -> term -> typ list option ->
     thm_header
   val thm_body: proof_body -> thm_body
   val thm_body_proof_raw: thm_body -> proof
   val thm_body_proof_open: thm_body -> proof
   val thm_node_theory_name: thm_node -> string
   val thm_node_name: thm_node -> string
   val thm_node_prop: thm_node -> term
   val thm_node_body: thm_node -> proof_body future
   val thm_node_thms: thm_node -> thm list
   val join_thms: thm list -> proof_body list
   val make_thm: thm_header -> thm_body -> thm
   val fold_proof_atoms: bool -> (proof -> 'a -> 'a) -> proof list -> 'a -> 'a
   val fold_body_thms:
     ({serial: serial, name: string, prop: term, body: proof_body} -> 'a -> 'a) ->
     proof_body list -> 'a -> 'a
   val oracle_ord: oracle ord
   val thm_ord: thm ord
   val unions_oracles: oracle Ord_List.T list -> oracle Ord_List.T
   val unions_thms: thm Ord_List.T list -> thm Ord_List.T
   val no_proof_body: proof -> proof_body
   val no_thm_names: proof -> proof
   val no_thm_proofs: proof -> proof
   val no_body_proofs: proof -> proof
 
   val encode: Consts.T -> proof XML.Encode.T
   val encode_body: Consts.T -> proof_body XML.Encode.T
   val encode_standard_term: Consts.T -> term XML.Encode.T
   val encode_standard_proof: Consts.T -> proof XML.Encode.T
   val decode: Consts.T -> proof XML.Decode.T
   val decode_body: Consts.T -> proof_body XML.Decode.T
 
   val %> : proof * term -> proof
 
   (*primitive operations*)
   val proofs: int Unsynchronized.ref
   val proofs_enabled: unit -> bool
   val atomic_proof: proof -> bool
   val compact_proof: proof -> bool
   val proof_combt: proof * term list -> proof
   val proof_combt': proof * term option list -> proof
   val proof_combP: proof * proof list -> proof
   val strip_combt: proof -> proof * term option list
   val strip_combP: proof -> proof * proof list
   val strip_thm_body: proof_body -> proof_body
   val map_proof_same: term Same.operation -> typ Same.operation
     -> (typ * class -> proof) -> proof Same.operation
   val map_proof_terms_same: term Same.operation -> typ Same.operation -> proof Same.operation
   val map_proof_types_same: typ Same.operation -> proof Same.operation
   val map_proof_terms: (term -> term) -> (typ -> typ) -> proof -> proof
   val map_proof_types: (typ -> typ) -> proof -> proof
   val fold_proof_terms: (term -> 'a -> 'a) -> proof -> 'a -> 'a
   val fold_proof_terms_types: (term -> 'a -> 'a) -> (typ -> 'a -> 'a) -> proof -> 'a -> 'a
   val maxidx_proof: proof -> int -> int
   val size_of_proof: proof -> int
   val change_types: typ list option -> proof -> proof
   val prf_abstract_over: term -> proof -> proof
   val prf_incr_bv: int -> int -> int -> int -> proof -> proof
   val incr_pboundvars: int -> int -> proof -> proof
   val prf_loose_bvar1: proof -> int -> bool
   val prf_loose_Pbvar1: proof -> int -> bool
   val prf_add_loose_bnos: int -> int -> proof -> int list * int list -> int list * int list
   val norm_proof: Envir.env -> proof -> proof
   val norm_proof': Envir.env -> proof -> proof
   val prf_subst_bounds: term list -> proof -> proof
   val prf_subst_pbounds: proof list -> proof -> proof
   val freeze_thaw_prf: proof -> proof * (proof -> proof)
 
   (*proof terms for specific inference rules*)
   val trivial_proof: proof
   val implies_intr_proof: term -> proof -> proof
   val implies_intr_proof': term -> proof -> proof
   val forall_intr_proof: string * term -> typ option -> proof -> proof
   val forall_intr_proof': term -> proof -> proof
   val varify_proof: term -> (string * sort) list -> proof -> proof
   val legacy_freezeT: term -> proof -> proof
   val rotate_proof: term list -> term -> (string * typ) list -> term list -> int -> proof -> proof
   val permute_prems_proof: term list -> int -> int -> proof -> proof
   val generalize_proof: Symtab.set * Symtab.set -> int -> term -> proof -> proof
   val instantiate: typ Term_Subst.TVars.table * term Term_Subst.Vars.table -> proof -> proof
   val lift_proof: term -> int -> term -> proof -> proof
   val incr_indexes: int -> proof -> proof
   val assumption_proof: term list -> term -> int -> proof -> proof
   val bicompose_proof: bool -> term list -> term list -> term option -> term list ->
     int -> int -> proof -> proof -> proof
   val equality_axms: (string * term) list
   val reflexive_axm: proof
   val symmetric_axm: proof
   val transitive_axm: proof
   val equal_intr_axm: proof
   val equal_elim_axm: proof
   val abstract_rule_axm: proof
   val combination_axm: proof
   val reflexive_proof: proof
   val symmetric_proof: proof -> proof
   val transitive_proof: typ -> term -> proof -> proof -> proof
   val equal_intr_proof: term -> term -> proof -> proof -> proof
   val equal_elim_proof: term -> term -> proof -> proof -> proof
   val abstract_rule_proof: string * term -> proof -> proof
   val combination_proof: term -> term -> term -> term -> proof -> proof -> proof
   val strip_shyps_proof: Sorts.algebra -> (typ * sort) list -> (typ * sort) list ->
     sort list -> proof -> proof
   val of_sort_proof: Sorts.algebra ->
     (class * class -> proof) ->
     (string * class list list * class -> proof) ->
     (typ * class -> proof) -> typ * sort -> proof list
   val axm_proof: string -> term -> proof
   val oracle_proof: string -> term -> proof
   val shrink_proof: proof -> proof
 
   (*rewriting on proof terms*)
   val add_prf_rrule: proof * proof -> theory -> theory
   val add_prf_rproc: (typ list -> term option list -> proof -> (proof * proof) option) -> theory -> theory
   val set_preproc: (theory -> proof -> proof) -> theory -> theory
   val apply_preproc: theory -> proof -> proof
   val forall_intr_variables_term: term -> term
   val forall_intr_variables: term -> proof -> proof
   val no_skel: proof
   val normal_skel: proof
   val rewrite_proof: theory -> (proof * proof) list *
     (typ list -> term option list -> proof -> (proof * proof) option) list -> proof -> proof
   val rewrite_proof_notypes: (proof * proof) list *
     (typ list -> term option list -> proof -> (proof * proof) option) list -> proof -> proof
   val rew_proof: theory -> proof -> proof
 
   val reconstruct_proof: theory -> term -> proof -> proof
   val prop_of': term list -> proof -> term
   val prop_of: proof -> term
   val expand_name_empty: thm_header -> string option
   val expand_proof: theory -> (thm_header -> string option) -> proof -> proof
 
   val standard_vars: Name.context -> term * proof option -> term * proof option
   val standard_vars_term: Name.context -> term -> term
   val add_standard_vars: proof -> (string * typ) list -> (string * typ) list
   val add_standard_vars_term: term -> (string * typ) list -> (string * typ) list
 
   val export_enabled: unit -> bool
   val export_standard_enabled: unit -> bool
   val export_proof_boxes_required: theory -> bool
   val export_proof_boxes: proof_body list -> unit
   val fulfill_norm_proof: theory -> (serial * proof_body) list -> proof_body -> proof_body
   val thm_proof: theory -> (class * class -> proof) ->
     (string * class list list * class -> proof) -> string * Position.T -> sort list ->
     term list -> term -> (serial * proof_body future) list -> proof_body -> thm * proof
   val unconstrain_thm_proof: theory -> (class * class -> proof) ->
     (string * class list list * class -> proof) -> sort list -> term ->
     (serial * proof_body future) list -> proof_body -> thm * proof
   val get_identity: sort list -> term list -> term -> proof ->
     {serial: serial, theory_name: string, name: string} option
   val get_approximative_name: sort list -> term list -> term -> proof -> string
   type thm_id = {serial: serial, theory_name: string}
   val make_thm_id: serial * string -> thm_id
   val thm_header_id: thm_header -> thm_id
   val thm_id: thm -> thm_id
   val get_id: sort list -> term list -> term -> proof -> thm_id option
   val this_id: thm_id option -> thm_id -> bool
   val proof_boxes: {excluded: thm_id -> bool, included: thm_id -> bool} ->
     proof list -> (thm_header * proof) list  (*exception MIN_PROOF*)
 end
 
 structure Proofterm : PROOFTERM =
 struct
 
 (** datatype proof **)
 
 type thm_header =
   {serial: serial, pos: Position.T list, theory_name: string, name: string,
     prop: term, types: typ list option};
 
 datatype proof =
    MinProof
  | PBound of int
  | Abst of string * typ option * proof
  | AbsP of string * term option * proof
  | op % of proof * term option
  | op %% of proof * proof
  | Hyp of term
  | PAxm of string * term * typ list option
  | PClass of typ * class
  | Oracle of string * term * typ list option
  | PThm of thm_header * thm_body
 and proof_body = PBody of
   {oracles: ((string * Position.T) * term option) Ord_List.T,
    thms: (serial * thm_node) Ord_List.T,
    proof: proof}
 and thm_body =
   Thm_Body of {open_proof: proof -> proof, body: proof_body future}
 and thm_node =
   Thm_Node of {theory_name: string, name: string, prop: term,
     body: proof_body future, export: unit lazy, consolidate: unit lazy};
 
 type oracle = (string * Position.T) * term option;
 val oracle_ord: oracle ord =
   prod_ord (prod_ord fast_string_ord Position.ord) (option_ord Term_Ord.fast_term_ord);
 
 type thm = serial * thm_node;
 val thm_ord: thm ord = fn ((i, _), (j, _)) => int_ord (j, i);
 
 
 exception MIN_PROOF of unit;
 
 fun proof_of (PBody {proof, ...}) = proof;
 val join_proof = Future.join #> proof_of;
 
 fun map_proof_of f (PBody {oracles, thms, proof}) =
   PBody {oracles = oracles, thms = thms, proof = f proof};
 
 fun thm_header serial pos theory_name name prop types : thm_header =
   {serial = serial, pos = pos, theory_name = theory_name, name = name, prop = prop, types = types};
 
 fun thm_body body = Thm_Body {open_proof = I, body = Future.value body};
 fun thm_body_proof_raw (Thm_Body {body, ...}) = join_proof body;
 fun thm_body_proof_open (Thm_Body {open_proof, body, ...}) = open_proof (join_proof body);
 
 fun rep_thm_node (Thm_Node args) = args;
 val thm_node_theory_name = #theory_name o rep_thm_node;
 val thm_node_name = #name o rep_thm_node;
 val thm_node_prop = #prop o rep_thm_node;
 val thm_node_body = #body o rep_thm_node;
 val thm_node_thms = thm_node_body #> Future.join #> (fn PBody {thms, ...} => thms);
 val thm_node_export = #export o rep_thm_node;
 val thm_node_consolidate = #consolidate o rep_thm_node;
 
 fun join_thms (thms: thm list) =
   Future.joins (map (thm_node_body o #2) thms);
 
 val consolidate_bodies =
   maps (fn PBody {thms, ...} => map (thm_node_consolidate o #2) thms)
   #> Lazy.consolidate #> map Lazy.force #> ignore;
 
 fun make_thm_node theory_name name prop body export =
   let
     val consolidate =
       Lazy.lazy_name "Proofterm.make_thm_node" (fn () =>
         let val PBody {thms, ...} = Future.join body
         in consolidate_bodies (join_thms thms) end);
   in
     Thm_Node {theory_name = theory_name, name = name, prop = prop, body = body,
       export = export, consolidate = consolidate}
   end;
 
 val no_export = Lazy.value ();
 
 fun make_thm ({serial, theory_name, name, prop, ...}: thm_header) (Thm_Body {body, ...}) =
   (serial, make_thm_node theory_name name prop body no_export);
 
 
 (* proof atoms *)
 
 fun fold_proof_atoms all f =
   let
     fun app (Abst (_, _, prf)) = app prf
       | app (AbsP (_, _, prf)) = app prf
       | app (prf % _) = app prf
       | app (prf1 %% prf2) = app prf1 #> app prf2
       | app (prf as PThm ({serial = i, ...}, Thm_Body {body, ...})) = (fn (x, seen) =>
           if Inttab.defined seen i then (x, seen)
           else
             let val (x', seen') =
               (if all then app (join_proof body) else I) (x, Inttab.update (i, ()) seen)
             in (f prf x', seen') end)
       | app prf = (fn (x, seen) => (f prf x, seen));
   in fn prfs => fn x => #1 (fold app prfs (x, Inttab.empty)) end;
 
 fun fold_body_thms f =
   let
     fun app (PBody {thms, ...}) =
       tap join_thms thms |> fold (fn (i, thm_node) => fn (x, seen) =>
         if Inttab.defined seen i then (x, seen)
         else
           let
             val name = thm_node_name thm_node;
             val prop = thm_node_prop thm_node;
             val body = Future.join (thm_node_body thm_node);
             val (x', seen') = app body (x, Inttab.update (i, ()) seen);
           in (f {serial = i, name = name, prop = prop, body = body} x', seen') end);
   in fn bodies => fn x => #1 (fold app bodies (x, Inttab.empty)) end;
 
 
 (* proof body *)
 
 val unions_oracles = Ord_List.unions oracle_ord;
 val unions_thms = Ord_List.unions thm_ord;
 
 fun no_proof_body proof = PBody {oracles = [], thms = [], proof = proof};
 val no_thm_body = thm_body (no_proof_body MinProof);
 
 fun no_thm_names (Abst (x, T, prf)) = Abst (x, T, no_thm_names prf)
   | no_thm_names (AbsP (x, t, prf)) = AbsP (x, t, no_thm_names prf)
   | no_thm_names (prf % t) = no_thm_names prf % t
   | no_thm_names (prf1 %% prf2) = no_thm_names prf1 %% no_thm_names prf2
   | no_thm_names (PThm ({serial, pos, theory_name, name = _, prop, types}, thm_body)) =
       PThm (thm_header serial pos theory_name "" prop types, thm_body)
   | no_thm_names a = a;
 
 fun no_thm_proofs (Abst (x, T, prf)) = Abst (x, T, no_thm_proofs prf)
   | no_thm_proofs (AbsP (x, t, prf)) = AbsP (x, t, no_thm_proofs prf)
   | no_thm_proofs (prf % t) = no_thm_proofs prf % t
   | no_thm_proofs (prf1 %% prf2) = no_thm_proofs prf1 %% no_thm_proofs prf2
   | no_thm_proofs (PThm (header, _)) = PThm (header, no_thm_body)
   | no_thm_proofs a = a;
 
 fun no_body_proofs (Abst (x, T, prf)) = Abst (x, T, no_body_proofs prf)
   | no_body_proofs (AbsP (x, t, prf)) = AbsP (x, t, no_body_proofs prf)
   | no_body_proofs (prf % t) = no_body_proofs prf % t
   | no_body_proofs (prf1 %% prf2) = no_body_proofs prf1 %% no_body_proofs prf2
   | no_body_proofs (PThm (header, Thm_Body {open_proof, body})) =
       let
         val body' = Future.value (no_proof_body (join_proof body));
         val thm_body' = Thm_Body {open_proof = open_proof, body = body'};
       in PThm (header, thm_body') end
   | no_body_proofs a = a;
 
 
 
 (** XML data representation **)
 
 (* encode *)
 
 local
 
 open XML.Encode Term_XML.Encode;
 
 fun proof consts prf = prf |> variant
  [fn MinProof => ([], []),
   fn PBound a => ([], int a),
   fn Abst (a, b, c) => ([a], pair (option typ) (proof consts) (b, c)),
   fn AbsP (a, b, c) => ([a], pair (option (term consts)) (proof consts) (b, c)),
   fn a % b => ([], pair (proof consts) (option (term consts)) (a, b)),
   fn a %% b => ([], pair (proof consts) (proof consts) (a, b)),
   fn Hyp a => ([], term consts a),
   fn PAxm (a, b, c) => ([a], pair (term consts) (option (list typ)) (b, c)),
   fn PClass (a, b) => ([b], typ a),
   fn Oracle (a, b, c) => ([a], pair (term consts) (option (list typ)) (b, c)),
   fn PThm ({serial, pos, theory_name, name, prop, types}, Thm_Body {open_proof, body, ...}) =>
     ([int_atom serial, theory_name, name],
       pair (list properties) (pair (term consts) (pair (option (list typ)) (proof_body consts)))
         (map Position.properties_of pos, (prop, (types, map_proof_of open_proof (Future.join body)))))]
 and proof_body consts (PBody {oracles, thms, proof = prf}) =
   triple (list (pair (pair string (properties o Position.properties_of))
       (option (term consts)))) (list (thm consts)) (proof consts) (oracles, thms, prf)
 and thm consts (a, thm_node) =
   pair int (pair string (pair string (pair (term consts) (proof_body consts))))
     (a, (thm_node_theory_name thm_node, (thm_node_name thm_node, (thm_node_prop thm_node,
       (Future.join (thm_node_body thm_node))))));
 
 fun standard_term consts t = t |> variant
  [fn Const (a, b) => ([a], list typ (Consts.typargs consts (a, b))),
   fn Free (a, _) => ([a], []),
   fn Var (a, _) => (indexname a, []),
   fn Bound a => ([], int a),
   fn Abs (a, b, c) => ([a], pair typ (standard_term consts) (b, c)),
   fn op $ a => ([], pair (standard_term consts) (standard_term consts) a)];
 
 fun standard_proof consts prf = prf |> variant
  [fn MinProof => ([], []),
   fn PBound a => ([], int a),
   fn Abst (a, SOME b, c) => ([a], pair typ (standard_proof consts) (b, c)),
   fn AbsP (a, SOME b, c) => ([a], pair (standard_term consts) (standard_proof consts) (b, c)),
   fn a % SOME b => ([], pair (standard_proof consts) (standard_term consts) (a, b)),
   fn a %% b => ([], pair (standard_proof consts) (standard_proof consts) (a, b)),
   fn Hyp a => ([], standard_term consts a),
   fn PAxm (name, _, SOME Ts) => ([name], list typ Ts),
   fn PClass (T, c) => ([c], typ T),
   fn Oracle (name, prop, SOME Ts) => ([name], pair (standard_term consts) (list typ) (prop, Ts)),
   fn PThm ({serial, theory_name, name, types = SOME Ts, ...}, _) =>
     ([int_atom serial, theory_name, name], list typ Ts)];
 
 in
 
 val encode = proof;
 val encode_body = proof_body;
 val encode_standard_term = standard_term;
 val encode_standard_proof = standard_proof;
 
 end;
 
 
 (* decode *)
 
 local
 
 open XML.Decode Term_XML.Decode;
 
 fun proof consts prf = prf |> variant
  [fn ([], []) => MinProof,
   fn ([], a) => PBound (int a),
   fn ([a], b) => let val (c, d) = pair (option typ) (proof consts) b in Abst (a, c, d) end,
   fn ([a], b) => let val (c, d) = pair (option (term consts)) (proof consts) b in AbsP (a, c, d) end,
   fn ([], a) => op % (pair (proof consts) (option (term consts)) a),
   fn ([], a) => op %% (pair (proof consts) (proof consts) a),
   fn ([], a) => Hyp (term consts a),
   fn ([a], b) => let val (c, d) = pair (term consts) (option (list typ)) b in PAxm (a, c, d) end,
   fn ([b], a) => PClass (typ a, b),
   fn ([a], b) => let val (c, d) = pair (term consts) (option (list typ)) b in Oracle (a, c, d) end,
   fn ([a, b, c], d) =>
     let
       val ((e, (f, (g, h)))) =
         pair (list properties) (pair (term consts) (pair (option (list typ)) (proof_body consts))) d;
       val header = thm_header (int_atom a) (map Position.of_properties e) b c f g;
     in PThm (header, thm_body h) end]
 and proof_body consts x =
   let
     val (a, b, c) =
       triple (list (pair (pair string (Position.of_properties o properties))
         (option (term consts)))) (list (thm consts)) (proof consts) x;
   in PBody {oracles = a, thms = b, proof = c} end
 and thm consts x =
   let
     val (a, (b, (c, (d, e)))) =
       pair int (pair string (pair string (pair (term consts) (proof_body consts)))) x
   in (a, make_thm_node b c d (Future.value e) no_export) end;
 
 in
 
 val decode = proof;
 val decode_body = proof_body;
 
 end;
 
 
 (** proof objects with different levels of detail **)
 
 val proofs = Unsynchronized.ref 2;
 fun proofs_enabled () = ! proofs >= 2;
 
 fun atomic_proof prf =
   (case prf of
     Abst _ => false
   | AbsP _ => false
   | op % _ => false
   | op %% _ => false
   | MinProof => false
   | _ => true);
 
 fun compact_proof (prf % _) = compact_proof prf
   | compact_proof (prf1 %% prf2) = atomic_proof prf2 andalso compact_proof prf1
   | compact_proof prf = atomic_proof prf;
 
 fun (prf %> t) = prf % SOME t;
 
 val proof_combt = Library.foldl (op %>);
 val proof_combt' = Library.foldl (op %);
 val proof_combP = Library.foldl (op %%);
 
 fun strip_combt prf =
     let fun stripc (prf % t, ts) = stripc (prf, t::ts)
           | stripc  x =  x
     in  stripc (prf, [])  end;
 
 fun strip_combP prf =
     let fun stripc (prf %% prf', prfs) = stripc (prf, prf'::prfs)
           | stripc  x =  x
     in  stripc (prf, [])  end;
 
 fun strip_thm_body (body as PBody {proof, ...}) =
   (case fst (strip_combt (fst (strip_combP proof))) of
     PThm (_, Thm_Body {body = body', ...}) => Future.join body'
   | _ => body);
 
 val mk_Abst = fold_rev (fn (x, _: typ) => fn prf => Abst (x, NONE, prf));
 val mk_AbsP = fold_rev (fn _: term => fn prf => AbsP ("H", NONE, prf));
 
 fun map_proof_same term typ ofclass =
   let
     val typs = Same.map typ;
 
     fun proof (Abst (s, T, prf)) =
           (Abst (s, Same.map_option typ T, Same.commit proof prf)
             handle Same.SAME => Abst (s, T, proof prf))
       | proof (AbsP (s, t, prf)) =
           (AbsP (s, Same.map_option term t, Same.commit proof prf)
             handle Same.SAME => AbsP (s, t, proof prf))
       | proof (prf % t) =
           (proof prf % Same.commit (Same.map_option term) t
             handle Same.SAME => prf % Same.map_option term t)
       | proof (prf1 %% prf2) =
           (proof prf1 %% Same.commit proof prf2
             handle Same.SAME => prf1 %% proof prf2)
       | proof (PAxm (a, prop, SOME Ts)) = PAxm (a, prop, SOME (typs Ts))
       | proof (PClass T_c) = ofclass T_c
       | proof (Oracle (a, prop, SOME Ts)) = Oracle (a, prop, SOME (typs Ts))
       | proof (PThm ({serial, pos, theory_name, name, prop, types = SOME Ts}, thm_body)) =
           PThm (thm_header serial pos theory_name name prop (SOME (typs Ts)), thm_body)
       | proof _ = raise Same.SAME;
   in proof end;
 
 fun map_proof_terms_same term typ = map_proof_same term typ (fn (T, c) => PClass (typ T, c));
 fun map_proof_types_same typ = map_proof_terms_same (Term_Subst.map_types_same typ) typ;
 
 fun same eq f x =
   let val x' = f x
   in if eq (x, x') then raise Same.SAME else x' end;
 
 fun map_proof_terms f g = Same.commit (map_proof_terms_same (same (op =) f) (same (op =) g));
 fun map_proof_types f = Same.commit (map_proof_types_same (same (op =) f));
 
 fun fold_proof_terms f (Abst (_, _, prf)) = fold_proof_terms f prf
   | fold_proof_terms f (AbsP (_, SOME t, prf)) = f t #> fold_proof_terms f prf
   | fold_proof_terms f (AbsP (_, NONE, prf)) = fold_proof_terms f prf
   | fold_proof_terms f (prf % SOME t) = fold_proof_terms f prf #> f t
   | fold_proof_terms f (prf % NONE) = fold_proof_terms f prf
   | fold_proof_terms f (prf1 %% prf2) = fold_proof_terms f prf1 #> fold_proof_terms f prf2
   | fold_proof_terms _ _ = I;
 
 fun fold_proof_terms_types f g (Abst (_, SOME T, prf)) = g T #> fold_proof_terms_types f g prf
   | fold_proof_terms_types f g (Abst (_, NONE, prf)) = fold_proof_terms_types f g prf
   | fold_proof_terms_types f g (AbsP (_, SOME t, prf)) = f t #> fold_proof_terms_types f g prf
   | fold_proof_terms_types f g (AbsP (_, NONE, prf)) = fold_proof_terms_types f g prf
   | fold_proof_terms_types f g (prf % SOME t) = fold_proof_terms_types f g prf #> f t
   | fold_proof_terms_types f g (prf % NONE) = fold_proof_terms_types f g prf
   | fold_proof_terms_types f g (prf1 %% prf2) =
       fold_proof_terms_types f g prf1 #> fold_proof_terms_types f g prf2
   | fold_proof_terms_types _ g (PAxm (_, _, SOME Ts)) = fold g Ts
   | fold_proof_terms_types _ g (PClass (T, _)) = g T
   | fold_proof_terms_types _ g (Oracle (_, _, SOME Ts)) = fold g Ts
   | fold_proof_terms_types _ g (PThm ({types = SOME Ts, ...}, _)) = fold g Ts
   | fold_proof_terms_types _ _ _ = I;
 
 fun maxidx_proof prf = fold_proof_terms_types Term.maxidx_term Term.maxidx_typ prf;
 
 fun size_of_proof (Abst (_, _, prf)) = 1 + size_of_proof prf
   | size_of_proof (AbsP (_, _, prf)) = 1 + size_of_proof prf
   | size_of_proof (prf % _) = 1 + size_of_proof prf
   | size_of_proof (prf1 %% prf2) = size_of_proof prf1 + size_of_proof prf2
   | size_of_proof _ = 1;
 
 fun change_types types (PAxm (name, prop, _)) = PAxm (name, prop, types)
   | change_types (SOME [T]) (PClass (_, c)) = PClass (T, c)
   | change_types types (Oracle (name, prop, _)) = Oracle (name, prop, types)
   | change_types types (PThm ({serial, pos, theory_name, name, prop, types = _}, thm_body)) =
       PThm (thm_header serial pos theory_name name prop types, thm_body)
   | change_types _ prf = prf;
 
 
 (* utilities *)
 
 fun strip_abs (_::Ts) (Abs (_, _, t)) = strip_abs Ts t
   | strip_abs _ t = t;
 
 fun mk_abs Ts t = Library.foldl (fn (t', T) => Abs ("", T, t')) (t, Ts);
 
 
 (*Abstraction of a proof term over its occurrences of v,
     which must contain no loose bound variables.
   The resulting proof term is ready to become the body of an Abst.*)
 
 fun prf_abstract_over v =
   let
     fun abst' lev u = if v aconv u then Bound lev else
       (case u of
          Abs (a, T, t) => Abs (a, T, abst' (lev + 1) t)
        | f $ t => (abst' lev f $ absth' lev t handle Same.SAME => f $ abst' lev t)
        | _ => raise Same.SAME)
     and absth' lev t = (abst' lev t handle Same.SAME => t);
 
     fun abst lev (AbsP (a, t, prf)) =
           (AbsP (a, Same.map_option (abst' lev) t, absth lev prf)
            handle Same.SAME => AbsP (a, t, abst lev prf))
       | abst lev (Abst (a, T, prf)) = Abst (a, T, abst (lev + 1) prf)
       | abst lev (prf1 %% prf2) = (abst lev prf1 %% absth lev prf2
           handle Same.SAME => prf1 %% abst lev prf2)
       | abst lev (prf % t) = (abst lev prf % Option.map (absth' lev) t
           handle Same.SAME => prf % Same.map_option (abst' lev) t)
       | abst _ _ = raise Same.SAME
     and absth lev prf = (abst lev prf handle Same.SAME => prf);
 
   in absth 0 end;
 
 
 (*increments a proof term's non-local bound variables
   required when moving a proof term within abstractions
      inc is  increment for bound variables
      lev is  level at which a bound variable is considered 'loose'*)
 
 fun incr_bv' inct tlev t = incr_bv (inct, tlev, t);
 
 fun prf_incr_bv' incP _ Plev _ (PBound i) =
       if i >= Plev then PBound (i+incP) else raise Same.SAME
   | prf_incr_bv' incP inct Plev tlev (AbsP (a, t, body)) =
       (AbsP (a, Same.map_option (same (op =) (incr_bv' inct tlev)) t,
          prf_incr_bv incP inct (Plev+1) tlev body) handle Same.SAME =>
            AbsP (a, t, prf_incr_bv' incP inct (Plev+1) tlev body))
   | prf_incr_bv' incP inct Plev tlev (Abst (a, T, body)) =
       Abst (a, T, prf_incr_bv' incP inct Plev (tlev+1) body)
   | prf_incr_bv' incP inct Plev tlev (prf %% prf') =
       (prf_incr_bv' incP inct Plev tlev prf %% prf_incr_bv incP inct Plev tlev prf'
        handle Same.SAME => prf %% prf_incr_bv' incP inct Plev tlev prf')
   | prf_incr_bv' incP inct Plev tlev (prf % t) =
       (prf_incr_bv' incP inct Plev tlev prf % Option.map (incr_bv' inct tlev) t
        handle Same.SAME => prf % Same.map_option (same (op =) (incr_bv' inct tlev)) t)
   | prf_incr_bv' _ _ _ _ _ = raise Same.SAME
 and prf_incr_bv incP inct Plev tlev prf =
       (prf_incr_bv' incP inct Plev tlev prf handle Same.SAME => prf);
 
 fun incr_pboundvars  0 0 prf = prf
   | incr_pboundvars incP inct prf = prf_incr_bv incP inct 0 0 prf;
 
 
 fun prf_loose_bvar1 (prf1 %% prf2) k = prf_loose_bvar1 prf1 k orelse prf_loose_bvar1 prf2 k
   | prf_loose_bvar1 (prf % SOME t) k = prf_loose_bvar1 prf k orelse loose_bvar1 (t, k)
   | prf_loose_bvar1 (_ % NONE) _ = true
   | prf_loose_bvar1 (AbsP (_, SOME t, prf)) k = loose_bvar1 (t, k) orelse prf_loose_bvar1 prf k
   | prf_loose_bvar1 (AbsP (_, NONE, _)) _ = true
   | prf_loose_bvar1 (Abst (_, _, prf)) k = prf_loose_bvar1 prf (k+1)
   | prf_loose_bvar1 _ _ = false;
 
 fun prf_loose_Pbvar1 (PBound i) k = i = k
   | prf_loose_Pbvar1 (prf1 %% prf2) k = prf_loose_Pbvar1 prf1 k orelse prf_loose_Pbvar1 prf2 k
   | prf_loose_Pbvar1 (prf % _) k = prf_loose_Pbvar1 prf k
   | prf_loose_Pbvar1 (AbsP (_, _, prf)) k = prf_loose_Pbvar1 prf (k+1)
   | prf_loose_Pbvar1 (Abst (_, _, prf)) k = prf_loose_Pbvar1 prf k
   | prf_loose_Pbvar1 _ _ = false;
 
 fun prf_add_loose_bnos plev _ (PBound i) (is, js) =
       if i < plev then (is, js) else (insert (op =) (i-plev) is, js)
   | prf_add_loose_bnos plev tlev (prf1 %% prf2) p =
       prf_add_loose_bnos plev tlev prf2
         (prf_add_loose_bnos plev tlev prf1 p)
   | prf_add_loose_bnos plev tlev (prf % opt) (is, js) =
       prf_add_loose_bnos plev tlev prf
         (case opt of
           NONE => (is, insert (op =) ~1 js)
         | SOME t => (is, add_loose_bnos (t, tlev, js)))
   | prf_add_loose_bnos plev tlev (AbsP (_, opt, prf)) (is, js) =
       prf_add_loose_bnos (plev+1) tlev prf
         (case opt of
           NONE => (is, insert (op =) ~1 js)
         | SOME t => (is, add_loose_bnos (t, tlev, js)))
   | prf_add_loose_bnos plev tlev (Abst (_, _, prf)) p =
       prf_add_loose_bnos plev (tlev+1) prf p
   | prf_add_loose_bnos _ _ _ _ = ([], []);
 
 
 (* substitutions *)
 
 local
 
 fun conflicting_tvarsT envT =
   Term.fold_atyps
     (fn T => fn instT =>
       (case T of
         TVar (v as (_, S)) =>
           if Term_Subst.TVars.defined instT v orelse can (Type.lookup envT) v then instT
           else Term_Subst.TVars.update (v, Logic.dummy_tfree S) instT
       | _ => instT));
 
 fun conflicting_tvars env =
   Term.fold_aterms
     (fn t => fn inst =>
       (case t of
         Var (v as (_, T)) =>
           if Term_Subst.Vars.defined inst v orelse can (Envir.lookup env) v then inst
           else Term_Subst.Vars.update (v, Free ("dummy", T)) inst
       | _ => inst));
 
 fun del_conflicting_tvars envT ty =
-  Term_Subst.instantiateT (conflicting_tvarsT envT ty Term_Subst.TVars.empty) ty;
+  Term_Subst.instantiateT (Term_Subst.TVars.build (conflicting_tvarsT envT ty)) ty;
 
 fun del_conflicting_vars env tm =
   let
-    val instT = Term.fold_types (conflicting_tvarsT (Envir.type_env env)) tm Term_Subst.TVars.empty;
-    val inst = conflicting_tvars env tm Term_Subst.Vars.empty;
+    val instT =
+      Term_Subst.TVars.build (tm |> Term.fold_types (conflicting_tvarsT (Envir.type_env env)));
+    val inst = Term_Subst.Vars.build (tm |> conflicting_tvars env);
   in Term_Subst.instantiate (instT, inst) tm end;
 
 in
 
 fun norm_proof env =
   let
     val envT = Envir.type_env env;
     fun msg s = warning ("type conflict in norm_proof:\n" ^ s);
     fun htype f t = f env t handle TYPE (s, _, _) =>
       (msg s; f env (del_conflicting_vars env t));
     fun htypeT f T = f envT T handle TYPE (s, _, _) =>
       (msg s; f envT (del_conflicting_tvars envT T));
     fun htypeTs f Ts = f envT Ts handle TYPE (s, _, _) =>
       (msg s; f envT (map (del_conflicting_tvars envT) Ts));
 
     fun norm (Abst (s, T, prf)) =
           (Abst (s, Same.map_option (htypeT Envir.norm_type_same) T, Same.commit norm prf)
             handle Same.SAME => Abst (s, T, norm prf))
       | norm (AbsP (s, t, prf)) =
           (AbsP (s, Same.map_option (htype Envir.norm_term_same) t, Same.commit norm prf)
             handle Same.SAME => AbsP (s, t, norm prf))
       | norm (prf % t) =
           (norm prf % Option.map (htype Envir.norm_term) t
             handle Same.SAME => prf % Same.map_option (htype Envir.norm_term_same) t)
       | norm (prf1 %% prf2) =
           (norm prf1 %% Same.commit norm prf2
             handle Same.SAME => prf1 %% norm prf2)
       | norm (PAxm (s, prop, Ts)) =
           PAxm (s, prop, Same.map_option (htypeTs Envir.norm_types_same) Ts)
       | norm (PClass (T, c)) =
           PClass (htypeT Envir.norm_type_same T, c)
       | norm (Oracle (s, prop, Ts)) =
           Oracle (s, prop, Same.map_option (htypeTs Envir.norm_types_same) Ts)
       | norm (PThm ({serial = i, pos = p, theory_name, name = a, prop = t, types = Ts}, thm_body)) =
           PThm (thm_header i p theory_name a t
             (Same.map_option (htypeTs Envir.norm_types_same) Ts), thm_body)
       | norm _ = raise Same.SAME;
   in Same.commit norm end;
 
 end;
 
 
 (* remove some types in proof term (to save space) *)
 
 fun remove_types (Abs (s, _, t)) = Abs (s, dummyT, remove_types t)
   | remove_types (t $ u) = remove_types t $ remove_types u
   | remove_types (Const (s, _)) = Const (s, dummyT)
   | remove_types t = t;
 
 fun remove_types_env (Envir.Envir {maxidx, tenv, tyenv}) =
   Envir.Envir {maxidx = maxidx, tenv = Vartab.map (K (apsnd remove_types)) tenv, tyenv = tyenv};
 
 fun norm_proof' env prf = norm_proof (remove_types_env env) prf;
 
 
 (* substitution of bound variables *)
 
 fun prf_subst_bounds args prf =
   let
     val n = length args;
     fun subst' lev (Bound i) =
          (if i<lev then raise Same.SAME    (*var is locally bound*)
           else  incr_boundvars lev (nth args (i-lev))
                   handle General.Subscript => Bound (i-n))  (*loose: change it*)
       | subst' lev (Abs (a, T, body)) = Abs (a, T,  subst' (lev+1) body)
       | subst' lev (f $ t) = (subst' lev f $ substh' lev t
           handle Same.SAME => f $ subst' lev t)
       | subst' _ _ = raise Same.SAME
     and substh' lev t = (subst' lev t handle Same.SAME => t);
 
     fun subst lev (AbsP (a, t, body)) =
         (AbsP (a, Same.map_option (subst' lev) t, substh lev body)
           handle Same.SAME => AbsP (a, t, subst lev body))
       | subst lev (Abst (a, T, body)) = Abst (a, T, subst (lev+1) body)
       | subst lev (prf %% prf') = (subst lev prf %% substh lev prf'
           handle Same.SAME => prf %% subst lev prf')
       | subst lev (prf % t) = (subst lev prf % Option.map (substh' lev) t
           handle Same.SAME => prf % Same.map_option (subst' lev) t)
       | subst _ _ = raise Same.SAME
     and substh lev prf = (subst lev prf handle Same.SAME => prf);
   in (case args of [] => prf | _ => substh 0 prf) end;
 
 fun prf_subst_pbounds args prf =
   let
     val n = length args;
     fun subst (PBound i) Plev tlev =
          (if i < Plev then raise Same.SAME    (*var is locally bound*)
           else incr_pboundvars Plev tlev (nth args (i-Plev))
                  handle General.Subscript => PBound (i-n)  (*loose: change it*))
       | subst (AbsP (a, t, body)) Plev tlev = AbsP (a, t, subst body (Plev+1) tlev)
       | subst (Abst (a, T, body)) Plev tlev = Abst (a, T, subst body Plev (tlev+1))
       | subst (prf %% prf') Plev tlev = (subst prf Plev tlev %% substh prf' Plev tlev
           handle Same.SAME => prf %% subst prf' Plev tlev)
       | subst (prf % t) Plev tlev = subst prf Plev tlev % t
       | subst  _ _ _ = raise Same.SAME
     and substh prf Plev tlev = (subst prf Plev tlev handle Same.SAME => prf)
   in (case args of [] => prf | _ => substh prf 0 0) end;
 
 
 (* freezing and thawing of variables in proof terms *)
 
 local
 
 fun frzT names =
   map_type_tvar (fn (ixn, S) => TFree (the (AList.lookup (op =) names ixn), S));
 
 fun thawT names =
   map_type_tfree (fn (a, S) =>
     (case AList.lookup (op =) names a of
       NONE => TFree (a, S)
     | SOME ixn => TVar (ixn, S)));
 
 fun freeze names names' (t $ u) =
       freeze names names' t $ freeze names names' u
   | freeze names names' (Abs (s, T, t)) =
       Abs (s, frzT names' T, freeze names names' t)
   | freeze _ names' (Const (s, T)) = Const (s, frzT names' T)
   | freeze _ names' (Free (s, T)) = Free (s, frzT names' T)
   | freeze names names' (Var (ixn, T)) =
       Free (the (AList.lookup (op =) names ixn), frzT names' T)
   | freeze _ _ t = t;
 
 fun thaw names names' (t $ u) =
       thaw names names' t $ thaw names names' u
   | thaw names names' (Abs (s, T, t)) =
       Abs (s, thawT names' T, thaw names names' t)
   | thaw _ names' (Const (s, T)) = Const (s, thawT names' T)
   | thaw names names' (Free (s, T)) =
       let val T' = thawT names' T in
         (case AList.lookup (op =) names s of
           NONE => Free (s, T')
         | SOME ixn => Var (ixn, T'))
       end
   | thaw _ names' (Var (ixn, T)) = Var (ixn, thawT names' T)
   | thaw _ _ t = t;
 
 in
 
 fun freeze_thaw_prf prf =
   let
     val (fs, Tfs, vs, Tvs) = fold_proof_terms_types
       (fn t => fn (fs, Tfs, vs, Tvs) =>
          (Term.add_free_names t fs, Term.add_tfree_names t Tfs,
           Term.add_var_names t vs, Term.add_tvar_names t Tvs))
       (fn T => fn (fs, Tfs, vs, Tvs) =>
          (fs, Term.add_tfree_namesT T Tfs,
           vs, Term.add_tvar_namesT T Tvs))
       prf ([], [], [], []);
     val names = vs ~~ Name.variant_list fs (map fst vs);
     val names' = Tvs ~~ Name.variant_list Tfs (map fst Tvs);
     val rnames = map swap names;
     val rnames' = map swap names';
   in
     (map_proof_terms (freeze names names') (frzT names') prf,
      map_proof_terms (thaw rnames rnames') (thawT rnames'))
   end;
 
 end;
 
 
 
 (** inference rules **)
 
 (* trivial implication *)
 
 val trivial_proof = AbsP ("H", NONE, PBound 0);
 
 
 (* implication introduction *)
 
 fun gen_implies_intr_proof f h prf =
   let
     fun abshyp i (Hyp t) = if h aconv t then PBound i else raise Same.SAME
       | abshyp i (Abst (s, T, prf)) = Abst (s, T, abshyp i prf)
       | abshyp i (AbsP (s, t, prf)) = AbsP (s, t, abshyp (i + 1) prf)
       | abshyp i (prf % t) = abshyp i prf % t
       | abshyp i (prf1 %% prf2) =
           (abshyp i prf1 %% abshyph i prf2
             handle Same.SAME => prf1 %% abshyp i prf2)
       | abshyp _ _ = raise Same.SAME
     and abshyph i prf = (abshyp i prf handle Same.SAME => prf);
   in
     AbsP ("H", f h, abshyph 0 prf)
   end;
 
 val implies_intr_proof = gen_implies_intr_proof (K NONE);
 val implies_intr_proof' = gen_implies_intr_proof SOME;
 
 
 (* forall introduction *)
 
 fun forall_intr_proof (a, v) opt_T prf = Abst (a, opt_T, prf_abstract_over v prf);
 
 fun forall_intr_proof' v prf =
   let val (a, T) = (case v of Var ((a, _), T) => (a, T) | Free (a, T) => (a, T))
   in forall_intr_proof (a, v) (SOME T) prf end;
 
 
 (* varify *)
 
 fun varify_proof t fixed prf =
   let
     val fs = Term.fold_types (Term.fold_atyps
       (fn TFree v => if member (op =) fixed v then I else insert (op =) v | _ => I)) t [];
     val used = Name.context
       |> fold_types (fold_atyps (fn TVar ((a, _), _) => Name.declare a | _ => I)) t;
     val fmap = fs ~~ #1 (fold_map Name.variant (map fst fs) used);
     fun thaw (a, S) =
       (case AList.lookup (op =) fmap (a, S) of
         NONE => TFree (a, S)
       | SOME b => TVar ((b, 0), S));
   in map_proof_terms (map_types (map_type_tfree thaw)) (map_type_tfree thaw) prf end;
 
 
 local
 
 fun new_name ix (pairs, used) =
   let val v = singleton (Name.variant_list used) (string_of_indexname ix)
   in ((ix, v) :: pairs, v :: used) end;
 
 fun freeze_one alist (ix, sort) =
   (case AList.lookup (op =) alist ix of
     NONE => TVar (ix, sort)
   | SOME name => TFree (name, sort));
 
 in
 
 fun legacy_freezeT t prf =
   let
     val used = Term.add_tfree_names t [];
     val (alist, _) = fold_rev new_name (map #1 (Term.add_tvars t [])) ([], used);
   in
     (case alist of
       [] => prf (*nothing to do!*)
     | _ =>
         let val frzT = map_type_tvar (freeze_one alist)
         in map_proof_terms (map_types frzT) frzT prf end)
   end;
 
 end;
 
 
 (* rotate assumptions *)
 
 fun rotate_proof Bs Bi' params asms m prf =
   let
     val i = length asms;
     val j = length Bs;
   in
     mk_AbsP (Bs @ [Bi']) (proof_combP (prf, map PBound
       (j downto 1) @ [mk_Abst params (mk_AbsP asms
         (proof_combP (proof_combt (PBound i, map Bound ((length params - 1) downto 0)),
           map PBound (((i-m-1) downto 0) @ ((i-1) downto (i-m))))))]))
   end;
 
 
 (* permute premises *)
 
 fun permute_prems_proof prems' j k prf =
   let val n = length prems' in
     mk_AbsP prems'
       (proof_combP (prf, map PBound ((n-1 downto n-j) @ (k-1 downto 0) @ (n-j-1 downto k))))
   end;
 
 
 (* generalization *)
 
 fun generalize_proof (tfrees, frees) idx prop prf =
   let
     val gen =
       if Symtab.is_empty frees then []
       else
         fold_aterms (fn Free (x, T) => Symtab.defined frees x ? insert (op =) (x, T) | _ => I)
           (Term_Subst.generalize (tfrees, Symtab.empty) idx prop) [];
   in
     prf
     |> Same.commit (map_proof_terms_same
         (Term_Subst.generalize_same (tfrees, Symtab.empty) idx)
         (Term_Subst.generalizeT_same tfrees idx))
     |> fold (fn (x, T) => forall_intr_proof (x, Free (x, T)) NONE) gen
     |> fold_rev (fn (x, T) => fn prf' => prf' %> Var (Name.clean_index (x, idx), T)) gen
   end;
 
 
 (* instantiation *)
 
 fun instantiate (instT, inst) =
   Same.commit (map_proof_terms_same
     (Term_Subst.instantiate_same (instT, Term_Subst.Vars.map (K remove_types) inst))
     (Term_Subst.instantiateT_same instT));
 
 
 (* lifting *)
 
 fun lift_proof Bi inc prop prf =
   let
     fun lift'' Us Ts t =
       strip_abs Ts (Logic.incr_indexes ([], Us, inc) (mk_abs Ts t));
 
     fun lift' Us Ts (Abst (s, T, prf)) =
           (Abst (s, Same.map_option (Logic.incr_tvar_same inc) T, lifth' Us (dummyT::Ts) prf)
            handle Same.SAME => Abst (s, T, lift' Us (dummyT::Ts) prf))
       | lift' Us Ts (AbsP (s, t, prf)) =
           (AbsP (s, Same.map_option (same (op =) (lift'' Us Ts)) t, lifth' Us Ts prf)
            handle Same.SAME => AbsP (s, t, lift' Us Ts prf))
       | lift' Us Ts (prf % t) = (lift' Us Ts prf % Option.map (lift'' Us Ts) t
           handle Same.SAME => prf % Same.map_option (same (op =) (lift'' Us Ts)) t)
       | lift' Us Ts (prf1 %% prf2) = (lift' Us Ts prf1 %% lifth' Us Ts prf2
           handle Same.SAME => prf1 %% lift' Us Ts prf2)
       | lift' _ _ (PAxm (s, prop, Ts)) =
           PAxm (s, prop, (Same.map_option o Same.map) (Logic.incr_tvar_same inc) Ts)
       | lift' _ _ (PClass (T, c)) =
           PClass (Logic.incr_tvar_same inc T, c)
       | lift' _ _ (Oracle (s, prop, Ts)) =
           Oracle (s, prop, (Same.map_option o Same.map) (Logic.incr_tvar_same inc) Ts)
       | lift' _ _ (PThm ({serial = i, pos = p, theory_name, name = s, prop, types = Ts}, thm_body)) =
           PThm (thm_header i p theory_name s prop
             ((Same.map_option o Same.map) (Logic.incr_tvar inc) Ts), thm_body)
       | lift' _ _ _ = raise Same.SAME
     and lifth' Us Ts prf = (lift' Us Ts prf handle Same.SAME => prf);
 
     val ps = map (Logic.lift_all inc Bi) (Logic.strip_imp_prems prop);
     val k = length ps;
 
     fun mk_app b (i, j, prf) =
           if b then (i-1, j, prf %% PBound i) else (i, j-1, prf %> Bound j);
 
     fun lift Us bs i j (Const ("Pure.imp", _) $ A $ B) =
             AbsP ("H", NONE (*A*), lift Us (true::bs) (i+1) j B)
       | lift Us bs i j (Const ("Pure.all", _) $ Abs (a, T, t)) =
             Abst (a, NONE (*T*), lift (T::Us) (false::bs) i (j+1) t)
       | lift Us bs i j _ = proof_combP (lifth' (rev Us) [] prf,
             map (fn k => (#3 (fold_rev mk_app bs (i-1, j-1, PBound k))))
               (i + k - 1 downto i));
   in
     mk_AbsP ps (lift [] [] 0 0 Bi)
   end;
 
 fun incr_indexes i =
   Same.commit (map_proof_terms_same
     (Logic.incr_indexes_same ([], [], i)) (Logic.incr_tvar_same i));
 
 
 (* proof by assumption *)
 
 fun mk_asm_prf t i m =
   let
     fun imp_prf _ i 0 = PBound i
       | imp_prf (Const ("Pure.imp", _) $ A $ B) i m = AbsP ("H", NONE (*A*), imp_prf B (i+1) (m-1))
       | imp_prf _ i _ = PBound i;
     fun all_prf (Const ("Pure.all", _) $ Abs (a, T, t)) = Abst (a, NONE (*T*), all_prf t)
       | all_prf t = imp_prf t (~i) m
   in all_prf t end;
 
 fun assumption_proof Bs Bi n prf =
   mk_AbsP Bs (proof_combP (prf, map PBound (length Bs - 1 downto 0) @ [mk_asm_prf Bi n ~1]));
 
 
 (* composition of object rule with proof state *)
 
 fun flatten_params_proof i j n (Const ("Pure.imp", _) $ A $ B, k) =
       AbsP ("H", NONE (*A*), flatten_params_proof (i+1) j n (B, k))
   | flatten_params_proof i j n (Const ("Pure.all", _) $ Abs (a, T, t), k) =
       Abst (a, NONE (*T*), flatten_params_proof i (j+1) n (t, k))
   | flatten_params_proof i j n (_, k) = proof_combP (proof_combt (PBound (k+i),
       map Bound (j-1 downto 0)), map PBound (remove (op =) (i-n) (i-1 downto 0)));
 
 fun bicompose_proof flatten Bs As A oldAs n m rprf sprf =
   let
     val lb = length Bs;
     val la = length As;
   in
     mk_AbsP (Bs @ As) (proof_combP (sprf,
       map PBound (lb + la - 1 downto la)) %%
         proof_combP (rprf, (if n>0 then [mk_asm_prf (the A) n m] else []) @
           map (if flatten then flatten_params_proof 0 0 n else PBound o snd)
             (oldAs ~~ (la - 1 downto 0))))
   end;
 
 
 
 (** type classes **)
 
 fun strip_shyps_proof algebra present witnessed extra prf =
   let
     val replacements = present @ witnessed @ map (`Logic.dummy_tfree) extra;
     fun get_replacement S =
       replacements |> get_first (fn (T', S') =>
         if Sorts.sort_le algebra (S', S) then SOME T' else NONE);
     fun replace T =
       if exists (fn (T', _) => T' = T) present then raise Same.SAME
       else
         (case get_replacement (Type.sort_of_atyp T) of
           SOME T' => T'
         | NONE => raise Fail "strip_shyps_proof: bad type variable in proof term");
   in Same.commit (map_proof_types_same (Term_Subst.map_atypsT_same replace)) prf end;
 
 fun of_sort_proof algebra classrel_proof arity_proof hyps =
   Sorts.of_sort_derivation algebra
    {class_relation = fn _ => fn _ => fn (prf, c1) => fn c2 =>
       if c1 = c2 then prf else classrel_proof (c1, c2) %% prf,
     type_constructor = fn (a, _) => fn dom => fn c =>
       let val Ss = map (map snd) dom and prfs = maps (map fst) dom
       in proof_combP (arity_proof (a, Ss, c), prfs) end,
     type_variable = fn typ => map (fn c => (hyps (typ, c), c)) (Type.sort_of_atyp typ)};
 
 
 
 (** axioms and theorems **)
 
 val add_type_variables = (fold_types o fold_atyps) (insert (op =));
 fun type_variables_of t = rev (add_type_variables t []);
 
 val add_variables = fold_aterms (fn a => (is_Var a orelse is_Free a) ? insert (op =) a);
 fun variables_of t = rev (add_variables t []);
 
 fun test_args _ [] = true
   | test_args is (Bound i :: ts) =
       not (member (op =) is i) andalso test_args (i :: is) ts
   | test_args _ _ = false;
 
 fun is_fun (Type ("fun", _)) = true
   | is_fun (TVar _) = true
   | is_fun _ = false;
 
 fun vars_of t = map Var (rev (Term.add_vars t []));
 
 fun add_funvars Ts (vs, t) =
   if is_fun (fastype_of1 (Ts, t)) then
     union (op =) vs (map_filter (fn Var (ixn, T) =>
       if is_fun T then SOME ixn else NONE | _ => NONE) (vars_of t))
   else vs;
 
 fun add_npvars q p Ts (vs, Const ("Pure.imp", _) $ t $ u) =
       add_npvars q p Ts (add_npvars q (not p) Ts (vs, t), u)
   | add_npvars q p Ts (vs, Const ("Pure.all", Type (_, [Type (_, [T, _]), _])) $ t) =
       add_npvars q p Ts (vs, if p andalso q then betapply (t, Var (("",0), T)) else t)
   | add_npvars q p Ts (vs, Abs (_, T, t)) = add_npvars q p (T::Ts) (vs, t)
   | add_npvars _ _ Ts (vs, t) = add_npvars' Ts (vs, t)
 and add_npvars' Ts (vs, t) =
   (case strip_comb t of
     (Var (ixn, _), ts) => if test_args [] ts then vs
       else Library.foldl (add_npvars' Ts)
         (AList.update (op =) (ixn,
           Library.foldl (add_funvars Ts) ((these ooo AList.lookup) (op =) vs ixn, ts)) vs, ts)
   | (Abs (_, T, u), ts) => Library.foldl (add_npvars' (T::Ts)) (vs, u :: ts)
   | (_, ts) => Library.foldl (add_npvars' Ts) (vs, ts));
 
 fun prop_vars (Const ("Pure.imp", _) $ P $ Q) = union (op =) (prop_vars P) (prop_vars Q)
   | prop_vars (Const ("Pure.all", _) $ Abs (_, _, t)) = prop_vars t
   | prop_vars t = (case strip_comb t of (Var (ixn, _), _) => [ixn] | _ => []);
 
 fun is_proj t =
   let
     fun is_p i t =
       (case strip_comb t of
         (Bound _, []) => false
       | (Bound j, ts) => j >= i orelse exists (is_p i) ts
       | (Abs (_, _, u), _) => is_p (i+1) u
       | (_, ts) => exists (is_p i) ts)
   in
     (case strip_abs_body t of
       Bound _ => true
     | t' => is_p 0 t')
   end;
 
 fun prop_args prop =
   let
     val needed_vars =
       union (op =) (Library.foldl (uncurry (union (op =)))
         ([], map (uncurry (insert (op =))) (add_npvars true true [] ([], prop))))
       (prop_vars prop);
   in
     variables_of prop |> map
       (fn var as Var (ixn, _) => if member (op =) needed_vars ixn then SOME var else NONE
         | free => SOME free)
   end;
 
 fun const_proof mk name prop =
   let
     val args = prop_args prop;
     val ({outer_constraints, ...}, prop1) = Logic.unconstrainT [] prop;
     val head = mk (name, prop1, NONE);
   in proof_combP (proof_combt' (head, args), map PClass outer_constraints) end;
 
 val axm_proof = const_proof PAxm;
 val oracle_proof = const_proof Oracle;
 
 val shrink_proof =
   let
     fun shrink ls lev (prf as Abst (a, T, body)) =
           let val (b, is, ch, body') = shrink ls (lev+1) body
           in (b, is, ch, if ch then Abst (a, T, body') else prf) end
       | shrink ls lev (prf as AbsP (a, t, body)) =
           let val (b, is, ch, body') = shrink (lev::ls) lev body
           in (b orelse member (op =) is 0, map_filter (fn 0 => NONE | i => SOME (i-1)) is,
             ch, if ch then AbsP (a, t, body') else prf)
           end
       | shrink ls lev prf =
           let val (is, ch, _, prf') = shrink' ls lev [] [] prf
           in (false, is, ch, prf') end
     and shrink' ls lev ts prfs (prf as prf1 %% prf2) =
           let
             val p as (_, is', ch', prf') = shrink ls lev prf2;
             val (is, ch, ts', prf'') = shrink' ls lev ts (p::prfs) prf1
           in (union (op =) is is', ch orelse ch', ts',
               if ch orelse ch' then prf'' %% prf' else prf)
           end
       | shrink' ls lev ts prfs (prf as prf1 % t) =
           let val (is, ch, (ch', t')::ts', prf') = shrink' ls lev (t::ts) prfs prf1
           in (is, ch orelse ch', ts',
               if ch orelse ch' then prf' % t' else prf) end
       | shrink' ls lev ts prfs (prf as PBound i) =
           (if exists (fn SOME (Bound j) => lev-j <= nth ls i | _ => true) ts
              orelse has_duplicates (op =)
                (Library.foldl (fn (js, SOME (Bound j)) => j :: js | (js, _) => js) ([], ts))
              orelse exists #1 prfs then [i] else [], false, map (pair false) ts, prf)
       | shrink' _ _ ts _ (Hyp t) = ([], false, map (pair false) ts, Hyp t)
       | shrink' _ _ ts _ (prf as MinProof) = ([], false, map (pair false) ts, prf)
       | shrink' _ _ ts _ (prf as PClass _) = ([], false, map (pair false) ts, prf)
       | shrink' _ _ ts prfs prf =
           let
             val prop =
               (case prf of
                 PAxm (_, prop, _) => prop
               | Oracle (_, prop, _) => prop
               | PThm ({prop, ...}, _) => prop
               | _ => raise Fail "shrink: proof not in normal form");
             val vs = vars_of prop;
             val (ts', ts'') = chop (length vs) ts;
             val insts = take (length ts') (map (fst o dest_Var) vs) ~~ ts';
             val nvs = Library.foldl (fn (ixns', (ixn, ixns)) =>
               insert (op =) ixn
                 (case AList.lookup (op =) insts ixn of
                   SOME (SOME t) => if is_proj t then union (op =) ixns ixns' else ixns'
                 | _ => union (op =) ixns ixns'))
                   (needed prop ts'' prfs, add_npvars false true [] ([], prop));
             val insts' = map
               (fn (ixn, x as SOME _) => if member (op =) nvs ixn then (false, x) else (true, NONE)
                 | (_, x) => (false, x)) insts
           in ([], false, insts' @ map (pair false) ts'', prf) end
     and needed (Const ("Pure.imp", _) $ t $ u) ts ((b, _, _, _)::prfs) =
           union (op =) (if b then map (fst o dest_Var) (vars_of t) else []) (needed u ts prfs)
       | needed (Var (ixn, _)) (_::_) _ = [ixn]
       | needed _ _ _ = [];
   in fn prf => #4 (shrink [] 0 prf) end;
 
 
 
 (** axioms for equality **)
 
 val aT = TFree ("'a", []);
 val bT = TFree ("'b", []);
 val x = Free ("x", aT);
 val y = Free ("y", aT);
 val z = Free ("z", aT);
 val A = Free ("A", propT);
 val B = Free ("B", propT);
 val f = Free ("f", aT --> bT);
 val g = Free ("g", aT --> bT);
 
 val equality_axms =
  [("reflexive", Logic.mk_equals (x, x)),
   ("symmetric", Logic.mk_implies (Logic.mk_equals (x, y), Logic.mk_equals (y, x))),
   ("transitive",
     Logic.list_implies ([Logic.mk_equals (x, y), Logic.mk_equals (y, z)], Logic.mk_equals (x, z))),
   ("equal_intr",
     Logic.list_implies ([Logic.mk_implies (A, B), Logic.mk_implies (B, A)], Logic.mk_equals (A, B))),
   ("equal_elim", Logic.list_implies ([Logic.mk_equals (A, B), A], B)),
   ("abstract_rule",
     Logic.mk_implies
       (Logic.all x (Logic.mk_equals (f $ x, g $ x)),
         Logic.mk_equals (lambda x (f $ x), lambda x (g $ x)))),
   ("combination", Logic.list_implies
     ([Logic.mk_equals (f, g), Logic.mk_equals (x, y)], Logic.mk_equals (f $ x, g $ y)))];
 
 val [reflexive_axm, symmetric_axm, transitive_axm, equal_intr_axm,
   equal_elim_axm, abstract_rule_axm, combination_axm] =
     map (fn (s, t) => PAxm ("Pure." ^ s, Logic.varify_global t, NONE)) equality_axms;
 
 val reflexive_proof = reflexive_axm % NONE;
 
 val is_reflexive_proof = fn PAxm ("Pure.reflexive", _, _) % _ => true | _ => false;
 
 fun symmetric_proof prf =
   if is_reflexive_proof prf then prf
   else symmetric_axm % NONE % NONE %% prf;
 
 fun transitive_proof U u prf1 prf2 =
   if is_reflexive_proof prf1 then prf2
   else if is_reflexive_proof prf2 then prf1
   else if U = propT then transitive_axm % NONE % SOME (remove_types u) % NONE %% prf1 %% prf2
   else transitive_axm % NONE % NONE % NONE %% prf1 %% prf2;
 
 fun equal_intr_proof A B prf1 prf2 =
   equal_intr_axm %> remove_types A %> remove_types B %% prf1 %% prf2;
 
 fun equal_elim_proof A B prf1 prf2 =
   equal_elim_axm %> remove_types A %> remove_types B %% prf1 %% prf2;
 
 fun abstract_rule_proof (a, x) prf =
   abstract_rule_axm % NONE % NONE %% forall_intr_proof (a, x) NONE prf;
 
 fun check_comb (PAxm ("Pure.combination", _, _) % f % _ % _ % _ %% prf %% _) =
       is_some f orelse check_comb prf
   | check_comb (PAxm ("Pure.transitive", _, _) % _ % _ % _ %% prf1 %% prf2) =
       check_comb prf1 andalso check_comb prf2
   | check_comb (PAxm ("Pure.symmetric", _, _) % _ % _ %% prf) = check_comb prf
   | check_comb _ = false;
 
 fun combination_proof f g t u prf1 prf2 =
   let
     val f = Envir.beta_norm f;
     val g = Envir.beta_norm g;
     val prf =
       if check_comb prf1 then
         combination_axm % NONE % NONE
       else
         (case prf1 of
           PAxm ("Pure.reflexive", _, _) % _ =>
             combination_axm %> remove_types f % NONE
         | _ => combination_axm %> remove_types f %> remove_types g)
   in
     prf %
       (case head_of f of
         Abs _ => SOME (remove_types t)
       | Var _ => SOME (remove_types t)
       | _ => NONE) %
       (case head_of g of
         Abs _ => SOME (remove_types u)
       | Var _ => SOME (remove_types u)
       | _ => NONE) %% prf1 %% prf2
   end;
 
 
 
 (** rewriting on proof terms **)
 
 (* simple first order matching functions for terms and proofs (see pattern.ML) *)
 
 exception PMatch;
 
 fun flt (i: int) = filter (fn n => n < i);
 
 fun fomatch Ts tymatch j instsp p =
   let
     fun mtch (instsp as (tyinsts, insts)) = fn
         (Var (ixn, T), t)  =>
           if j>0 andalso not (null (flt j (loose_bnos t)))
           then raise PMatch
           else (tymatch (tyinsts, fn () => (T, fastype_of1 (Ts, t))),
             (ixn, t) :: insts)
       | (Free (a, T), Free (b, U)) =>
           if a=b then (tymatch (tyinsts, K (T, U)), insts) else raise PMatch
       | (Const (a, T), Const (b, U))  =>
           if a=b then (tymatch (tyinsts, K (T, U)), insts) else raise PMatch
       | (f $ t, g $ u) => mtch (mtch instsp (f, g)) (t, u)
       | (Bound i, Bound j) => if i=j then instsp else raise PMatch
       | _ => raise PMatch
   in mtch instsp (apply2 Envir.beta_eta_contract p) end;
 
 fun match_proof Ts tymatch =
   let
     fun optmatch _ inst (NONE, _) = inst
       | optmatch _ _ (SOME _, NONE) = raise PMatch
       | optmatch mtch inst (SOME x, SOME y) = mtch inst (x, y)
 
     fun matcht Ts j (pinst, tinst) (t, u) =
       (pinst, fomatch Ts tymatch j tinst (t, Envir.beta_norm u));
     fun matchT (pinst, (tyinsts, insts)) p =
       (pinst, (tymatch (tyinsts, K p), insts));
     fun matchTs inst (Ts, Us) = Library.foldl (uncurry matchT) (inst, Ts ~~ Us);
 
     fun mtch Ts i j (pinst, tinst) (Hyp (Var (ixn, _)), prf) =
           if i = 0 andalso j = 0 then ((ixn, prf) :: pinst, tinst)
           else
             (case apfst (flt i) (apsnd (flt j) (prf_add_loose_bnos 0 0 prf ([], []))) of
               ([], []) => ((ixn, incr_pboundvars (~i) (~j) prf) :: pinst, tinst)
             | ([], _) =>
                 if j = 0 then ((ixn, incr_pboundvars (~i) (~j) prf) :: pinst, tinst)
                 else raise PMatch
             | _ => raise PMatch)
       | mtch Ts i j inst (prf1 % opt1, prf2 % opt2) =
           optmatch (matcht Ts j) (mtch Ts i j inst (prf1, prf2)) (opt1, opt2)
       | mtch Ts i j inst (prf1 %% prf2, prf1' %% prf2') =
           mtch Ts i j (mtch Ts i j inst (prf1, prf1')) (prf2, prf2')
       | mtch Ts i j inst (Abst (_, opT, prf1), Abst (_, opU, prf2)) =
           mtch (the_default dummyT opU :: Ts) i (j+1)
             (optmatch matchT inst (opT, opU)) (prf1, prf2)
       | mtch Ts i j inst (prf1, Abst (_, opU, prf2)) =
           mtch (the_default dummyT opU :: Ts) i (j+1) inst
             (incr_pboundvars 0 1 prf1 %> Bound 0, prf2)
       | mtch Ts i j inst (AbsP (_, opt, prf1), AbsP (_, opu, prf2)) =
           mtch Ts (i+1) j (optmatch (matcht Ts j) inst (opt, opu)) (prf1, prf2)
       | mtch Ts i j inst (prf1, AbsP (_, _, prf2)) =
           mtch Ts (i+1) j inst (incr_pboundvars 1 0 prf1 %% PBound 0, prf2)
       | mtch Ts i j inst (PAxm (s1, _, opTs), PAxm (s2, _, opUs)) =
           if s1 = s2 then optmatch matchTs inst (opTs, opUs)
           else raise PMatch
       | mtch Ts i j inst (PClass (T1, c1), PClass (T2, c2)) =
           if c1 = c2 then matchT inst (T1, T2)
           else raise PMatch
       | mtch Ts i j inst
             (PThm ({name = name1, prop = prop1, types = types1, ...}, _),
               PThm ({name = name2, prop = prop2, types = types2, ...}, _)) =
           if name1 = name2 andalso prop1 = prop2
           then optmatch matchTs inst (types1, types2)
           else raise PMatch
       | mtch _ _ _ inst (PBound i, PBound j) = if i = j then inst else raise PMatch
       | mtch _ _ _ _ _ = raise PMatch
   in mtch Ts 0 0 end;
 
 fun prf_subst (pinst, (tyinsts, insts)) =
   let
     val substT = Envir.subst_type_same tyinsts;
     val substTs = Same.map substT;
 
     fun subst' lev (Var (xi, _)) =
         (case AList.lookup (op =) insts xi of
           NONE => raise Same.SAME
         | SOME u => incr_boundvars lev u)
       | subst' _ (Const (s, T)) = Const (s, substT T)
       | subst' _ (Free (s, T)) = Free (s, substT T)
       | subst' lev (Abs (a, T, body)) =
           (Abs (a, substT T, Same.commit (subst' (lev + 1)) body)
             handle Same.SAME => Abs (a, T, subst' (lev + 1) body))
       | subst' lev (f $ t) =
           (subst' lev f $ Same.commit (subst' lev) t
             handle Same.SAME => f $ subst' lev t)
       | subst' _ _ = raise Same.SAME;
 
     fun subst plev tlev (AbsP (a, t, body)) =
           (AbsP (a, Same.map_option (subst' tlev) t, Same.commit (subst (plev + 1) tlev) body)
             handle Same.SAME => AbsP (a, t, subst (plev + 1) tlev body))
       | subst plev tlev (Abst (a, T, body)) =
           (Abst (a, Same.map_option substT T, Same.commit (subst plev (tlev + 1)) body)
             handle Same.SAME => Abst (a, T, subst plev (tlev + 1) body))
       | subst plev tlev (prf %% prf') =
           (subst plev tlev prf %% Same.commit (subst plev tlev) prf'
             handle Same.SAME => prf %% subst plev tlev prf')
       | subst plev tlev (prf % t) =
           (subst plev tlev prf % Same.commit (Same.map_option (subst' tlev)) t
             handle Same.SAME => prf % Same.map_option (subst' tlev) t)
       | subst plev tlev (Hyp (Var (xi, _))) =
           (case AList.lookup (op =) pinst xi of
             NONE => raise Same.SAME
           | SOME prf' => incr_pboundvars plev tlev prf')
       | subst _ _ (PAxm (id, prop, Ts)) = PAxm (id, prop, Same.map_option substTs Ts)
       | subst _ _ (PClass (T, c)) = PClass (substT T, c)
       | subst _ _ (Oracle (id, prop, Ts)) = Oracle (id, prop, Same.map_option substTs Ts)
       | subst _ _ (PThm ({serial = i, pos = p, theory_name, name = id, prop, types}, thm_body)) =
           PThm (thm_header i p theory_name id prop (Same.map_option substTs types), thm_body)
       | subst _ _ _ = raise Same.SAME;
   in fn t => subst 0 0 t handle Same.SAME => t end;
 
 (*A fast unification filter: true unless the two terms cannot be unified.
   Terms must be NORMAL.  Treats all Vars as distinct. *)
 fun could_unify prf1 prf2 =
   let
     fun matchrands (prf1 %% prf2) (prf1' %% prf2') =
           could_unify prf2 prf2' andalso matchrands prf1 prf1'
       | matchrands (prf % SOME t) (prf' % SOME t') =
           Term.could_unify (t, t') andalso matchrands prf prf'
       | matchrands (prf % _) (prf' % _) = matchrands prf prf'
       | matchrands _ _ = true
 
     fun head_of (prf %% _) = head_of prf
       | head_of (prf % _) = head_of prf
       | head_of prf = prf
 
   in case (head_of prf1, head_of prf2) of
         (_, Hyp (Var _)) => true
       | (Hyp (Var _), _) => true
       | (PAxm (a, _, _), PAxm (b, _, _)) => a = b andalso matchrands prf1 prf2
       | (PClass (_, c), PClass (_, d)) => c = d andalso matchrands prf1 prf2
       | (PThm ({name = a, prop = propa, ...}, _), PThm ({name = b, prop = propb, ...}, _)) =>
           a = b andalso propa = propb andalso matchrands prf1 prf2
       | (PBound i, PBound j) => i = j andalso matchrands prf1 prf2
       | (AbsP _, _) =>  true   (*because of possible eta equality*)
       | (Abst _, _) =>  true
       | (_, AbsP _) =>  true
       | (_, Abst _) =>  true
       | _ => false
   end;
 
 
 (* rewrite proof *)
 
 val no_skel = PBound 0;
 val normal_skel = Hyp (Var ((Name.uu, 0), propT));
 
 fun rewrite_prf tymatch (rules, procs) prf =
   let
     fun rew _ _ (Abst (_, _, body) % SOME t) = SOME (prf_subst_bounds [t] body, no_skel)
       | rew _ _ (AbsP (_, _, body) %% prf) = SOME (prf_subst_pbounds [prf] body, no_skel)
       | rew Ts hs prf =
           (case get_first (fn r => r Ts hs prf) procs of
             NONE => get_first (fn (prf1, prf2) => SOME (prf_subst
               (match_proof Ts tymatch ([], (Vartab.empty, [])) (prf1, prf)) prf2, prf2)
                  handle PMatch => NONE) (filter (could_unify prf o fst) rules)
           | some => some);
 
     fun rew0 Ts hs (prf as AbsP (_, _, prf' %% PBound 0)) =
           if prf_loose_Pbvar1 prf' 0 then rew Ts hs prf
           else
             let val prf'' = incr_pboundvars (~1) 0 prf'
             in SOME (the_default (prf'', no_skel) (rew Ts hs prf'')) end
       | rew0 Ts hs (prf as Abst (_, _, prf' % SOME (Bound 0))) =
           if prf_loose_bvar1 prf' 0 then rew Ts hs prf
           else
             let val prf'' = incr_pboundvars 0 (~1) prf'
             in SOME (the_default (prf'', no_skel) (rew Ts hs prf'')) end
       | rew0 Ts hs prf = rew Ts hs prf;
 
     fun rew1 _ _ (Hyp (Var _)) _ = NONE
       | rew1 Ts hs skel prf =
           (case rew2 Ts hs skel prf of
             SOME prf1 =>
               (case rew0 Ts hs prf1 of
                 SOME (prf2, skel') => SOME (the_default prf2 (rew1 Ts hs skel' prf2))
               | NONE => SOME prf1)
           | NONE =>
               (case rew0 Ts hs prf of
                 SOME (prf1, skel') => SOME (the_default prf1 (rew1 Ts hs skel' prf1))
               | NONE => NONE))
 
     and rew2 Ts hs skel (prf % SOME t) =
           (case prf of
             Abst (_, _, body) =>
               let val prf' = prf_subst_bounds [t] body
               in SOME (the_default prf' (rew2 Ts hs no_skel prf')) end
           | _ =>
               (case rew1 Ts hs (case skel of skel' % _ => skel' | _ => no_skel) prf of
                 SOME prf' => SOME (prf' % SOME t)
               | NONE => NONE))
       | rew2 Ts hs skel (prf % NONE) = Option.map (fn prf' => prf' % NONE)
           (rew1 Ts hs (case skel of skel' % _ => skel' | _ => no_skel) prf)
       | rew2 Ts hs skel (prf1 %% prf2) =
           (case prf1 of
             AbsP (_, _, body) =>
               let val prf' = prf_subst_pbounds [prf2] body
               in SOME (the_default prf' (rew2 Ts hs no_skel prf')) end
           | _ =>
             let
               val (skel1, skel2) =
                 (case skel of
                   skel1 %% skel2 => (skel1, skel2)
                 | _ => (no_skel, no_skel))
             in
               (case rew1 Ts hs skel1 prf1 of
                 SOME prf1' =>
                   (case rew1 Ts hs skel2 prf2 of
                     SOME prf2' => SOME (prf1' %% prf2')
                   | NONE => SOME (prf1' %% prf2))
               | NONE =>
                   (case rew1 Ts hs skel2 prf2 of
                     SOME prf2' => SOME (prf1 %% prf2')
                   | NONE => NONE))
             end)
       | rew2 Ts hs skel (Abst (s, T, prf)) =
           (case rew1 (the_default dummyT T :: Ts) hs
               (case skel of Abst (_, _, skel') => skel' | _ => no_skel) prf of
             SOME prf' => SOME (Abst (s, T, prf'))
           | NONE => NONE)
       | rew2 Ts hs skel (AbsP (s, t, prf)) =
           (case rew1 Ts (t :: hs) (case skel of AbsP (_, _, skel') => skel' | _ => no_skel) prf of
             SOME prf' => SOME (AbsP (s, t, prf'))
           | NONE => NONE)
       | rew2 _ _ _ _ = NONE;
 
   in the_default prf (rew1 [] [] no_skel prf) end;
 
 fun rewrite_proof thy = rewrite_prf (fn (tyenv, f) =>
   Sign.typ_match thy (f ()) tyenv handle Type.TYPE_MATCH => raise PMatch);
 
 fun rewrite_proof_notypes rews = rewrite_prf fst rews;
 
 
 (* theory data *)
 
 structure Data = Theory_Data
 (
   type T =
     ((stamp * (proof * proof)) list *
      (stamp * (typ list -> term option list -> proof -> (proof * proof) option)) list) *
     (theory -> proof -> proof) option;
 
   val empty = (([], []), NONE);
   val extend = I;
   fun merge (((rules1, procs1), preproc1), ((rules2, procs2), preproc2)) : T =
     ((AList.merge (op =) (K true) (rules1, rules2),
       AList.merge (op =) (K true) (procs1, procs2)),
       merge_options (preproc1, preproc2));
 );
 
 fun get_rew_data thy =
   let val (rules, procs) = #1 (Data.get thy)
   in (map #2 rules, map #2 procs) end;
 
 fun rew_proof thy = rewrite_prf fst (get_rew_data thy);
 
 fun add_prf_rrule r = (Data.map o apfst o apfst) (cons (stamp (), r));
 fun add_prf_rproc p = (Data.map o apfst o apsnd) (cons (stamp (), p));
 
 fun set_preproc f = (Data.map o apsnd) (K (SOME f));
 fun apply_preproc thy = (case #2 (Data.get thy) of NONE => I | SOME f => f thy);
 
 
 
 (** reconstruction of partial proof terms **)
 
 fun forall_intr_variables_term prop = fold_rev Logic.all (variables_of prop) prop;
 fun forall_intr_variables prop prf = fold_rev forall_intr_proof' (variables_of prop) prf;
 
 local
 
 fun app_types shift prop Ts prf =
   let
     val inst = type_variables_of prop ~~ Ts;
     fun subst_same A =
       (case AList.lookup (op =) inst A of SOME T => T | NONE => raise Same.SAME);
     val subst_type_same =
       Term_Subst.map_atypsT_same
         (fn TVar ((a, i), S) => subst_same (TVar ((a, i - shift), S)) | A => subst_same A);
   in Same.commit (map_proof_types_same subst_type_same) prf end;
 
 fun guess_name (PThm ({name, ...}, _)) = name
   | guess_name (prf %% Hyp _) = guess_name prf
   | guess_name (prf %% PClass _) = guess_name prf
   | guess_name (prf % NONE) = guess_name prf
   | guess_name (prf % SOME (Var _)) = guess_name prf
   | guess_name _ = "";
 
 
 (* generate constraints for proof term *)
 
 fun mk_var env Ts T =
   let val (env', v) = Envir.genvar "a" (env, rev Ts ---> T)
   in (list_comb (v, map Bound (length Ts - 1 downto 0)), env') end;
 
 fun mk_tvar S (Envir.Envir {maxidx, tenv, tyenv}) =
   (TVar (("'t", maxidx + 1), S),
     Envir.Envir {maxidx = maxidx + 1, tenv = tenv, tyenv = tyenv});
 
 val mk_abs = fold (fn T => fn u => Abs ("", T, u));
 
 fun unifyT thy env T U =
   let
     val Envir.Envir {maxidx, tenv, tyenv} = env;
     val (tyenv', maxidx') = Sign.typ_unify thy (T, U) (tyenv, maxidx);
   in Envir.Envir {maxidx = maxidx', tenv = tenv, tyenv = tyenv'} end;
 
 fun chaseT env (T as TVar v) =
       (case Type.lookup (Envir.type_env env) v of
         NONE => T
       | SOME T' => chaseT env T')
   | chaseT _ T = T;
 
 fun infer_type thy (env as Envir.Envir {maxidx, tenv, tyenv}) _ vTs (t as Const (s, T)) =
       if T = dummyT then
         (case Sign.const_type thy s of
           NONE => error ("reconstruct_proof: No such constant: " ^ quote s)
         | SOME T =>
             let val T' = Type.strip_sorts (Logic.incr_tvar (maxidx + 1) T) in
               (Const (s, T'), T', vTs,
                 Envir.Envir {maxidx = maxidx + 1, tenv = tenv, tyenv = tyenv})
             end)
       else (t, T, vTs, env)
   | infer_type _ env _ vTs (t as Free (s, T)) =
       if T = dummyT then
         (case Symtab.lookup vTs s of
           NONE =>
             let val (T, env') = mk_tvar [] env
             in (Free (s, T), T, Symtab.update_new (s, T) vTs, env') end
         | SOME T => (Free (s, T), T, vTs, env))
       else (t, T, vTs, env)
   | infer_type _ _ _ _ (Var _) = error "reconstruct_proof: internal error"
   | infer_type thy env Ts vTs (Abs (s, T, t)) =
       let
         val (T', env') = if T = dummyT then mk_tvar [] env else (T, env);
         val (t', U, vTs', env'') = infer_type thy env' (T' :: Ts) vTs t
       in (Abs (s, T', t'), T' --> U, vTs', env'') end
   | infer_type thy env Ts vTs (t $ u) =
       let
         val (t', T, vTs1, env1) = infer_type thy env Ts vTs t;
         val (u', U, vTs2, env2) = infer_type thy env1 Ts vTs1 u;
       in
         (case chaseT env2 T of
           Type ("fun", [U', V]) => (t' $ u', V, vTs2, unifyT thy env2 U U')
         | _ =>
           let val (V, env3) = mk_tvar [] env2
           in (t' $ u', V, vTs2, unifyT thy env3 T (U --> V)) end)
       end
   | infer_type _ env Ts vTs (t as Bound i) = ((t, nth Ts i, vTs, env)
       handle General.Subscript => error ("infer_type: bad variable index " ^ string_of_int i));
 
 fun cantunify thy (t, u) =
   error ("Non-unifiable terms:\n" ^
     Syntax.string_of_term_global thy t ^ "\n\n" ^ Syntax.string_of_term_global thy u);
 
 fun decompose thy Ts (p as (t, u)) env =
   let
     fun rigrig (a, T) (b, U) uT ts us =
       if a <> b then cantunify thy p
       else apfst flat (fold_map (decompose thy Ts) (ts ~~ us) (uT env T U))
   in
     case apply2 (strip_comb o Envir.head_norm env) p of
       ((Const c, ts), (Const d, us)) => rigrig c d (unifyT thy) ts us
     | ((Free c, ts), (Free d, us)) => rigrig c d (unifyT thy) ts us
     | ((Bound i, ts), (Bound j, us)) =>
         rigrig (i, dummyT) (j, dummyT) (K o K) ts us
     | ((Abs (_, T, t), []), (Abs (_, U, u), [])) =>
         decompose thy (T::Ts) (t, u) (unifyT thy env T U)
     | ((Abs (_, T, t), []), _) =>
         decompose thy (T::Ts) (t, incr_boundvars 1 u $ Bound 0) env
     | (_, (Abs (_, T, u), [])) =>
         decompose thy (T::Ts) (incr_boundvars 1 t $ Bound 0, u) env
     | _ => ([(mk_abs Ts t, mk_abs Ts u)], env)
   end;
 
 fun make_constraints_cprf thy env cprf =
   let
     fun add_cnstrt Ts prop prf cs env vTs (t, u) =
       let
         val t' = mk_abs Ts t;
         val u' = mk_abs Ts u
       in
         (prop, prf, cs, Pattern.unify (Context.Theory thy) (t', u') env, vTs)
           handle Pattern.Pattern =>
             let val (cs', env') = decompose thy [] (t', u') env
             in (prop, prf, cs @ cs', env', vTs) end
           | Pattern.Unif => cantunify thy (Envir.norm_term env t', Envir.norm_term env u')
       end;
 
     fun mk_cnstrts_atom env vTs prop opTs prf =
           let
             val prop_types = type_variables_of prop;
             val (Ts, env') =
               (case opTs of
                 NONE => fold_map (mk_tvar o Type.sort_of_atyp) prop_types env
               | SOME Ts => (Ts, env));
             val prop' = subst_atomic_types (prop_types ~~ Ts)
               (forall_intr_variables_term prop) handle ListPair.UnequalLengths =>
                 error ("Wrong number of type arguments for " ^ quote (guess_name prf))
           in (prop', change_types (SOME Ts) prf, [], env', vTs) end;
 
     fun head_norm (prop, prf, cnstrts, env, vTs) =
       (Envir.head_norm env prop, prf, cnstrts, env, vTs);
 
     fun mk_cnstrts env _ Hs vTs (PBound i) = ((nth Hs i, PBound i, [], env, vTs)
           handle General.Subscript => error ("mk_cnstrts: bad variable index " ^ string_of_int i))
       | mk_cnstrts env Ts Hs vTs (Abst (s, opT, cprf)) =
           let
             val (T, env') =
               (case opT of
                 NONE => mk_tvar [] env
               | SOME T => (T, env));
             val (t, prf, cnstrts, env'', vTs') =
               mk_cnstrts env' (T::Ts) (map (incr_boundvars 1) Hs) vTs cprf;
           in
             (Const ("Pure.all", (T --> propT) --> propT) $ Abs (s, T, t), Abst (s, SOME T, prf),
               cnstrts, env'', vTs')
           end
       | mk_cnstrts env Ts Hs vTs (AbsP (s, SOME t, cprf)) =
           let
             val (t', _, vTs', env') = infer_type thy env Ts vTs t;
             val (u, prf, cnstrts, env'', vTs'') = mk_cnstrts env' Ts (t'::Hs) vTs' cprf;
           in (Logic.mk_implies (t', u), AbsP (s, SOME t', prf), cnstrts, env'', vTs'')
           end
       | mk_cnstrts env Ts Hs vTs (AbsP (s, NONE, cprf)) =
           let
             val (t, env') = mk_var env Ts propT;
             val (u, prf, cnstrts, env'', vTs') = mk_cnstrts env' Ts (t::Hs) vTs cprf;
           in (Logic.mk_implies (t, u), AbsP (s, SOME t, prf), cnstrts, env'', vTs')
           end
       | mk_cnstrts env Ts Hs vTs (cprf1 %% cprf2) =
           let val (u, prf2, cnstrts, env', vTs') = mk_cnstrts env Ts Hs vTs cprf2
           in (case head_norm (mk_cnstrts env' Ts Hs vTs' cprf1) of
               (Const ("Pure.imp", _) $ u' $ t', prf1, cnstrts', env'', vTs'') =>
                 add_cnstrt Ts t' (prf1 %% prf2) (cnstrts' @ cnstrts)
                   env'' vTs'' (u, u')
             | (t, prf1, cnstrts', env'', vTs'') =>
                 let val (v, env''') = mk_var env'' Ts propT
                 in add_cnstrt Ts v (prf1 %% prf2) (cnstrts' @ cnstrts)
                   env''' vTs'' (t, Logic.mk_implies (u, v))
                 end)
           end
       | mk_cnstrts env Ts Hs vTs (cprf % SOME t) =
           let val (t', U, vTs1, env1) = infer_type thy env Ts vTs t
           in (case head_norm (mk_cnstrts env1 Ts Hs vTs1 cprf) of
              (Const ("Pure.all", Type ("fun", [Type ("fun", [T, _]), _])) $ f,
                  prf, cnstrts, env2, vTs2) =>
                let val env3 = unifyT thy env2 T U
                in (betapply (f, t'), prf % SOME t', cnstrts, env3, vTs2)
                end
            | (u, prf, cnstrts, env2, vTs2) =>
                let val (v, env3) = mk_var env2 Ts (U --> propT);
                in
                  add_cnstrt Ts (v $ t') (prf % SOME t') cnstrts env3 vTs2
                    (u, Const ("Pure.all", (U --> propT) --> propT) $ v)
                end)
           end
       | mk_cnstrts env Ts Hs vTs (cprf % NONE) =
           (case head_norm (mk_cnstrts env Ts Hs vTs cprf) of
              (Const ("Pure.all", Type ("fun", [Type ("fun", [T, _]), _])) $ f,
                  prf, cnstrts, env', vTs') =>
                let val (t, env'') = mk_var env' Ts T
                in (betapply (f, t), prf % SOME t, cnstrts, env'', vTs')
                end
            | (u, prf, cnstrts, env', vTs') =>
                let
                  val (T, env1) = mk_tvar [] env';
                  val (v, env2) = mk_var env1 Ts (T --> propT);
                  val (t, env3) = mk_var env2 Ts T
                in
                  add_cnstrt Ts (v $ t) (prf % SOME t) cnstrts env3 vTs'
                    (u, Const ("Pure.all", (T --> propT) --> propT) $ v)
                end)
       | mk_cnstrts env _ _ vTs (prf as PThm ({prop, types = opTs, ...}, _)) =
           mk_cnstrts_atom env vTs prop opTs prf
       | mk_cnstrts env _ _ vTs (prf as PAxm (_, prop, opTs)) =
           mk_cnstrts_atom env vTs prop opTs prf
       | mk_cnstrts env _ _ vTs (prf as PClass (T, c)) =
           mk_cnstrts_atom env vTs (Logic.mk_of_class (T, c)) NONE prf
       | mk_cnstrts env _ _ vTs (prf as Oracle (_, prop, opTs)) =
           mk_cnstrts_atom env vTs prop opTs prf
       | mk_cnstrts env _ _ vTs (Hyp t) = (t, Hyp t, [], env, vTs)
       | mk_cnstrts _ _ _ _ MinProof = raise MIN_PROOF ()
   in mk_cnstrts env [] [] Symtab.empty cprf end;
 
 
 (* update list of free variables of constraints *)
 
 fun upd_constrs env cs =
   let
     val tenv = Envir.term_env env;
     val tyenv = Envir.type_env env;
     val dom = []
       |> Vartab.fold (cons o #1) tenv
       |> Vartab.fold (cons o #1) tyenv;
     val vran = []
       |> Vartab.fold (Term.add_var_names o #2 o #2) tenv
       |> Vartab.fold (Term.add_tvar_namesT o #2 o #2) tyenv;
     fun check_cs [] = []
       | check_cs ((u, p, vs) :: ps) =
           let val vs' = subtract (op =) dom vs in
             if vs = vs' then (u, p, vs) :: check_cs ps
             else (true, p, fold (insert op =) vs' vran) :: check_cs ps
           end;
   in check_cs cs end;
 
 
 (* solution of constraints *)
 
 fun solve _ [] bigenv = bigenv
   | solve thy cs bigenv =
       let
         fun search _ [] =
               error ("Unsolvable constraints:\n" ^
                 Pretty.string_of (Pretty.chunks (map (fn (_, p, _) =>
                   Syntax.pretty_flexpair (Syntax.init_pretty_global thy)
                     (apply2 (Envir.norm_term bigenv) p)) cs)))
           | search env ((u, p as (t1, t2), vs)::ps) =
               if u then
                 let
                   val tn1 = Envir.norm_term bigenv t1;
                   val tn2 = Envir.norm_term bigenv t2
                 in
                   if Pattern.pattern tn1 andalso Pattern.pattern tn2 then
                     (Pattern.unify (Context.Theory thy) (tn1, tn2) env, ps)
                       handle Pattern.Unif => cantunify thy (tn1, tn2)
                   else
                     let val (cs', env') = decompose thy [] (tn1, tn2) env
                     in if cs' = [(tn1, tn2)] then
                          apsnd (cons (false, (tn1, tn2), vs)) (search env ps)
                        else search env' (map (fn q => (true, q, vs)) cs' @ ps)
                     end
                 end
               else apsnd (cons (false, p, vs)) (search env ps);
         val Envir.Envir {maxidx, ...} = bigenv;
         val (env, cs') = search (Envir.empty maxidx) cs;
       in
         solve thy (upd_constrs env cs') (Envir.merge (bigenv, env))
       end;
 
 in
 
 
 (* reconstruction of proofs *)
 
 fun reconstruct_proof thy prop cprf =
   let
     val (cprf' % SOME prop', thawf) = freeze_thaw_prf (cprf % SOME prop);
     val (t, prf, cs, env, _) = make_constraints_cprf thy
       (Envir.empty (maxidx_proof cprf ~1)) cprf';
     val cs' =
       map (apply2 (Envir.norm_term env)) ((t, prop') :: cs)
       |> map (fn p => (true, p, Term.add_var_names (#1 p) (Term.add_var_names (#2 p) [])));
     val env' = solve thy cs' env;
   in thawf (norm_proof env' prf) end handle MIN_PROOF () => MinProof;
 
 fun prop_of_atom prop Ts =
   subst_atomic_types (type_variables_of prop ~~ Ts) (forall_intr_variables_term prop);
 
 val head_norm = Envir.head_norm Envir.init;
 
 fun prop_of0 Hs (PBound i) = nth Hs i
   | prop_of0 Hs (Abst (s, SOME T, prf)) =
       Logic.all_const T $ (Abs (s, T, prop_of0 Hs prf))
   | prop_of0 Hs (AbsP (_, SOME t, prf)) =
       Logic.mk_implies (t, prop_of0 (t :: Hs) prf)
   | prop_of0 Hs (prf % SOME t) = (case head_norm (prop_of0 Hs prf) of
       Const ("Pure.all", _) $ f => f $ t
     | _ => error "prop_of: all expected")
   | prop_of0 Hs (prf1 %% _) = (case head_norm (prop_of0 Hs prf1) of
       Const ("Pure.imp", _) $ _ $ Q => Q
     | _ => error "prop_of: ==> expected")
   | prop_of0 _ (Hyp t) = t
   | prop_of0 _ (PThm ({prop, types = SOME Ts, ...}, _)) = prop_of_atom prop Ts
   | prop_of0 _ (PAxm (_, prop, SOME Ts)) = prop_of_atom prop Ts
   | prop_of0 _ (PClass (T, c)) = Logic.mk_of_class (T, c)
   | prop_of0 _ (Oracle (_, prop, SOME Ts)) = prop_of_atom prop Ts
   | prop_of0 _ _ = error "prop_of: partial proof object";
 
 val prop_of' = Envir.beta_eta_contract oo prop_of0;
 val prop_of = prop_of' [];
 
 
 (* expand and reconstruct subproofs *)
 
 fun expand_name_empty (header: thm_header) = if #name header = "" then SOME "" else NONE;
 
 fun expand_proof thy expand_name prf =
   let
     fun expand seen maxidx (AbsP (s, t, prf)) =
           let val (seen', maxidx', prf') = expand seen maxidx prf
           in (seen', maxidx', AbsP (s, t, prf')) end
       | expand seen maxidx (Abst (s, T, prf)) =
           let val (seen', maxidx', prf') = expand seen maxidx prf
           in (seen', maxidx', Abst (s, T, prf')) end
       | expand seen maxidx (prf1 %% prf2) =
           let
             val (seen', maxidx', prf1') = expand seen maxidx prf1;
             val (seen'', maxidx'', prf2') = expand seen' maxidx' prf2;
           in (seen'', maxidx'', prf1' %% prf2') end
       | expand seen maxidx (prf % t) =
           let val (seen', maxidx', prf') = expand seen maxidx prf
           in (seen', maxidx', prf' % t) end
       | expand seen maxidx (prf as PThm (header, thm_body)) =
           let val {serial, pos, theory_name, name, prop, types} = header in
             (case expand_name header of
               SOME name' =>
                 if name' = "" andalso is_some types then
                   let
                     val (seen', maxidx', prf') =
                       (case Inttab.lookup seen serial of
                         NONE =>
                           let
                             val prf1 =
                               thm_body_proof_open thm_body
                               |> reconstruct_proof thy prop
                               |> forall_intr_variables prop;
                             val (seen1, maxidx1, prf2) = expand_init seen prf1
                             val seen2 = seen1 |> Inttab.update (serial, (maxidx1, prf2));
                           in (seen2, maxidx1, prf2) end
                       | SOME (maxidx1, prf1) => (seen, maxidx1, prf1));
                     val prf'' = prf'
                       |> incr_indexes (maxidx + 1) |> app_types (maxidx + 1) prop (the types);
                   in (seen', maxidx' + maxidx + 1, prf'') end
                 else if name' <> name then
                   (seen, maxidx, PThm (thm_header serial pos theory_name name' prop types, thm_body))
                 else (seen, maxidx, prf)
             | NONE => (seen, maxidx, prf))
           end
       | expand seen maxidx prf = (seen, maxidx, prf)
     and expand_init seen prf = expand seen (maxidx_proof prf ~1) prf;
 
   in #3 (expand_init Inttab.empty prf) end;
 
 end;
 
 
 
 (** promises **)
 
 fun fulfill_norm_proof thy ps body0 =
   let
     val _ = consolidate_bodies (map #2 ps @ [body0]);
     val PBody {oracles = oracles0, thms = thms0, proof = proof0} = body0;
     val oracles =
       unions_oracles
         (fold (fn (_, PBody {oracles, ...}) => not (null oracles) ? cons oracles) ps [oracles0]);
     val thms =
       unions_thms (fold (fn (_, PBody {thms, ...}) => not (null thms) ? cons thms) ps [thms0]);
     val proof = rew_proof thy proof0;
   in PBody {oracles = oracles, thms = thms, proof = proof} end;
 
 fun fulfill_proof_future thy promises (postproc: proof_body -> proof_body) body =
   let
     fun fulfill () =
       postproc (fulfill_norm_proof thy (map (apsnd Future.join) promises) (Future.join body));
   in
     if null promises then Future.map postproc body
     else if Future.is_finished body andalso length promises = 1 then
       Future.map (fn _ => fulfill ()) (snd (hd promises))
     else
       (singleton o Future.forks)
         {name = "Proofterm.fulfill_proof_future", group = NONE,
           deps = Future.task_of body :: map (Future.task_of o snd) promises, pri = 1,
           interrupts = true}
         fulfill
   end;
 
 
 
 (** theorems **)
 
 (* standardization of variables for export: only frees and named bounds *)
 
 local
 
 val declare_names_term = Term.declare_term_frees;
 val declare_names_term' = fn SOME t => declare_names_term t | NONE => I;
 val declare_names_proof = fold_proof_terms declare_names_term;
 
 fun variant names bs x =
   #1 (Name.variant x (fold Name.declare bs names));
 
 fun variant_term bs (Abs (x, T, t)) =
       let
         val x' = variant (declare_names_term t Name.context) bs x;
         val t' = variant_term (x' :: bs) t;
       in Abs (x', T, t') end
   | variant_term bs (t $ u) = variant_term bs t $ variant_term bs u
   | variant_term _ t = t;
 
 fun variant_proof bs (Abst (x, T, prf)) =
       let
         val x' = variant (declare_names_proof prf Name.context) bs x;
         val prf' = variant_proof (x' :: bs) prf;
       in Abst (x', T, prf') end
   | variant_proof bs (AbsP (x, t, prf)) =
       let
         val x' = variant (declare_names_term' t (declare_names_proof prf Name.context)) bs x;
         val t' = Option.map (variant_term bs) t;
         val prf' = variant_proof (x' :: bs) prf;
       in AbsP (x', t', prf') end
   | variant_proof bs (prf % t) = variant_proof bs prf % Option.map (variant_term bs) t
   | variant_proof bs (prf1 %% prf2) = variant_proof bs prf1 %% variant_proof bs prf2
   | variant_proof bs (Hyp t) = Hyp (variant_term bs t)
   | variant_proof _ prf = prf;
 
 val used_frees_type = fold_atyps (fn TFree (a, _) => Name.declare a | _ => I);
 fun used_frees_term t = fold_types used_frees_type t #> Term.declare_term_frees t;
 val used_frees_proof = fold_proof_terms_types used_frees_term used_frees_type;
 
 val unvarifyT = Term.map_atyps (fn TVar ((a, _), S) => TFree (a, S) | T => T);
 val unvarify = Term.map_aterms (fn Var ((x, _), T) => Free (x, T) | t => t) #> map_types unvarifyT;
 val unvarify_proof = map_proof_terms unvarify unvarifyT;
 
 fun hidden_types prop proof =
   let
     val visible = (fold_types o fold_atyps) (insert (op =)) prop [];
     val add_hiddenT = fold_atyps (fn T => not (member (op =) visible T) ? insert (op =) T);
   in rev (fold_proof_terms_types (fold_types add_hiddenT) add_hiddenT proof []) end;
 
 fun standard_hidden_types term proof =
   let
     val hidden = hidden_types term proof;
     val idx = Term.maxidx_term term (maxidx_proof proof ~1) + 1;
     fun smash T =
       if member (op =) hidden T then
         (case Type.sort_of_atyp T of
           [] => dummyT
         | S => TVar (("'", idx), S))
       else T;
     val smashT = map_atyps smash;
   in map_proof_terms (map_types smashT) smashT proof end;
 
 fun standard_hidden_terms term proof =
   let
     fun add_unless excluded x =
       ((is_Free x orelse is_Var x) andalso not (member (op =) excluded x)) ? insert (op =) x;
     val visible = fold_aterms (add_unless []) term [];
     val hidden = fold_proof_terms (fold_aterms (add_unless visible)) proof [];
     val dummy_term = Term.map_aterms (fn x =>
       if member (op =) hidden x then Term.dummy_pattern (Term.fastype_of x) else x);
   in proof |> not (null hidden) ? map_proof_terms dummy_term I end;
 
 in
 
 fun standard_vars used (term, opt_proof) =
   let
     val proofs = opt_proof
       |> Option.map (standard_hidden_types term #> standard_hidden_terms term) |> the_list;
     val proof_terms = rev (fold (fold_proof_terms_types cons (cons o Logic.mk_type)) proofs []);
     val used_frees = used
       |> used_frees_term term
       |> fold used_frees_proof proofs;
     val inst = Term_Subst.zero_var_indexes_inst used_frees (term :: proof_terms);
     val term' = term |> Term_Subst.instantiate inst |> unvarify |> variant_term [];
     val proofs' = proofs |> map (instantiate inst #> unvarify_proof #> variant_proof []);
   in (term', try hd proofs') end;
 
 fun standard_vars_term used t = #1 (standard_vars used (t, NONE));
 
 val add_standard_vars_term = fold_aterms
   (fn Free (x, T) =>
     (fn env =>
       (case AList.lookup (op =) env x of
         NONE => (x, T) :: env
       | SOME T' =>
           if T = T' then env
           else raise TYPE ("standard_vars_env: type conflict for variable " ^ quote x, [T, T'], [])))
     | _ => I);
 
 val add_standard_vars = fold_proof_terms add_standard_vars_term;
 
 end;
 
 
 (* PThm nodes *)
 
 fun prune_body body =
   if Options.default_bool "prune_proofs"
   then (Future.map o map_proof_of) (K MinProof) body
   else body;
 
 fun export_enabled () = Options.default_bool "export_proofs";
 fun export_standard_enabled () = Options.default_bool "export_standard_proofs";
 
 fun export_proof_boxes_required thy =
   Context.theory_name thy = Context.PureN orelse
     (export_enabled () andalso not (export_standard_enabled ()));
 
 fun export_proof_boxes bodies =
   let
     fun export_thm (i, thm_node) boxes =
       if Inttab.defined boxes i then boxes
       else
         boxes
         |> Inttab.update (i, thm_node_export thm_node)
         |> fold export_thm (thm_node_thms thm_node);
 
     fun export_body (PBody {thms, ...}) = fold export_thm thms;
 
-    val exports = (bodies, Inttab.empty) |-> fold export_body |> Inttab.dest;
+    val exports = Inttab.build (fold export_body bodies) |> Inttab.dest;
   in List.app (Lazy.force o #2) exports end;
 
 local
 
 fun unconstrainT_proof algebra classrel_proof arity_proof (ucontext: Logic.unconstrain_context) =
   let
     fun hyp_map hyp =
       (case AList.lookup (op =) (#constraints ucontext) hyp of
         SOME t => Hyp t
       | NONE => raise Fail "unconstrainT_proof: missing constraint");
 
     val typ = Term_Subst.map_atypsT_same (Type.strip_sorts o #atyp_map ucontext);
     fun ofclass (ty, c) =
       let val ty' = Term.map_atyps (#atyp_map ucontext) ty;
       in the_single (of_sort_proof algebra classrel_proof arity_proof hyp_map (ty', [c])) end;
   in
     Same.commit (map_proof_same (Term_Subst.map_types_same typ) typ ofclass)
     #> fold_rev (implies_intr_proof o snd) (#constraints ucontext)
   end;
 
 fun export_proof thy i prop prf0 =
   let
     val prf = prf0
       |> reconstruct_proof thy prop
       |> apply_preproc thy;
     val (prop', SOME prf') = (prop, SOME prf) |> standard_vars Name.context;
     val args = [] |> add_standard_vars_term prop' |> add_standard_vars prf' |> rev;
     val typargs = [] |> Term.add_tfrees prop' |> fold_proof_terms Term.add_tfrees prf' |> rev;
 
     val consts = Sign.consts_of thy;
     val xml = (typargs, (args, (prop', no_thm_names prf'))) |>
       let
         open XML.Encode Term_XML.Encode;
         val encode_vars = list (pair string typ);
         val encode_term = encode_standard_term consts;
         val encode_proof = encode_standard_proof consts;
       in pair (list (pair string sort)) (pair encode_vars (pair encode_term encode_proof)) end;
   in
     Export.export_params
      {theory = thy,
       binding = Path.binding0 (Path.make ["proofs", string_of_int i]),
       executable = false,
       compress = true,
       strict = false} xml
   end;
 
 fun prepare_thm_proof unconstrain thy classrel_proof arity_proof
     (name, pos) shyps hyps concl promises body =
   let
     val named = name <> "";
 
     val prop = Logic.list_implies (hyps, concl);
     val args = prop_args prop;
 
     val (ucontext, prop1) = Logic.unconstrainT shyps prop;
 
     val PBody {oracles = oracles0, thms = thms0, proof = prf} = body;
     val body0 =
       Future.value
         (PBody {oracles = oracles0, thms = thms0,
           proof = if proofs_enabled () then fold_rev implies_intr_proof hyps prf else MinProof});
 
     fun new_prf () =
       let
         val i = serial ();
         val unconstrainT =
           unconstrainT_proof (Sign.classes_of thy) classrel_proof arity_proof ucontext;
         val postproc = map_proof_of (unconstrainT #> named ? rew_proof thy);
       in (i, fulfill_proof_future thy promises postproc body0) end;
 
     val (i, body') =
       (*somewhat non-deterministic proof boxes!*)
       if export_enabled () then new_prf ()
       else
         (case strip_combt (fst (strip_combP prf)) of
           (PThm ({serial = ser, name = a, prop = prop', types = NONE, ...}, thm_body'), args') =>
             if (a = "" orelse a = name) andalso prop' = prop1 andalso args' = args then
               let
                 val Thm_Body {body = body', ...} = thm_body';
                 val i = if a = "" andalso named then serial () else ser;
               in (i, body' |> ser <> i ? Future.map (map_proof_of (rew_proof thy))) end
             else new_prf ()
         | _ => new_prf ());
 
     val open_proof = not named ? rew_proof thy;
 
     val export =
       if export_enabled () then
         Lazy.lazy (fn () =>
           join_proof body' |> open_proof |> export_proof thy i prop1 handle exn =>
             if Exn.is_interrupt exn then
               raise Fail ("Interrupt: potential resource problems while exporting proof " ^
                 string_of_int i)
             else Exn.reraise exn)
       else no_export;
 
     val thm_body = prune_body body';
     val theory_name = Context.theory_long_name thy;
     val thm = (i, make_thm_node theory_name name prop1 thm_body export);
 
     val header = thm_header i ([pos, Position.thread_data ()]) theory_name name prop1 NONE;
     val head = PThm (header, Thm_Body {open_proof = open_proof, body = thm_body});
     val proof =
       if unconstrain then
         proof_combt' (head, (map o Option.map o Term.map_types) (#map_atyps ucontext) args)
       else
         proof_combP (proof_combt' (head, args),
           map PClass (#outer_constraints ucontext) @ map Hyp hyps);
   in (thm, proof) end;
 
 in
 
 fun thm_proof thy = prepare_thm_proof false thy;
 
 fun unconstrain_thm_proof thy classrel_proof arity_proof shyps concl promises body =
   prepare_thm_proof true thy classrel_proof arity_proof ("", Position.none)
     shyps [] concl promises body;
 
 end;
 
 
 (* PThm identity *)
 
 fun get_identity shyps hyps prop prf =
   let val (_, prop) = Logic.unconstrainT shyps (Logic.list_implies (hyps, prop)) in
     (case fst (strip_combt (fst (strip_combP prf))) of
       PThm ({serial, theory_name, name, prop = prop', ...}, _) =>
         if prop = prop'
         then SOME {serial = serial, theory_name = theory_name, name = name} else NONE
     | _ => NONE)
   end;
 
 fun get_approximative_name shyps hyps prop prf =
   Option.map #name (get_identity shyps hyps prop prf) |> the_default "";
 
 
 (* thm_id *)
 
 type thm_id = {serial: serial, theory_name: string};
 
 fun make_thm_id (serial, theory_name) : thm_id =
   {serial = serial, theory_name = theory_name};
 
 fun thm_header_id ({serial, theory_name, ...}: thm_header) =
   make_thm_id (serial, theory_name);
 
 fun thm_id (serial, thm_node) : thm_id =
   make_thm_id (serial, thm_node_theory_name thm_node);
 
 fun get_id shyps hyps prop prf : thm_id option =
   (case get_identity shyps hyps prop prf of
     NONE => NONE
   | SOME {name = "", ...} => NONE
   | SOME {serial, theory_name, ...} => SOME (make_thm_id (serial, theory_name)));
 
 fun this_id NONE _ = false
   | this_id (SOME (thm_id: thm_id)) (thm_id': thm_id) = #serial thm_id = #serial thm_id';
 
 
 (* proof boxes: intermediate PThm nodes *)
 
 fun proof_boxes {included, excluded} proofs =
   let
     fun boxes_of (Abst (_, _, prf)) = boxes_of prf
       | boxes_of (AbsP (_, _, prf)) = boxes_of prf
       | boxes_of (prf % _) = boxes_of prf
       | boxes_of (prf1 %% prf2) = boxes_of prf1 #> boxes_of prf2
       | boxes_of (PThm (header as {serial = i, ...}, thm_body)) =
           (fn boxes =>
             let val thm_id = thm_header_id header in
               if Inttab.defined boxes i orelse (excluded thm_id andalso not (included thm_id))
               then boxes
               else
                 let
                   val prf' = thm_body_proof_open thm_body;
                   val boxes' = Inttab.update (i, (header, prf')) boxes;
                 in boxes_of prf' boxes' end
             end)
       | boxes_of MinProof = raise MIN_PROOF ()
       | boxes_of _ = I;
-  in Inttab.fold_rev (cons o #2) (fold boxes_of proofs Inttab.empty) [] end;
+  in Inttab.fold_rev (cons o #2) (Inttab.build (fold boxes_of proofs)) [] end;
 
 end;
 
 structure Basic_Proofterm =
 struct
   datatype proof = datatype Proofterm.proof
   datatype proof_body = datatype Proofterm.proof_body
   val op %> = Proofterm.%>
 end;
 
 open Basic_Proofterm;
diff --git a/src/Pure/raw_simplifier.ML b/src/Pure/raw_simplifier.ML
--- a/src/Pure/raw_simplifier.ML
+++ b/src/Pure/raw_simplifier.ML
@@ -1,1463 +1,1463 @@
 (*  Title:      Pure/raw_simplifier.ML
     Author:     Tobias Nipkow and Stefan Berghofer, TU Muenchen
 
 Higher-order Simplification.
 *)
 
 infix 4
   addsimps delsimps addsimprocs delsimprocs
   setloop addloop delloop
   setSSolver addSSolver setSolver addSolver;
 
 signature BASIC_RAW_SIMPLIFIER =
 sig
   val simp_depth_limit: int Config.T
   val simp_trace_depth_limit: int Config.T
   val simp_debug: bool Config.T
   val simp_trace: bool Config.T
   type cong_name = bool * string
   type rrule
   val mk_rrules: Proof.context -> thm list -> rrule list
   val eq_rrule: rrule * rrule -> bool
   type proc
   type solver
   val mk_solver: string -> (Proof.context -> int -> tactic) -> solver
   type simpset
   val empty_ss: simpset
   val merge_ss: simpset * simpset -> simpset
   val dest_ss: simpset ->
    {simps: (string * thm) list,
     procs: (string * term list) list,
     congs: (cong_name * thm) list,
     weak_congs: cong_name list,
     loopers: string list,
     unsafe_solvers: string list,
     safe_solvers: string list}
   type simproc
   val eq_simproc: simproc * simproc -> bool
   val cert_simproc: theory -> string ->
     {lhss: term list, proc: morphism -> Proof.context -> cterm -> thm option} -> simproc
   val transform_simproc: morphism -> simproc -> simproc
   val simpset_of: Proof.context -> simpset
   val put_simpset: simpset -> Proof.context -> Proof.context
   val simpset_map: Proof.context -> (Proof.context -> Proof.context) -> simpset -> simpset
   val map_theory_simpset: (Proof.context -> Proof.context) -> theory -> theory
   val empty_simpset: Proof.context -> Proof.context
   val clear_simpset: Proof.context -> Proof.context
   val addsimps: Proof.context * thm list -> Proof.context
   val delsimps: Proof.context * thm list -> Proof.context
   val addsimprocs: Proof.context * simproc list -> Proof.context
   val delsimprocs: Proof.context * simproc list -> Proof.context
   val setloop: Proof.context * (Proof.context -> int -> tactic) -> Proof.context
   val addloop: Proof.context * (string * (Proof.context -> int -> tactic)) -> Proof.context
   val delloop: Proof.context * string -> Proof.context
   val setSSolver: Proof.context * solver -> Proof.context
   val addSSolver: Proof.context * solver -> Proof.context
   val setSolver: Proof.context * solver -> Proof.context
   val addSolver: Proof.context * solver -> Proof.context
 
   val rewrite_rule: Proof.context -> thm list -> thm -> thm
   val rewrite_goals_rule: Proof.context -> thm list -> thm -> thm
   val rewrite_goals_tac: Proof.context -> thm list -> tactic
   val rewrite_goal_tac: Proof.context -> thm list -> int -> tactic
   val prune_params_tac: Proof.context -> tactic
   val fold_rule: Proof.context -> thm list -> thm -> thm
   val fold_goals_tac: Proof.context -> thm list -> tactic
   val norm_hhf: Proof.context -> thm -> thm
   val norm_hhf_protect: Proof.context -> thm -> thm
 end;
 
 signature RAW_SIMPLIFIER =
 sig
   include BASIC_RAW_SIMPLIFIER
   exception SIMPLIFIER of string * thm list
   type trace_ops
   val set_trace_ops: trace_ops -> theory -> theory
   val subgoal_tac: Proof.context -> int -> tactic
   val loop_tac: Proof.context -> int -> tactic
   val solvers: Proof.context -> solver list * solver list
   val map_ss: (Proof.context -> Proof.context) -> Context.generic -> Context.generic
   val prems_of: Proof.context -> thm list
   val add_simp: thm -> Proof.context -> Proof.context
   val del_simp: thm -> Proof.context -> Proof.context
   val flip_simp: thm -> Proof.context -> Proof.context
   val init_simpset: thm list -> Proof.context -> Proof.context
   val add_eqcong: thm -> Proof.context -> Proof.context
   val del_eqcong: thm -> Proof.context -> Proof.context
   val add_cong: thm -> Proof.context -> Proof.context
   val del_cong: thm -> Proof.context -> Proof.context
   val mksimps: Proof.context -> thm -> thm list
   val set_mksimps: (Proof.context -> thm -> thm list) -> Proof.context -> Proof.context
   val set_mkcong: (Proof.context -> thm -> thm) -> Proof.context -> Proof.context
   val set_mksym: (Proof.context -> thm -> thm option) -> Proof.context -> Proof.context
   val set_mkeqTrue: (Proof.context -> thm -> thm option) -> Proof.context -> Proof.context
   val set_term_ord: term ord -> Proof.context -> Proof.context
   val set_subgoaler: (Proof.context -> int -> tactic) -> Proof.context -> Proof.context
   val solver: Proof.context -> solver -> int -> tactic
   val default_mk_sym: Proof.context -> thm -> thm option
   val add_prems: thm list -> Proof.context -> Proof.context
   val set_reorient: (Proof.context -> term list -> term -> term -> bool) ->
     Proof.context -> Proof.context
   val set_solvers: solver list -> Proof.context -> Proof.context
   val rewrite_cterm: bool * bool * bool ->
     (Proof.context -> thm -> thm option) -> Proof.context -> conv
   val rewrite_term: theory -> thm list -> (term -> term option) list -> term -> term
   val rewrite_thm: bool * bool * bool ->
     (Proof.context -> thm -> thm option) -> Proof.context -> thm -> thm
   val generic_rewrite_goal_tac: bool * bool * bool ->
     (Proof.context -> tactic) -> Proof.context -> int -> tactic
   val rewrite: Proof.context -> bool -> thm list -> conv
 end;
 
 structure Raw_Simplifier: RAW_SIMPLIFIER =
 struct
 
 (** datatype simpset **)
 
 (* congruence rules *)
 
 type cong_name = bool * string;
 
 fun cong_name (Const (a, _)) = SOME (true, a)
   | cong_name (Free (a, _)) = SOME (false, a)
   | cong_name _ = NONE;
 
 structure Congtab = Table(type key = cong_name val ord = prod_ord bool_ord fast_string_ord);
 
 
 (* rewrite rules *)
 
 type rrule =
  {thm: thm,         (*the rewrite rule*)
   name: string,     (*name of theorem from which rewrite rule was extracted*)
   lhs: term,        (*the left-hand side*)
   elhs: cterm,      (*the eta-contracted lhs*)
   extra: bool,      (*extra variables outside of elhs*)
   fo: bool,         (*use first-order matching*)
   perm: bool};      (*the rewrite rule is permutative*)
 
 fun trim_context_rrule ({thm, name, lhs, elhs, extra, fo, perm}: rrule) =
   {thm = Thm.trim_context thm, name = name, lhs = lhs, elhs = Thm.trim_context_cterm elhs,
     extra = extra, fo = fo, perm = perm};
 
 (*
 Remarks:
   - elhs is used for matching,
     lhs only for preservation of bound variable names;
   - fo is set iff
     either elhs is first-order (no Var is applied),
       in which case fo-matching is complete,
     or elhs is not a pattern,
       in which case there is nothing better to do;
 *)
 
 fun eq_rrule ({thm = thm1, ...}: rrule, {thm = thm2, ...}: rrule) =
   Thm.eq_thm_prop (thm1, thm2);
 
 (* FIXME: it seems that the conditions on extra variables are too liberal if
 prems are nonempty: does solving the prems really guarantee instantiation of
 all its Vars? Better: a dynamic check each time a rule is applied.
 *)
 fun rewrite_rule_extra_vars prems elhs erhs =
   let
     val elhss = elhs :: prems;
-    val tvars = fold Term_Subst.add_tvars elhss Term_Subst.TVars.empty;
-    val vars = fold Term_Subst.add_vars elhss Term_Subst.Vars.empty;
+    val tvars = Term_Subst.TVars.build (fold Term_Subst.add_tvars elhss);
+    val vars = Term_Subst.Vars.build (fold Term_Subst.add_vars elhss);
   in
     erhs |> Term.exists_type (Term.exists_subtype
       (fn TVar v => not (Term_Subst.TVars.defined tvars v) | _ => false)) orelse
     erhs |> Term.exists_subterm
       (fn Var v => not (Term_Subst.Vars.defined vars v) | _ => false)
   end;
 
 fun rrule_extra_vars elhs thm =
   rewrite_rule_extra_vars [] (Thm.term_of elhs) (Thm.full_prop_of thm);
 
 fun mk_rrule2 {thm, name, lhs, elhs, perm} =
   let
     val t = Thm.term_of elhs;
     val fo = Pattern.first_order t orelse not (Pattern.pattern t);
     val extra = rrule_extra_vars elhs thm;
   in {thm = thm, name = name, lhs = lhs, elhs = elhs, extra = extra, fo = fo, perm = perm} end;
 
 (*simple test for looping rewrite rules and stupid orientations*)
 fun default_reorient ctxt prems lhs rhs =
   rewrite_rule_extra_vars prems lhs rhs
     orelse
   is_Var (head_of lhs)
     orelse
 (* turns t = x around, which causes a headache if x is a local variable -
    usually it is very useful :-(
   is_Free rhs andalso not(is_Free lhs) andalso not(Logic.occs(rhs,lhs))
   andalso not(exists_subterm is_Var lhs)
     orelse
 *)
   exists (fn t => Logic.occs (lhs, t)) (rhs :: prems)
     orelse
   null prems andalso Pattern.matches (Proof_Context.theory_of ctxt) (lhs, rhs)
     (*the condition "null prems" is necessary because conditional rewrites
       with extra variables in the conditions may terminate although
       the rhs is an instance of the lhs; example: ?m < ?n \<Longrightarrow> f ?n \<equiv> f ?m *)
     orelse
   is_Const lhs andalso not (is_Const rhs);
 
 
 (* simplification procedures *)
 
 datatype proc =
   Proc of
    {name: string,
     lhs: term,
     proc: Proof.context -> cterm -> thm option,
     stamp: stamp};
 
 fun eq_proc (Proc {stamp = stamp1, ...}, Proc {stamp = stamp2, ...}) = stamp1 = stamp2;
 
 
 (* solvers *)
 
 datatype solver =
   Solver of
    {name: string,
     solver: Proof.context -> int -> tactic,
     id: stamp};
 
 fun mk_solver name solver = Solver {name = name, solver = solver, id = stamp ()};
 
 fun solver_name (Solver {name, ...}) = name;
 fun solver ctxt (Solver {solver = tac, ...}) = tac ctxt;
 fun eq_solver (Solver {id = id1, ...}, Solver {id = id2, ...}) = (id1 = id2);
 
 
 (* simplification sets *)
 
 (*A simpset contains data required during conversion:
     rules: discrimination net of rewrite rules;
     prems: current premises;
     depth: simp_depth and exceeded flag;
     congs: association list of congruence rules and
            a list of `weak' congruence constants.
            A congruence is `weak' if it avoids normalization of some argument.
     procs: discrimination net of simplification procedures
       (functions that prove rewrite rules on the fly);
     mk_rews:
       mk: turn simplification thms into rewrite rules;
       mk_cong: prepare congruence rules;
       mk_sym: turn \<equiv> around;
       mk_eq_True: turn P into P \<equiv> True;
     term_ord: for ordered rewriting;*)
 
 datatype simpset =
   Simpset of
    {rules: rrule Net.net,
     prems: thm list,
     depth: int * bool Unsynchronized.ref} *
    {congs: thm Congtab.table * cong_name list,
     procs: proc Net.net,
     mk_rews:
      {mk: Proof.context -> thm -> thm list,
       mk_cong: Proof.context -> thm -> thm,
       mk_sym: Proof.context -> thm -> thm option,
       mk_eq_True: Proof.context -> thm -> thm option,
       reorient: Proof.context -> term list -> term -> term -> bool},
     term_ord: term ord,
     subgoal_tac: Proof.context -> int -> tactic,
     loop_tacs: (string * (Proof.context -> int -> tactic)) list,
     solvers: solver list * solver list};
 
 fun internal_ss (Simpset (_, ss2)) = ss2;
 
 fun make_ss1 (rules, prems, depth) = {rules = rules, prems = prems, depth = depth};
 
 fun map_ss1 f {rules, prems, depth} = make_ss1 (f (rules, prems, depth));
 
 fun make_ss2 (congs, procs, mk_rews, term_ord, subgoal_tac, loop_tacs, solvers) =
   {congs = congs, procs = procs, mk_rews = mk_rews, term_ord = term_ord,
     subgoal_tac = subgoal_tac, loop_tacs = loop_tacs, solvers = solvers};
 
 fun map_ss2 f {congs, procs, mk_rews, term_ord, subgoal_tac, loop_tacs, solvers} =
   make_ss2 (f (congs, procs, mk_rews, term_ord, subgoal_tac, loop_tacs, solvers));
 
 fun make_simpset (args1, args2) = Simpset (make_ss1 args1, make_ss2 args2);
 
 fun dest_ss (Simpset ({rules, ...}, {congs, procs, loop_tacs, solvers, ...})) =
  {simps = Net.entries rules
     |> map (fn {name, thm, ...} => (name, thm)),
   procs = Net.entries procs
     |> map (fn Proc {name, lhs, stamp, ...} => ((name, lhs), stamp))
     |> partition_eq (eq_snd op =)
     |> map (fn ps => (fst (fst (hd ps)), map (snd o fst) ps)),
   congs = congs |> fst |> Congtab.dest,
   weak_congs = congs |> snd,
   loopers = map fst loop_tacs,
   unsafe_solvers = map solver_name (#1 solvers),
   safe_solvers = map solver_name (#2 solvers)};
 
 
 (* empty *)
 
 fun init_ss depth mk_rews term_ord subgoal_tac solvers =
   make_simpset ((Net.empty, [], depth),
     ((Congtab.empty, []), Net.empty, mk_rews, term_ord, subgoal_tac, [], solvers));
 
 fun default_mk_sym _ th = SOME (th RS Drule.symmetric_thm);
 
 val empty_ss =
   init_ss (0, Unsynchronized.ref false)
     {mk = fn _ => fn th => if can Logic.dest_equals (Thm.concl_of th) then [th] else [],
       mk_cong = K I,
       mk_sym = default_mk_sym,
       mk_eq_True = K (K NONE),
       reorient = default_reorient}
     Term_Ord.term_ord (K (K no_tac)) ([], []);
 
 
 (* merge *)  (*NOTE: ignores some fields of 2nd simpset*)
 
 fun merge_ss (ss1, ss2) =
   if pointer_eq (ss1, ss2) then ss1
   else
     let
       val Simpset ({rules = rules1, prems = prems1, depth = depth1},
        {congs = (congs1, weak1), procs = procs1, mk_rews, term_ord, subgoal_tac,
         loop_tacs = loop_tacs1, solvers = (unsafe_solvers1, solvers1)}) = ss1;
       val Simpset ({rules = rules2, prems = prems2, depth = depth2},
        {congs = (congs2, weak2), procs = procs2, mk_rews = _, term_ord = _, subgoal_tac = _,
         loop_tacs = loop_tacs2, solvers = (unsafe_solvers2, solvers2)}) = ss2;
 
       val rules' = Net.merge eq_rrule (rules1, rules2);
       val prems' = Thm.merge_thms (prems1, prems2);
       val depth' = if #1 depth1 < #1 depth2 then depth2 else depth1;
       val congs' = Congtab.merge (K true) (congs1, congs2);
       val weak' = merge (op =) (weak1, weak2);
       val procs' = Net.merge eq_proc (procs1, procs2);
       val loop_tacs' = AList.merge (op =) (K true) (loop_tacs1, loop_tacs2);
       val unsafe_solvers' = merge eq_solver (unsafe_solvers1, unsafe_solvers2);
       val solvers' = merge eq_solver (solvers1, solvers2);
     in
       make_simpset ((rules', prems', depth'), ((congs', weak'), procs',
         mk_rews, term_ord, subgoal_tac, loop_tacs', (unsafe_solvers', solvers')))
     end;
 
 
 
 (** context data **)
 
 structure Simpset = Generic_Data
 (
   type T = simpset;
   val empty = empty_ss;
   val extend = I;
   val merge = merge_ss;
 );
 
 val simpset_of = Simpset.get o Context.Proof;
 
 fun map_simpset f = Context.proof_map (Simpset.map f);
 fun map_simpset1 f = map_simpset (fn Simpset (ss1, ss2) => Simpset (map_ss1 f ss1, ss2));
 fun map_simpset2 f = map_simpset (fn Simpset (ss1, ss2) => Simpset (ss1, map_ss2 f ss2));
 
 fun put_simpset ss = map_simpset (K ss);
 
 fun simpset_map ctxt f ss = ctxt |> put_simpset ss |> f |> simpset_of;
 
 val empty_simpset = put_simpset empty_ss;
 
 fun map_theory_simpset f thy =
   let
     val ctxt' = f (Proof_Context.init_global thy);
     val thy' = Proof_Context.theory_of ctxt';
   in Context.theory_map (Simpset.map (K (simpset_of ctxt'))) thy' end;
 
 fun map_ss f = Context.mapping (map_theory_simpset (f o Context_Position.not_really)) f;
 
 val clear_simpset =
   map_simpset (fn Simpset ({depth, ...}, {mk_rews, term_ord, subgoal_tac, solvers, ...}) =>
     init_ss depth mk_rews term_ord subgoal_tac solvers);
 
 
 (* accessors for tactis *)
 
 fun subgoal_tac ctxt = (#subgoal_tac o internal_ss o simpset_of) ctxt ctxt;
 
 fun loop_tac ctxt =
   FIRST' (map (fn (_, tac) => tac ctxt) (rev ((#loop_tacs o internal_ss o simpset_of) ctxt)));
 
 val solvers = #solvers o internal_ss o simpset_of
 
 
 (* simp depth *)
 
 (*
 The simp_depth_limit is meant to abort infinite recursion of the simplifier
 early but should not terminate "normal" executions.
 As of 2017, 25 would suffice; 40 builds in a safety margin.
 *)
 
 val simp_depth_limit = Config.declare_int ("simp_depth_limit", \<^here>) (K 40);
 val simp_trace_depth_limit = Config.declare_int ("simp_trace_depth_limit", \<^here>) (K 1);
 
 fun inc_simp_depth ctxt =
   ctxt |> map_simpset1 (fn (rules, prems, (depth, exceeded)) =>
     (rules, prems,
       (depth + 1,
         if depth = Config.get ctxt simp_trace_depth_limit
         then Unsynchronized.ref false else exceeded)));
 
 fun simp_depth ctxt =
   let val Simpset ({depth = (depth, _), ...}, _) = simpset_of ctxt
   in depth end;
 
 
 (* diagnostics *)
 
 exception SIMPLIFIER of string * thm list;
 
 val simp_debug = Config.declare_bool ("simp_debug", \<^here>) (K false);
 val simp_trace = Config.declare_bool ("simp_trace", \<^here>) (K false);
 
 fun cond_warning ctxt msg =
   if Context_Position.is_really_visible ctxt then warning (msg ()) else ();
 
 fun cond_tracing' ctxt flag msg =
   if Config.get ctxt flag then
     let
       val Simpset ({depth = (depth, exceeded), ...}, _) = simpset_of ctxt;
       val depth_limit = Config.get ctxt simp_trace_depth_limit;
     in
       if depth > depth_limit then
         if ! exceeded then () else (tracing "simp_trace_depth_limit exceeded!"; exceeded := true)
       else (tracing (enclose "[" "]" (string_of_int depth) ^ msg ()); exceeded := false)
     end
   else ();
 
 fun cond_tracing ctxt = cond_tracing' ctxt simp_trace;
 
 fun print_term ctxt s t =
   s ^ "\n" ^ Syntax.string_of_term ctxt t;
 
 fun print_thm ctxt s (name, th) =
   print_term ctxt (if name = "" then s else s ^ " " ^ quote name ^ ":") (Thm.full_prop_of th);
 
 
 
 (** simpset operations **)
 
 (* prems *)
 
 fun prems_of ctxt =
   let val Simpset ({prems, ...}, _) = simpset_of ctxt in prems end;
 
 fun add_prems ths =
   map_simpset1 (fn (rules, prems, depth) => (rules, ths @ prems, depth));
 
 
 (* maintain simp rules *)
 
 fun del_rrule loud (rrule as {thm, elhs, ...}) ctxt =
   ctxt |> map_simpset1 (fn (rules, prems, depth) =>
     (Net.delete_term eq_rrule (Thm.term_of elhs, rrule) rules, prems, depth))
   handle Net.DELETE =>
     (if not loud then ()
      else cond_warning ctxt
             (fn () => print_thm ctxt "Rewrite rule not in simpset:" ("", thm));
      ctxt);
 
 fun insert_rrule (rrule as {thm, name, ...}) ctxt =
  (cond_tracing ctxt (fn () => print_thm ctxt "Adding rewrite rule" (name, thm));
   ctxt |> map_simpset1 (fn (rules, prems, depth) =>
     let
       val rrule2 as {elhs, ...} = mk_rrule2 rrule;
       val rules' = Net.insert_term eq_rrule (Thm.term_of elhs, trim_context_rrule rrule2) rules;
     in (rules', prems, depth) end)
   handle Net.INSERT =>
     (cond_warning ctxt (fn () => print_thm ctxt "Ignoring duplicate rewrite rule:" ("", thm));
       ctxt));
 
-fun vars_set t = Term_Subst.add_vars t Term_Subst.Vars.empty;
+val vars_set = Term_Subst.Vars.build o Term_Subst.add_vars;
 
 local
 
 fun vperm (Var _, Var _) = true
   | vperm (Abs (_, _, s), Abs (_, _, t)) = vperm (s, t)
   | vperm (t1 $ t2, u1 $ u2) = vperm (t1, u1) andalso vperm (t2, u2)
   | vperm (t, u) = (t = u);
 
 fun var_perm (t, u) = vperm (t, u) andalso Term_Subst.Vars.eq_set (apply2 vars_set (t, u));
 
 in
 
 fun decomp_simp thm =
   let
     val prop = Thm.prop_of thm;
     val prems = Logic.strip_imp_prems prop;
     val concl = Drule.strip_imp_concl (Thm.cprop_of thm);
     val (lhs, rhs) = Thm.dest_equals concl handle TERM _ =>
       raise SIMPLIFIER ("Rewrite rule not a meta-equality", [thm]);
     val elhs = Thm.dest_arg (Thm.cprop_of (Thm.eta_conversion lhs));
     val erhs = Envir.eta_contract (Thm.term_of rhs);
     val perm =
       var_perm (Thm.term_of elhs, erhs) andalso
       not (Thm.term_of elhs aconv erhs) andalso
       not (is_Var (Thm.term_of elhs));
   in (prems, Thm.term_of lhs, elhs, Thm.term_of rhs, perm) end;
 
 end;
 
 fun decomp_simp' thm =
   let val (_, lhs, _, rhs, _) = decomp_simp thm in
     if Thm.nprems_of thm > 0 then raise SIMPLIFIER ("Bad conditional rewrite rule", [thm])
     else (lhs, rhs)
   end;
 
 fun mk_eq_True ctxt (thm, name) =
   let val Simpset (_, {mk_rews = {mk_eq_True, ...}, ...}) = simpset_of ctxt in
     (case mk_eq_True ctxt thm of
       NONE => []
     | SOME eq_True =>
         let val (_, lhs, elhs, _, _) = decomp_simp eq_True;
         in [{thm = eq_True, name = name, lhs = lhs, elhs = elhs, perm = false}] end)
   end;
 
 (*create the rewrite rule and possibly also the eq_True variant,
   in case there are extra vars on the rhs*)
 fun rrule_eq_True ctxt thm name lhs elhs rhs thm2 =
   let val rrule = {thm = thm, name = name, lhs = lhs, elhs = elhs, perm = false} in
     if rewrite_rule_extra_vars [] lhs rhs then
       mk_eq_True ctxt (thm2, name) @ [rrule]
     else [rrule]
   end;
 
 fun mk_rrule ctxt (thm, name) =
   let val (prems, lhs, elhs, rhs, perm) = decomp_simp thm in
     if perm then [{thm = thm, name = name, lhs = lhs, elhs = elhs, perm = true}]
     else
       (*weak test for loops*)
       if rewrite_rule_extra_vars prems lhs rhs orelse is_Var (Thm.term_of elhs)
       then mk_eq_True ctxt (thm, name)
       else rrule_eq_True ctxt thm name lhs elhs rhs thm
   end |> map (fn {thm, name, lhs, elhs, perm} =>
     {thm = Thm.trim_context thm, name = name, lhs = lhs,
       elhs = Thm.trim_context_cterm elhs, perm = perm});
 
 fun orient_rrule ctxt (thm, name) =
   let
     val (prems, lhs, elhs, rhs, perm) = decomp_simp thm;
     val Simpset (_, {mk_rews = {reorient, mk_sym, ...}, ...}) = simpset_of ctxt;
   in
     if perm then [{thm = thm, name = name, lhs = lhs, elhs = elhs, perm = true}]
     else if reorient ctxt prems lhs rhs then
       if reorient ctxt prems rhs lhs
       then mk_eq_True ctxt (thm, name)
       else
         (case mk_sym ctxt thm of
           NONE => []
         | SOME thm' =>
             let val (_, lhs', elhs', rhs', _) = decomp_simp thm'
             in rrule_eq_True ctxt thm' name lhs' elhs' rhs' thm end)
     else rrule_eq_True ctxt thm name lhs elhs rhs thm
   end;
 
 fun extract_rews ctxt sym thms =
   let
     val Simpset (_, {mk_rews = {mk, ...}, ...}) = simpset_of ctxt;
     val mk =
       if sym then fn ctxt => fn th => (mk ctxt th) RL [Drule.symmetric_thm]
       else mk
   in maps (fn thm => map (rpair (Thm.get_name_hint thm)) (mk ctxt thm)) thms
   end;
 
 fun extract_safe_rrules ctxt thm =
   maps (orient_rrule ctxt) (extract_rews ctxt false [thm]);
 
 fun mk_rrules ctxt thms =
   let
     val rews = extract_rews ctxt false thms
     val raw_rrules = flat (map (mk_rrule ctxt) rews)
   in map mk_rrule2 raw_rrules end
 
 
 (* add/del rules explicitly *)
 
 local
 
 fun comb_simps ctxt comb mk_rrule sym thms =
   let val rews = extract_rews ctxt sym (map (Thm.transfer' ctxt) thms);
   in fold (fold comb o mk_rrule) rews ctxt end;
 
 (*
 This code checks if the symetric version of a rule is already in the simpset.
 However, the variable names in the two versions of the rule may differ.
 Thus the current test modulo eq_rrule is too weak to be useful
 and needs to be refined.
 
 fun present ctxt rules (rrule as {thm, elhs, ...}) =
   (Net.insert_term eq_rrule (Thm.term_of elhs, trim_context_rrule rrule) rules;
    false)
   handle Net.INSERT =>
     (cond_warning ctxt
        (fn () => print_thm ctxt "Symmetric rewrite rule already in simpset:" ("", thm));
      true);
 
 fun sym_present ctxt thms =
   let
     val rews = extract_rews ctxt true (map (Thm.transfer' ctxt) thms);
     val rrules = map mk_rrule2 (flat(map (mk_rrule ctxt) rews))
     val Simpset({rules, ...},_) = simpset_of ctxt
   in exists (present ctxt rules) rrules end
 *)
 in
 
 fun ctxt addsimps thms =
   comb_simps ctxt insert_rrule (mk_rrule ctxt) false thms;
 
 fun addsymsimps ctxt thms =
   comb_simps ctxt insert_rrule (mk_rrule ctxt) true thms;
 
 fun ctxt delsimps thms =
   comb_simps ctxt (del_rrule true) (map mk_rrule2 o mk_rrule ctxt) false thms;
 
 fun delsimps_quiet ctxt thms =
   comb_simps ctxt (del_rrule false) (map mk_rrule2 o mk_rrule ctxt) false thms;
 
 fun add_simp thm ctxt = ctxt addsimps [thm];
 (*
 with check for presence of symmetric version:
   if sym_present ctxt [thm]
   then (cond_warning ctxt (fn () => print_thm ctxt "Ignoring rewrite rule:" ("", thm)); ctxt)
   else ctxt addsimps [thm];
 *)
 fun del_simp thm ctxt = ctxt delsimps [thm];
 fun flip_simp thm ctxt = addsymsimps (delsimps_quiet ctxt [thm]) [thm];
 
 end;
 
 fun init_simpset thms ctxt = ctxt
   |> Context_Position.set_visible false
   |> empty_simpset
   |> fold add_simp thms
   |> Context_Position.restore_visible ctxt;
 
 
 (* congs *)
 
 local
 
 fun is_full_cong_prems [] [] = true
   | is_full_cong_prems [] _ = false
   | is_full_cong_prems (p :: prems) varpairs =
       (case Logic.strip_assums_concl p of
         Const ("Pure.eq", _) $ lhs $ rhs =>
           let val (x, xs) = strip_comb lhs and (y, ys) = strip_comb rhs in
             is_Var x andalso forall is_Bound xs andalso
             not (has_duplicates (op =) xs) andalso xs = ys andalso
             member (op =) varpairs (x, y) andalso
             is_full_cong_prems prems (remove (op =) (x, y) varpairs)
           end
       | _ => false);
 
 fun is_full_cong thm =
   let
     val prems = Thm.prems_of thm and concl = Thm.concl_of thm;
     val (lhs, rhs) = Logic.dest_equals concl;
     val (f, xs) = strip_comb lhs and (g, ys) = strip_comb rhs;
   in
     f = g andalso not (has_duplicates (op =) (xs @ ys)) andalso length xs = length ys andalso
     is_full_cong_prems prems (xs ~~ ys)
   end;
 
 fun mk_cong ctxt =
   let val Simpset (_, {mk_rews = {mk_cong = f, ...}, ...}) = simpset_of ctxt
   in f ctxt end;
 
 in
 
 fun add_eqcong thm ctxt = ctxt |> map_simpset2
   (fn (congs, procs, mk_rews, term_ord, subgoal_tac, loop_tacs, solvers) =>
     let
       val (lhs, _) = Logic.dest_equals (Thm.concl_of thm)
         handle TERM _ => raise SIMPLIFIER ("Congruence not a meta-equality", [thm]);
     (*val lhs = Envir.eta_contract lhs;*)
       val a = the (cong_name (head_of lhs)) handle Option.Option =>
         raise SIMPLIFIER ("Congruence must start with a constant or free variable", [thm]);
       val (xs, weak) = congs;
       val xs' = Congtab.update (a, Thm.trim_context thm) xs;
       val weak' = if is_full_cong thm then weak else a :: weak;
     in ((xs', weak'), procs, mk_rews, term_ord, subgoal_tac, loop_tacs, solvers) end);
 
 fun del_eqcong thm ctxt = ctxt |> map_simpset2
   (fn (congs, procs, mk_rews, term_ord, subgoal_tac, loop_tacs, solvers) =>
     let
       val (lhs, _) = Logic.dest_equals (Thm.concl_of thm)
         handle TERM _ => raise SIMPLIFIER ("Congruence not a meta-equality", [thm]);
     (*val lhs = Envir.eta_contract lhs;*)
       val a = the (cong_name (head_of lhs)) handle Option.Option =>
         raise SIMPLIFIER ("Congruence must start with a constant", [thm]);
       val (xs, _) = congs;
       val xs' = Congtab.delete_safe a xs;
       val weak' = Congtab.fold (fn (a, th) => if is_full_cong th then I else insert (op =) a) xs' [];
     in ((xs', weak'), procs, mk_rews, term_ord, subgoal_tac, loop_tacs, solvers) end);
 
 fun add_cong thm ctxt = add_eqcong (mk_cong ctxt thm) ctxt;
 fun del_cong thm ctxt = del_eqcong (mk_cong ctxt thm) ctxt;
 
 end;
 
 
 (* simprocs *)
 
 datatype simproc =
   Simproc of
     {name: string,
      lhss: term list,
      proc: morphism -> Proof.context -> cterm -> thm option,
      stamp: stamp};
 
 fun eq_simproc (Simproc {stamp = stamp1, ...}, Simproc {stamp = stamp2, ...}) = stamp1 = stamp2;
 
 fun cert_simproc thy name {lhss, proc} =
   Simproc {name = name, lhss = map (Sign.cert_term thy) lhss, proc = proc, stamp = stamp ()};
 
 fun transform_simproc phi (Simproc {name, lhss, proc, stamp}) =
   Simproc
    {name = name,
     lhss = map (Morphism.term phi) lhss,
     proc = Morphism.transform phi proc,
     stamp = stamp};
 
 local
 
 fun add_proc (proc as Proc {name, lhs, ...}) ctxt =
  (cond_tracing ctxt (fn () =>
     print_term ctxt ("Adding simplification procedure " ^ quote name ^ " for") lhs);
   ctxt |> map_simpset2
     (fn (congs, procs, mk_rews, term_ord, subgoal_tac, loop_tacs, solvers) =>
       (congs, Net.insert_term eq_proc (lhs, proc) procs,
         mk_rews, term_ord, subgoal_tac, loop_tacs, solvers))
   handle Net.INSERT =>
     (cond_warning ctxt (fn () => "Ignoring duplicate simplification procedure " ^ quote name);
       ctxt));
 
 fun del_proc (proc as Proc {name, lhs, ...}) ctxt =
   ctxt |> map_simpset2
     (fn (congs, procs, mk_rews, term_ord, subgoal_tac, loop_tacs, solvers) =>
       (congs, Net.delete_term eq_proc (lhs, proc) procs,
         mk_rews, term_ord, subgoal_tac, loop_tacs, solvers))
   handle Net.DELETE =>
     (cond_warning ctxt (fn () => "Simplification procedure " ^ quote name ^ " not in simpset");
       ctxt);
 
 fun prep_procs (Simproc {name, lhss, proc, stamp}) =
   lhss |> map (fn lhs => Proc {name = name, lhs = lhs, proc = Morphism.form proc, stamp = stamp});
 
 in
 
 fun ctxt addsimprocs ps = fold (fold add_proc o prep_procs) ps ctxt;
 fun ctxt delsimprocs ps = fold (fold del_proc o prep_procs) ps ctxt;
 
 end;
 
 
 (* mk_rews *)
 
 local
 
 fun map_mk_rews f =
   map_simpset2 (fn (congs, procs, mk_rews, term_ord, subgoal_tac, loop_tacs, solvers) =>
     let
       val {mk, mk_cong, mk_sym, mk_eq_True, reorient} = mk_rews;
       val (mk', mk_cong', mk_sym', mk_eq_True', reorient') =
         f (mk, mk_cong, mk_sym, mk_eq_True, reorient);
       val mk_rews' = {mk = mk', mk_cong = mk_cong', mk_sym = mk_sym', mk_eq_True = mk_eq_True',
         reorient = reorient'};
     in (congs, procs, mk_rews', term_ord, subgoal_tac, loop_tacs, solvers) end);
 
 in
 
 fun mksimps ctxt =
   let val Simpset (_, {mk_rews = {mk, ...}, ...}) = simpset_of ctxt
   in mk ctxt end;
 
 fun set_mksimps mk = map_mk_rews (fn (_, mk_cong, mk_sym, mk_eq_True, reorient) =>
   (mk, mk_cong, mk_sym, mk_eq_True, reorient));
 
 fun set_mkcong mk_cong = map_mk_rews (fn (mk, _, mk_sym, mk_eq_True, reorient) =>
   (mk, mk_cong, mk_sym, mk_eq_True, reorient));
 
 fun set_mksym mk_sym = map_mk_rews (fn (mk, mk_cong, _, mk_eq_True, reorient) =>
   (mk, mk_cong, mk_sym, mk_eq_True, reorient));
 
 fun set_mkeqTrue mk_eq_True = map_mk_rews (fn (mk, mk_cong, mk_sym, _, reorient) =>
   (mk, mk_cong, mk_sym, mk_eq_True, reorient));
 
 fun set_reorient reorient = map_mk_rews (fn (mk, mk_cong, mk_sym, mk_eq_True, _) =>
   (mk, mk_cong, mk_sym, mk_eq_True, reorient));
 
 end;
 
 
 (* term_ord *)
 
 fun set_term_ord term_ord =
   map_simpset2 (fn (congs, procs, mk_rews, _, subgoal_tac, loop_tacs, solvers) =>
    (congs, procs, mk_rews, term_ord, subgoal_tac, loop_tacs, solvers));
 
 
 (* tactics *)
 
 fun set_subgoaler subgoal_tac =
   map_simpset2 (fn (congs, procs, mk_rews, term_ord, _, loop_tacs, solvers) =>
    (congs, procs, mk_rews, term_ord, subgoal_tac, loop_tacs, solvers));
 
 fun ctxt setloop tac = ctxt |>
   map_simpset2 (fn (congs, procs, mk_rews, term_ord, subgoal_tac, _, solvers) =>
    (congs, procs, mk_rews, term_ord, subgoal_tac, [("", tac)], solvers));
 
 fun ctxt addloop (name, tac) = ctxt |>
   map_simpset2 (fn (congs, procs, mk_rews, term_ord, subgoal_tac, loop_tacs, solvers) =>
     (congs, procs, mk_rews, term_ord, subgoal_tac,
      AList.update (op =) (name, tac) loop_tacs, solvers));
 
 fun ctxt delloop name = ctxt |>
   map_simpset2 (fn (congs, procs, mk_rews, term_ord, subgoal_tac, loop_tacs, solvers) =>
     (congs, procs, mk_rews, term_ord, subgoal_tac,
      (if AList.defined (op =) loop_tacs name then ()
       else cond_warning ctxt (fn () => "No such looper in simpset: " ^ quote name);
       AList.delete (op =) name loop_tacs), solvers));
 
 fun ctxt setSSolver solver = ctxt |> map_simpset2
   (fn (congs, procs, mk_rews, term_ord, subgoal_tac, loop_tacs, (unsafe_solvers, _)) =>
     (congs, procs, mk_rews, term_ord, subgoal_tac, loop_tacs, (unsafe_solvers, [solver])));
 
 fun ctxt addSSolver solver = ctxt |> map_simpset2 (fn (congs, procs, mk_rews, term_ord,
   subgoal_tac, loop_tacs, (unsafe_solvers, solvers)) => (congs, procs, mk_rews, term_ord,
     subgoal_tac, loop_tacs, (unsafe_solvers, insert eq_solver solver solvers)));
 
 fun ctxt setSolver solver = ctxt |> map_simpset2 (fn (congs, procs, mk_rews, term_ord,
   subgoal_tac, loop_tacs, (_, solvers)) => (congs, procs, mk_rews, term_ord,
     subgoal_tac, loop_tacs, ([solver], solvers)));
 
 fun ctxt addSolver solver = ctxt |> map_simpset2 (fn (congs, procs, mk_rews, term_ord,
   subgoal_tac, loop_tacs, (unsafe_solvers, solvers)) => (congs, procs, mk_rews, term_ord,
     subgoal_tac, loop_tacs, (insert eq_solver solver unsafe_solvers, solvers)));
 
 fun set_solvers solvers = map_simpset2 (fn (congs, procs, mk_rews, term_ord,
   subgoal_tac, loop_tacs, _) => (congs, procs, mk_rews, term_ord,
   subgoal_tac, loop_tacs, (solvers, solvers)));
 
 
 (* trace operations *)
 
 type trace_ops =
  {trace_invoke: {depth: int, term: term} -> Proof.context -> Proof.context,
   trace_apply: {unconditional: bool, term: term, thm: thm, rrule: rrule} ->
     Proof.context -> (Proof.context -> (thm * term) option) -> (thm * term) option};
 
 structure Trace_Ops = Theory_Data
 (
   type T = trace_ops;
   val empty: T =
    {trace_invoke = fn _ => fn ctxt => ctxt,
     trace_apply = fn _ => fn ctxt => fn cont => cont ctxt};
   val extend = I;
   fun merge (trace_ops, _) = trace_ops;
 );
 
 val set_trace_ops = Trace_Ops.put;
 
 val trace_ops = Trace_Ops.get o Proof_Context.theory_of;
 fun trace_invoke args ctxt = #trace_invoke (trace_ops ctxt) args ctxt;
 fun trace_apply args ctxt = #trace_apply (trace_ops ctxt) args ctxt;
 
 
 
 (** rewriting **)
 
 (*
   Uses conversions, see:
     L C Paulson, A higher-order implementation of rewriting,
     Science of Computer Programming 3 (1983), pages 119-149.
 *)
 
 fun check_conv ctxt msg thm thm' =
   let
     val thm'' = Thm.transitive thm thm' handle THM _ =>
       let
         val nthm' =
           Thm.transitive (Thm.symmetric (Drule.beta_eta_conversion (Thm.lhs_of thm'))) thm'
       in Thm.transitive thm nthm' handle THM _ =>
            let
              val nthm =
                Thm.transitive thm (Drule.beta_eta_conversion (Thm.rhs_of thm))
            in Thm.transitive nthm nthm' end
       end
     val _ =
       if msg then cond_tracing ctxt (fn () => print_thm ctxt "SUCCEEDED" ("", thm'))
       else ();
   in SOME thm'' end
   handle THM _ =>
     let
       val _ $ _ $ prop0 = Thm.prop_of thm;
       val _ =
         cond_tracing ctxt (fn () =>
           print_thm ctxt "Proved wrong theorem (bad subgoaler?)" ("", thm') ^ "\n" ^
           print_term ctxt "Should have proved:" prop0);
     in NONE end;
 
 
 (* mk_procrule *)
 
 fun mk_procrule ctxt thm =
   let
     val (prems, lhs, elhs, rhs, _) = decomp_simp thm
     val thm' = Thm.close_derivation \<^here> thm;
   in
     if rewrite_rule_extra_vars prems lhs rhs
     then (cond_warning ctxt (fn () => print_thm ctxt "Extra vars on rhs:" ("", thm)); [])
     else [mk_rrule2 {thm = thm', name = "", lhs = lhs, elhs = elhs, perm = false}]
   end;
 
 
 (* rewritec: conversion to apply the meta simpset to a term *)
 
 (*Since the rewriting strategy is bottom-up, we avoid re-normalizing already
   normalized terms by carrying around the rhs of the rewrite rule just
   applied. This is called the `skeleton'. It is decomposed in parallel
   with the term. Once a Var is encountered, the corresponding term is
   already in normal form.
   skel0 is a dummy skeleton that is to enforce complete normalization.*)
 
 val skel0 = Bound 0;
 
 (*Use rhs as skeleton only if the lhs does not contain unnormalized bits.
   The latter may happen iff there are weak congruence rules for constants
   in the lhs.*)
 
 fun uncond_skel ((_, weak), (lhs, rhs)) =
   if null weak then rhs  (*optimization*)
   else if exists_subterm
     (fn Const (a, _) => member (op =) weak (true, a)
       | Free (a, _) => member (op =) weak (false, a)
       | _ => false) lhs then skel0
   else rhs;
 
 (*Behaves like unconditional rule if rhs does not contain vars not in the lhs.
   Otherwise those vars may become instantiated with unnormalized terms
   while the premises are solved.*)
 
 fun cond_skel (args as (_, (lhs, rhs))) =
   if Term_Subst.Vars.subset (vars_set rhs, vars_set lhs) then uncond_skel args
   else skel0;
 
 (*
   Rewriting -- we try in order:
     (1) beta reduction
     (2) unconditional rewrite rules
     (3) conditional rewrite rules
     (4) simplification procedures
 
   IMPORTANT: rewrite rules must not introduce new Vars or TVars!
 *)
 
 fun rewritec (prover, maxt) ctxt t =
   let
     val thy = Proof_Context.theory_of ctxt;
     val Simpset ({rules, ...}, {congs, procs, term_ord, ...}) = simpset_of ctxt;
     val eta_thm = Thm.eta_conversion t;
     val eta_t' = Thm.rhs_of eta_thm;
     val eta_t = Thm.term_of eta_t';
     fun rew rrule =
       let
         val {thm = thm0, name, lhs, elhs = elhs0, extra, fo, perm} = rrule;
         val thm = Thm.transfer thy thm0;
         val elhs = Thm.transfer_cterm thy elhs0;
         val prop = Thm.prop_of thm;
         val (rthm, elhs') =
           if maxt = ~1 orelse not extra then (thm, elhs)
           else (Thm.incr_indexes (maxt + 1) thm, Thm.incr_indexes_cterm (maxt + 1) elhs);
 
         val insts =
           if fo then Thm.first_order_match (elhs', eta_t')
           else Thm.match (elhs', eta_t');
         val thm' = Thm.instantiate insts (Thm.rename_boundvars lhs eta_t rthm);
         val prop' = Thm.prop_of thm';
         val unconditional = (Logic.count_prems prop' = 0);
         val (lhs', rhs') = Logic.dest_equals (Logic.strip_imp_concl prop');
         val trace_args = {unconditional = unconditional, term = eta_t, thm = thm', rrule = rrule};
       in
         if perm andalso is_greater_equal (term_ord (rhs', lhs'))
         then
          (cond_tracing ctxt (fn () =>
             print_thm ctxt "Cannot apply permutative rewrite rule" (name, thm) ^ "\n" ^
             print_thm ctxt "Term does not become smaller:" ("", thm'));
           NONE)
         else
          (cond_tracing ctxt (fn () =>
             print_thm ctxt "Applying instance of rewrite rule" (name, thm));
           if unconditional
           then
            (cond_tracing ctxt (fn () => print_thm ctxt "Rewriting:" ("", thm'));
             trace_apply trace_args ctxt (fn ctxt' =>
               let
                 val lr = Logic.dest_equals prop;
                 val SOME thm'' = check_conv ctxt' false eta_thm thm';
               in SOME (thm'', uncond_skel (congs, lr)) end))
           else
            (cond_tracing ctxt (fn () => print_thm ctxt "Trying to rewrite:" ("", thm'));
             if simp_depth ctxt > Config.get ctxt simp_depth_limit
             then (cond_tracing ctxt (fn () => "simp_depth_limit exceeded - giving up"); NONE)
             else
               trace_apply trace_args ctxt (fn ctxt' =>
                 (case prover ctxt' thm' of
                   NONE => (cond_tracing ctxt' (fn () => print_thm ctxt' "FAILED" ("", thm')); NONE)
                 | SOME thm2 =>
                     (case check_conv ctxt' true eta_thm thm2 of
                       NONE => NONE
                     | SOME thm2' =>
                         let
                           val concl = Logic.strip_imp_concl prop;
                           val lr = Logic.dest_equals concl;
                         in SOME (thm2', cond_skel (congs, lr)) end)))))
       end;
 
     fun rews [] = NONE
       | rews (rrule :: rrules) =
           let val opt = rew rrule handle Pattern.MATCH => NONE
           in (case opt of NONE => rews rrules | some => some) end;
 
     fun sort_rrules rrs =
       let
         fun is_simple ({thm, ...}: rrule) =
           (case Thm.prop_of thm of
             Const ("Pure.eq", _) $ _ $ _ => true
           | _ => false);
         fun sort [] (re1, re2) = re1 @ re2
           | sort (rr :: rrs) (re1, re2) =
               if is_simple rr
               then sort rrs (rr :: re1, re2)
               else sort rrs (re1, rr :: re2);
       in sort rrs ([], []) end;
 
     fun proc_rews [] = NONE
       | proc_rews (Proc {name, proc, lhs, ...} :: ps) =
           if Pattern.matches (Proof_Context.theory_of ctxt) (lhs, Thm.term_of t) then
             (cond_tracing' ctxt simp_debug (fn () =>
               print_term ctxt ("Trying procedure " ^ quote name ^ " on:") eta_t);
              (case proc ctxt eta_t' of
                NONE => (cond_tracing' ctxt simp_debug (fn () => "FAILED"); proc_rews ps)
              | SOME raw_thm =>
                  (cond_tracing ctxt (fn () =>
                     print_thm ctxt ("Procedure " ^ quote name ^ " produced rewrite rule:")
                       ("", raw_thm));
                   (case rews (mk_procrule ctxt raw_thm) of
                     NONE =>
                      (cond_tracing ctxt (fn () =>
                         print_term ctxt ("IGNORED result of simproc " ^ quote name ^
                             " -- does not match") (Thm.term_of t));
                       proc_rews ps)
                   | some => some))))
           else proc_rews ps;
   in
     (case eta_t of
       Abs _ $ _ => SOME (Thm.transitive eta_thm (Thm.beta_conversion false eta_t'), skel0)
     | _ =>
       (case rews (sort_rrules (Net.match_term rules eta_t)) of
         NONE => proc_rews (Net.match_term procs eta_t)
       | some => some))
   end;
 
 
 (* conversion to apply a congruence rule to a term *)
 
 fun congc prover ctxt maxt cong t =
   let
     val rthm = Thm.incr_indexes (maxt + 1) cong;
     val rlhs = fst (Thm.dest_equals (Drule.strip_imp_concl (Thm.cprop_of rthm)));
     val insts = Thm.match (rlhs, t)
     (* Thm.match can raise Pattern.MATCH;
        is handled when congc is called *)
     val thm' =
       Thm.instantiate insts (Thm.rename_boundvars (Thm.term_of rlhs) (Thm.term_of t) rthm);
     val _ =
       cond_tracing ctxt (fn () => print_thm ctxt "Applying congruence rule:" ("", thm'));
     fun err (msg, thm) = (cond_tracing ctxt (fn () => print_thm ctxt msg ("", thm)); NONE);
   in
     (case prover thm' of
       NONE => err ("Congruence proof failed.  Could not prove", thm')
     | SOME thm2 =>
         (case check_conv ctxt true (Drule.beta_eta_conversion t) thm2 of
           NONE => err ("Congruence proof failed.  Should not have proved", thm2)
         | SOME thm2' =>
             if op aconv (apply2 Thm.term_of (Thm.dest_equals (Thm.cprop_of thm2')))
             then NONE else SOME thm2'))
   end;
 
 val vA = (("A", 0), propT);
 val vB = (("B", 0), propT);
 val vC = (("C", 0), propT);
 
 fun transitive1 NONE NONE = NONE
   | transitive1 (SOME thm1) NONE = SOME thm1
   | transitive1 NONE (SOME thm2) = SOME thm2
   | transitive1 (SOME thm1) (SOME thm2) = SOME (Thm.transitive thm1 thm2);
 
 fun transitive2 thm = transitive1 (SOME thm);
 fun transitive3 thm = transitive1 thm o SOME;
 
 fun bottomc ((simprem, useprem, mutsimp), prover, maxidx) =
   let
     fun botc skel ctxt t =
       if is_Var skel then NONE
       else
         (case subc skel ctxt t of
            some as SOME thm1 =>
              (case rewritec (prover, maxidx) ctxt (Thm.rhs_of thm1) of
                 SOME (thm2, skel2) =>
                   transitive2 (Thm.transitive thm1 thm2)
                     (botc skel2 ctxt (Thm.rhs_of thm2))
               | NONE => some)
          | NONE =>
              (case rewritec (prover, maxidx) ctxt t of
                 SOME (thm2, skel2) => transitive2 thm2
                   (botc skel2 ctxt (Thm.rhs_of thm2))
               | NONE => NONE))
 
     and try_botc ctxt t =
       (case botc skel0 ctxt t of
         SOME trec1 => trec1
       | NONE => Thm.reflexive t)
 
     and subc skel ctxt t0 =
         let val Simpset (_, {congs, ...}) = simpset_of ctxt in
           (case Thm.term_of t0 of
               Abs (a, T, _) =>
                 let
                     val (v, ctxt') = Variable.next_bound (a, T) ctxt;
                     val b = #1 (Term.dest_Free v);
                     val (v', t') = Thm.dest_abs (SOME b) t0;
                     val b' = #1 (Term.dest_Free (Thm.term_of v'));
                     val _ =
                       if b <> b' then
                         warning ("Bad Simplifier context: renamed bound variable " ^
                           quote b ^ " to " ^ quote b' ^ Position.here (Position.thread_data ()))
                       else ();
                     val skel' = (case skel of Abs (_, _, sk) => sk | _ => skel0);
                 in
                   (case botc skel' ctxt' t' of
                     SOME thm => SOME (Thm.abstract_rule a v' thm)
                   | NONE => NONE)
                 end
             | t $ _ =>
               (case t of
                 Const ("Pure.imp", _) $ _  => impc t0 ctxt
               | Abs _ =>
                   let val thm = Thm.beta_conversion false t0
                   in
                     (case subc skel0 ctxt (Thm.rhs_of thm) of
                       NONE => SOME thm
                     | SOME thm' => SOME (Thm.transitive thm thm'))
                   end
               | _  =>
                   let
                     fun appc () =
                       let
                         val (tskel, uskel) =
                           (case skel of
                             tskel $ uskel => (tskel, uskel)
                           | _ => (skel0, skel0));
                         val (ct, cu) = Thm.dest_comb t0;
                       in
                         (case botc tskel ctxt ct of
                           SOME thm1 =>
                             (case botc uskel ctxt cu of
                               SOME thm2 => SOME (Thm.combination thm1 thm2)
                             | NONE => SOME (Thm.combination thm1 (Thm.reflexive cu)))
                         | NONE =>
                             (case botc uskel ctxt cu of
                               SOME thm1 => SOME (Thm.combination (Thm.reflexive ct) thm1)
                             | NONE => NONE))
                       end;
                     val (h, ts) = strip_comb t;
                   in
                     (case cong_name h of
                       SOME a =>
                         (case Congtab.lookup (fst congs) a of
                           NONE => appc ()
                         | SOME cong =>
      (*post processing: some partial applications h t1 ... tj, j <= length ts,
        may be a redex. Example: map (\<lambda>x. x) = (\<lambda>xs. xs) wrt map_cong*)
                            (let
                               val thm = congc (prover ctxt) ctxt maxidx cong t0;
                               val t = the_default t0 (Option.map Thm.rhs_of thm);
                               val (cl, cr) = Thm.dest_comb t
                               val dVar = Var(("", 0), dummyT)
                               val skel =
                                 list_comb (h, replicate (length ts) dVar)
                             in
                               (case botc skel ctxt cl of
                                 NONE => thm
                               | SOME thm' =>
                                   transitive3 thm (Thm.combination thm' (Thm.reflexive cr)))
                             end handle Pattern.MATCH => appc ()))
                      | _ => appc ())
                   end)
             | _ => NONE)
         end
     and impc ct ctxt =
       if mutsimp then mut_impc0 [] ct [] [] ctxt
       else nonmut_impc ct ctxt
 
     and rules_of_prem prem ctxt =
       if maxidx_of_term (Thm.term_of prem) <> ~1
       then
        (cond_tracing ctxt (fn () =>
           print_term ctxt "Cannot add premise as rewrite rule because it contains (type) unknowns:"
             (Thm.term_of prem));
         (([], NONE), ctxt))
       else
         let val (asm, ctxt') = Thm.assume_hyps prem ctxt
         in ((extract_safe_rrules ctxt' asm, SOME asm), ctxt') end
 
     and add_rrules (rrss, asms) ctxt =
       (fold o fold) insert_rrule rrss ctxt |> add_prems (map_filter I asms)
 
     and disch r prem eq =
       let
         val (lhs, rhs) = Thm.dest_equals (Thm.cprop_of eq);
         val eq' =
           Thm.implies_elim
             (Thm.instantiate ([], [(vA, prem), (vB, lhs), (vC, rhs)]) Drule.imp_cong)
             (Thm.implies_intr prem eq);
       in
         if not r then eq'
         else
           let
             val (prem', concl) = Thm.dest_implies lhs;
             val (prem'', _) = Thm.dest_implies rhs;
           in
             Thm.transitive
               (Thm.transitive
                 (Thm.instantiate ([], [(vA, prem'), (vB, prem), (vC, concl)]) Drule.swap_prems_eq)
                 eq')
               (Thm.instantiate ([], [(vA, prem), (vB, prem''), (vC, concl)]) Drule.swap_prems_eq)
           end
       end
 
     and rebuild [] _ _ _ _ eq = eq
       | rebuild (prem :: prems) concl (_ :: rrss) (_ :: asms) ctxt eq =
           let
             val ctxt' = add_rrules (rev rrss, rev asms) ctxt;
             val concl' =
               Drule.mk_implies (prem, the_default concl (Option.map Thm.rhs_of eq));
             val dprem = Option.map (disch false prem);
           in
             (case rewritec (prover, maxidx) ctxt' concl' of
               NONE => rebuild prems concl' rrss asms ctxt (dprem eq)
             | SOME (eq', _) =>
                 transitive2 (fold (disch false) prems (the (transitive3 (dprem eq) eq')))
                   (mut_impc0 (rev prems) (Thm.rhs_of eq') (rev rrss) (rev asms) ctxt))
           end
 
     and mut_impc0 prems concl rrss asms ctxt =
       let
         val prems' = strip_imp_prems concl;
         val ((rrss', asms'), ctxt') = fold_map rules_of_prem prems' ctxt |>> split_list;
       in
         mut_impc (prems @ prems') (strip_imp_concl concl) (rrss @ rrss')
           (asms @ asms') [] [] [] [] ctxt' ~1 ~1
       end
 
     and mut_impc [] concl [] [] prems' rrss' asms' eqns ctxt changed k =
         transitive1 (fold (fn (eq1, prem) => fn eq2 => transitive1 eq1
             (Option.map (disch false prem) eq2)) (eqns ~~ prems') NONE)
           (if changed > 0 then
              mut_impc (rev prems') concl (rev rrss') (rev asms')
                [] [] [] [] ctxt ~1 changed
            else rebuild prems' concl rrss' asms' ctxt
              (botc skel0 (add_rrules (rev rrss', rev asms') ctxt) concl))
 
       | mut_impc (prem :: prems) concl (rrs :: rrss) (asm :: asms)
           prems' rrss' asms' eqns ctxt changed k =
         (case (if k = 0 then NONE else botc skel0 (add_rrules
           (rev rrss' @ rrss, rev asms' @ asms) ctxt) prem) of
             NONE => mut_impc prems concl rrss asms (prem :: prems')
               (rrs :: rrss') (asm :: asms') (NONE :: eqns) ctxt changed
               (if k = 0 then 0 else k - 1)
         | SOME eqn =>
             let
               val prem' = Thm.rhs_of eqn;
               val tprems = map Thm.term_of prems;
               val i = 1 + fold Integer.max (map (fn p =>
                 find_index (fn q => q aconv p) tprems) (Thm.hyps_of eqn)) ~1;
               val ((rrs', asm'), ctxt') = rules_of_prem prem' ctxt;
             in
               mut_impc prems concl rrss asms (prem' :: prems')
                 (rrs' :: rrss') (asm' :: asms')
                 (SOME (fold_rev (disch true)
                   (take i prems)
                   (Drule.imp_cong_rule eqn (Thm.reflexive (Drule.list_implies
                     (drop i prems, concl))))) :: eqns)
                 ctxt' (length prems') ~1
             end)
 
     (*legacy code -- only for backwards compatibility*)
     and nonmut_impc ct ctxt =
       let
         val (prem, conc) = Thm.dest_implies ct;
         val thm1 = if simprem then botc skel0 ctxt prem else NONE;
         val prem1 = the_default prem (Option.map Thm.rhs_of thm1);
         val ctxt1 =
           if not useprem then ctxt
           else
             let val ((rrs, asm), ctxt') = rules_of_prem prem1 ctxt
             in add_rrules ([rrs], [asm]) ctxt' end;
       in
         (case botc skel0 ctxt1 conc of
           NONE =>
             (case thm1 of
               NONE => NONE
             | SOME thm1' => SOME (Drule.imp_cong_rule thm1' (Thm.reflexive conc)))
         | SOME thm2 =>
             let val thm2' = disch false prem1 thm2 in
               (case thm1 of
                 NONE => SOME thm2'
               | SOME thm1' =>
                  SOME (Thm.transitive (Drule.imp_cong_rule thm1' (Thm.reflexive conc)) thm2'))
             end)
       end;
 
   in try_botc end;
 
 
 (* Meta-rewriting: rewrites t to u and returns the theorem t \<equiv> u *)
 
 (*
   Parameters:
     mode = (simplify A,
             use A in simplifying B,
             use prems of B (if B is again a meta-impl.) to simplify A)
            when simplifying A \<Longrightarrow> B
     prover: how to solve premises in conditional rewrites and congruences
 *)
 
 fun rewrite_cterm mode prover raw_ctxt raw_ct =
   let
     val thy = Proof_Context.theory_of raw_ctxt;
 
     val ct = raw_ct
       |> Thm.transfer_cterm thy
       |> Thm.adjust_maxidx_cterm ~1;
     val maxidx = Thm.maxidx_of_cterm ct;
 
     val ctxt =
       raw_ctxt
       |> Variable.set_body true
       |> Context_Position.set_visible false
       |> inc_simp_depth
       |> (fn ctxt => trace_invoke {depth = simp_depth ctxt, term = Thm.term_of ct} ctxt);
 
     val _ =
       cond_tracing ctxt (fn () =>
         print_term ctxt "SIMPLIFIER INVOKED ON THE FOLLOWING TERM:" (Thm.term_of ct));
   in
     ct
     |> bottomc (mode, Option.map (Drule.flexflex_unique (SOME ctxt)) oo prover, maxidx) ctxt
     |> Thm.solve_constraints
   end;
 
 val simple_prover =
   SINGLE o (fn ctxt => ALLGOALS (resolve_tac ctxt (prems_of ctxt)));
 
 fun rewrite _ _ [] = Thm.reflexive
   | rewrite ctxt full thms =
       rewrite_cterm (full, false, false) simple_prover (init_simpset thms ctxt);
 
 fun rewrite_rule ctxt = Conv.fconv_rule o rewrite ctxt true;
 
 (*simple term rewriting -- no proof*)
 fun rewrite_term thy rules procs =
   Pattern.rewrite_term thy (map decomp_simp' rules) procs;
 
 fun rewrite_thm mode prover ctxt = Conv.fconv_rule (rewrite_cterm mode prover ctxt);
 
 (*Rewrite the subgoals of a proof state (represented by a theorem)*)
 fun rewrite_goals_rule ctxt thms th =
   Conv.fconv_rule (Conv.prems_conv ~1 (rewrite_cterm (true, true, true) simple_prover
     (init_simpset thms ctxt))) th;
 
 
 (** meta-rewriting tactics **)
 
 (*Rewrite all subgoals*)
 fun rewrite_goals_tac ctxt defs = PRIMITIVE (rewrite_goals_rule ctxt defs);
 
 (*Rewrite one subgoal*)
 fun generic_rewrite_goal_tac mode prover_tac ctxt i thm =
   if 0 < i andalso i <= Thm.nprems_of thm then
     Seq.single (Conv.gconv_rule (rewrite_cterm mode (SINGLE o prover_tac) ctxt) i thm)
   else Seq.empty;
 
 fun rewrite_goal_tac ctxt thms =
   generic_rewrite_goal_tac (true, false, false) (K no_tac) (init_simpset thms ctxt);
 
 (*Prunes all redundant parameters from the proof state by rewriting.*)
 fun prune_params_tac ctxt = rewrite_goals_tac ctxt [Drule.triv_forall_equality];
 
 
 (* for folding definitions, handling critical pairs *)
 
 (*The depth of nesting in a term*)
 fun term_depth (Abs (_, _, t)) = 1 + term_depth t
   | term_depth (f $ t) = 1 + Int.max (term_depth f, term_depth t)
   | term_depth _ = 0;
 
 val lhs_of_thm = #1 o Logic.dest_equals o Thm.prop_of;
 
 (*folding should handle critical pairs!  E.g. K \<equiv> Inl 0,  S \<equiv> Inr (Inl 0)
   Returns longest lhs first to avoid folding its subexpressions.*)
 fun sort_lhs_depths defs =
   let val keylist = AList.make (term_depth o lhs_of_thm) defs
       val keys = sort_distinct (rev_order o int_ord) (map #2 keylist)
   in map (AList.find (op =) keylist) keys end;
 
 val rev_defs = sort_lhs_depths o map Thm.symmetric;
 
 fun fold_rule ctxt defs = fold (rewrite_rule ctxt) (rev_defs defs);
 fun fold_goals_tac ctxt defs = EVERY (map (rewrite_goals_tac ctxt) (rev_defs defs));
 
 
 (* HHF normal form: \<And> before \<Longrightarrow>, outermost \<And> generalized *)
 
 local
 
 fun gen_norm_hhf ss ctxt0 th0 =
   let
     val (ctxt, th) = Thm.join_transfer_context (ctxt0, th0);
     val th' =
       if Drule.is_norm_hhf (Thm.prop_of th) then th
       else
         Conv.fconv_rule (rewrite_cterm (true, false, false) (K (K NONE)) (put_simpset ss ctxt)) th;
   in th' |> Thm.adjust_maxidx_thm ~1 |> Variable.gen_all ctxt end;
 
 val hhf_ss =
   Context.the_local_context ()
   |> init_simpset Drule.norm_hhf_eqs
   |> simpset_of;
 
 val hhf_protect_ss =
   Context.the_local_context ()
   |> init_simpset Drule.norm_hhf_eqs
   |> add_eqcong Drule.protect_cong
   |> simpset_of;
 
 in
 
 val norm_hhf = gen_norm_hhf hhf_ss;
 val norm_hhf_protect = gen_norm_hhf hhf_protect_ss;
 
 end;
 
 end;
 
 structure Basic_Meta_Simplifier: BASIC_RAW_SIMPLIFIER = Raw_Simplifier;
 open Basic_Meta_Simplifier;
diff --git a/src/Pure/sorts.ML b/src/Pure/sorts.ML
--- a/src/Pure/sorts.ML
+++ b/src/Pure/sorts.ML
@@ -1,494 +1,492 @@
 (*  Title:      Pure/sorts.ML
     Author:     Markus Wenzel and Stefan Berghofer, TU Muenchen
 
 The order-sorted algebra of type classes.
 
 Classes denote (possibly empty) collections of types that are
 partially ordered by class inclusion. They are represented
 symbolically by strings.
 
 Sorts are intersections of finitely many classes. They are represented
 by lists of classes.  Normal forms of sorts are sorted lists of
 minimal classes (wrt. current class inclusion).
 *)
 
 signature SORTS =
 sig
   val make: sort list -> sort Ord_List.T
   val subset: sort Ord_List.T * sort Ord_List.T -> bool
   val union: sort Ord_List.T -> sort Ord_List.T -> sort Ord_List.T
   val subtract: sort Ord_List.T -> sort Ord_List.T -> sort Ord_List.T
   val remove_sort: sort -> sort Ord_List.T -> sort Ord_List.T
   val insert_sort: sort -> sort Ord_List.T -> sort Ord_List.T
   val insert_typ: typ -> sort Ord_List.T -> sort Ord_List.T
   val insert_typs: typ list -> sort Ord_List.T -> sort Ord_List.T
   val insert_term: term -> sort Ord_List.T -> sort Ord_List.T
   val insert_terms: term list -> sort Ord_List.T -> sort Ord_List.T
   type algebra
   val classes_of: algebra -> serial Graph.T
   val arities_of: algebra -> (class * sort list) list Symtab.table
   val all_classes: algebra -> class list
   val super_classes: algebra -> class -> class list
   val class_less: algebra -> class * class -> bool
   val class_le: algebra -> class * class -> bool
   val sort_eq: algebra -> sort * sort -> bool
   val sort_le: algebra -> sort * sort -> bool
   val sorts_le: algebra -> sort list * sort list -> bool
   val inter_sort: algebra -> sort * sort -> sort
   val minimize_sort: algebra -> sort -> sort
   val complete_sort: algebra -> sort -> sort
   val add_class: Context.generic -> class * class list -> algebra -> algebra
   val add_classrel: Context.generic -> class * class -> algebra -> algebra
   val add_arities: Context.generic -> string * (class * sort list) list -> algebra -> algebra
   val empty_algebra: algebra
   val merge_algebra: Context.generic -> algebra * algebra -> algebra
   val dest_algebra: algebra list -> algebra ->
     {classrel: (class * class list) list,
      arities: (string * sort list * class) list}
   val subalgebra: Context.generic -> (class -> bool) -> (class * string -> sort list option)
     -> algebra -> (sort -> sort) * algebra
   type class_error
   val class_error: Context.generic -> class_error -> string
   exception CLASS_ERROR of class_error
   val has_instance: algebra -> string -> sort -> bool
   val mg_domain: algebra -> string -> sort -> sort list   (*exception CLASS_ERROR*)
   val meet_sort: algebra -> typ * sort
     -> sort Vartab.table -> sort Vartab.table   (*exception CLASS_ERROR*)
   val meet_sort_typ: algebra -> typ * sort -> typ -> typ   (*exception CLASS_ERROR*)
   val of_sort: algebra -> typ * sort -> bool
   val of_sort_derivation: algebra ->
     {class_relation: typ -> bool -> 'a * class -> class -> 'a,
      type_constructor: string * typ list -> ('a * class) list list -> class -> 'a,
      type_variable: typ -> ('a * class) list} ->
     typ * sort -> 'a list   (*exception CLASS_ERROR*)
   val classrel_derivation: algebra ->
     ('a * class -> class -> 'a) -> 'a * class -> class -> 'a  (*exception CLASS_ERROR*)
   val witness_sorts: algebra -> string list -> (typ * sort) list -> sort list -> (typ * sort) list
 end;
 
 structure Sorts: SORTS =
 struct
 
 
 (** ordered lists of sorts **)
 
 val make = Ord_List.make Term_Ord.sort_ord;
 val subset = Ord_List.subset Term_Ord.sort_ord;
 val union = Ord_List.union Term_Ord.sort_ord;
 val subtract = Ord_List.subtract Term_Ord.sort_ord;
 
 val remove_sort = Ord_List.remove Term_Ord.sort_ord;
 val insert_sort = Ord_List.insert Term_Ord.sort_ord;
 
 fun insert_typ (TFree (_, S)) Ss = insert_sort S Ss
   | insert_typ (TVar (_, S)) Ss = insert_sort S Ss
   | insert_typ (Type (_, Ts)) Ss = insert_typs Ts Ss
 and insert_typs [] Ss = Ss
   | insert_typs (T :: Ts) Ss = insert_typs Ts (insert_typ T Ss);
 
 fun insert_term (Const (_, T)) Ss = insert_typ T Ss
   | insert_term (Free (_, T)) Ss = insert_typ T Ss
   | insert_term (Var (_, T)) Ss = insert_typ T Ss
   | insert_term (Bound _) Ss = Ss
   | insert_term (Abs (_, T, t)) Ss = insert_term t (insert_typ T Ss)
   | insert_term (t $ u) Ss = insert_term t (insert_term u Ss);
 
 fun insert_terms [] Ss = Ss
   | insert_terms (t :: ts) Ss = insert_terms ts (insert_term t Ss);
 
 
 
 (** order-sorted algebra **)
 
 (*
   classes: graph representing class declarations together with proper
     subclass relation, which needs to be transitive and acyclic.
 
   arities: table of association lists of all type arities; (t, ars)
     means that type constructor t has the arities ars; an element
     (c, Ss) of ars represents the arity t::(Ss)c.  "Coregularity" of
     the arities structure requires that for any two declarations
     t::(Ss1)c1 and t::(Ss2)c2 such that c1 <= c2 holds Ss1 <= Ss2.
 *)
 
 datatype algebra = Algebra of
  {classes: serial Graph.T,
   arities: (class * sort list) list Symtab.table};
 
 fun classes_of (Algebra {classes, ...}) = classes;
 fun arities_of (Algebra {arities, ...}) = arities;
 
 fun make_algebra (classes, arities) =
   Algebra {classes = classes, arities = arities};
 
 fun map_classes f (Algebra {classes, arities}) = make_algebra (f classes, arities);
 fun map_arities f (Algebra {classes, arities}) = make_algebra (classes, f arities);
 
 
 (* classes *)
 
 fun all_classes (Algebra {classes, ...}) = Graph.all_preds classes (Graph.maximals classes);
 
 val super_classes = Graph.immediate_succs o classes_of;
 
 
 (* class relations *)
 
 val class_less : algebra -> class * class -> bool = Graph.is_edge o classes_of;
 fun class_le algebra (c1, c2) = c1 = c2 orelse class_less algebra (c1, c2);
 
 
 (* sort relations *)
 
 fun sort_le algebra (S1: sort, S2: sort) =
   S1 = S2 orelse forall (fn c2 => exists (fn c1 => class_le algebra (c1, c2)) S1) S2;
 
 fun sorts_le algebra (Ss1, Ss2) =
   ListPair.all (sort_le algebra) (Ss1, Ss2);
 
 fun sort_eq algebra (S1, S2) =
   sort_le algebra (S1, S2) andalso sort_le algebra (S2, S1);
 
 
 (* intersection *)
 
 fun inter_class algebra c S =
   let
     fun intr [] = [c]
       | intr (S' as c' :: c's) =
           if class_le algebra (c', c) then S'
           else if class_le algebra (c, c') then intr c's
           else c' :: intr c's
   in intr S end;
 
 fun inter_sort algebra (S1, S2) =
   sort_strings (fold (inter_class algebra) S1 S2);
 
 
 (* normal forms *)
 
 fun minimize_sort _ [] = []
   | minimize_sort _ (S as [_]) = S
   | minimize_sort algebra S =
       filter (fn c => not (exists (fn c' => class_less algebra (c', c)) S)) S
       |> sort_distinct string_ord;
 
 fun complete_sort algebra =
   Graph.all_succs (classes_of algebra) o minimize_sort algebra;
 
 
 
 (** build algebras **)
 
 (* classes *)
 
 fun err_dup_class c = error ("Duplicate declaration of class: " ^ quote c);
 
 fun err_cyclic_classes context css =
   error (cat_lines (map (fn cs =>
     "Cycle in class relation: " ^ Syntax.string_of_classrel (Syntax.init_pretty context) cs) css));
 
 fun add_class context (c, cs) = map_classes (fn classes =>
   let
     val classes' = classes |> Graph.new_node (c, serial ())
       handle Graph.DUP dup => err_dup_class dup;
     val classes'' = classes' |> fold Graph.add_edge_trans_acyclic (map (pair c) cs)
       handle Graph.CYCLES css => err_cyclic_classes context css;
   in classes'' end);
 
 
 (* arities *)
 
 local
 
 fun for_classes _ NONE = ""
   | for_classes ctxt (SOME (c1, c2)) = " for classes " ^ Syntax.string_of_classrel ctxt [c1, c2];
 
 fun err_conflict context t cc (c, Ss) (c', Ss') =
   let val ctxt = Syntax.init_pretty context in
     error ("Conflict of type arities" ^ for_classes ctxt cc ^ ":\n  " ^
       Syntax.string_of_arity ctxt (t, Ss, [c]) ^ " and\n  " ^
       Syntax.string_of_arity ctxt (t, Ss', [c']))
   end;
 
 fun coregular context algebra t (c, Ss) ars =
   let
     fun conflict (c', Ss') =
       if class_le algebra (c, c') andalso not (sorts_le algebra (Ss, Ss')) then
         SOME ((c, c'), (c', Ss'))
       else if class_le algebra (c', c) andalso not (sorts_le algebra (Ss', Ss)) then
         SOME ((c', c), (c', Ss'))
       else NONE;
   in
     (case get_first conflict ars of
       SOME ((c1, c2), (c', Ss')) => err_conflict context t (SOME (c1, c2)) (c, Ss) (c', Ss')
     | NONE => (c, Ss) :: ars)
   end;
 
 fun complete algebra (c, Ss) = map (rpair Ss) (c :: super_classes algebra c);
 
 fun insert context algebra t (c, Ss) ars =
   (case AList.lookup (op =) ars c of
     NONE => coregular context algebra t (c, Ss) ars
   | SOME Ss' =>
       if sorts_le algebra (Ss, Ss') then ars
       else if sorts_le algebra (Ss', Ss)
       then coregular context algebra t (c, Ss) (remove (op =) (c, Ss') ars)
       else err_conflict context t NONE (c, Ss) (c, Ss'));
 
 in
 
 fun insert_ars context algebra t = fold_rev (insert context algebra t);
 
 fun insert_complete_ars context algebra (t, ars) arities =
   let val ars' =
     Symtab.lookup_list arities t
     |> fold_rev (insert_ars context algebra t) (map (complete algebra) ars);
   in Symtab.update (t, ars') arities end;
 
 fun add_arities context arg algebra =
   algebra |> map_arities (insert_complete_ars context algebra arg);
 
 fun add_arities_table context algebra =
   Symtab.fold (fn (t, ars) => insert_complete_ars context algebra (t, ars));
 
 end;
 
 
 (* classrel *)
 
-fun rebuild_arities context algebra = algebra |> map_arities (fn arities =>
-  Symtab.empty
-  |> add_arities_table context algebra arities);
+fun rebuild_arities context algebra = algebra
+  |> map_arities (Symtab.build o add_arities_table context algebra);
 
 fun add_classrel context rel = rebuild_arities context o map_classes (fn classes =>
   classes |> Graph.add_edge_trans_acyclic rel
     handle Graph.CYCLES css => err_cyclic_classes context css);
 
 
 (* empty and merge *)
 
 val empty_algebra = make_algebra (Graph.empty, Symtab.empty);
 
 fun merge_algebra context
    (Algebra {classes = classes1, arities = arities1},
     Algebra {classes = classes2, arities = arities2}) =
   let
     val classes' = Graph.merge_trans_acyclic (op =) (classes1, classes2)
       handle Graph.DUP c => err_dup_class c
         | Graph.CYCLES css => err_cyclic_classes context css;
     val algebra0 = make_algebra (classes', Symtab.empty);
     val arities' =
       (case (pointer_eq (classes1, classes2), pointer_eq (arities1, arities2)) of
         (true, true) => arities1
       | (true, false) =>  (*no completion*)
           (arities1, arities2) |> Symtab.join (fn t => fn (ars1, ars2) =>
             if pointer_eq (ars1, ars2) then raise Symtab.SAME
             else insert_ars context algebra0 t ars2 ars1)
       | (false, true) =>  (*unary completion*)
-          Symtab.empty
-          |> add_arities_table context algebra0 arities1
+          Symtab.build (add_arities_table context algebra0 arities1)
       | (false, false) => (*binary completion*)
-          Symtab.empty
-          |> add_arities_table context algebra0 arities1
-          |> add_arities_table context algebra0 arities2);
+          Symtab.build
+           (add_arities_table context algebra0 arities1 #>
+            add_arities_table context algebra0 arities2));
   in make_algebra (classes', arities') end;
 
 
 (* destruct *)
 
 fun dest_algebra parents (Algebra {classes, arities}) =
   let
     fun new_classrel rel = not (exists (fn algebra => class_less algebra rel) parents);
     val classrel =
       (classes, []) |-> Graph.fold (fn (c, (_, (_, ds))) =>
         (case filter (fn d => new_classrel (c, d)) (Graph.Keys.dest ds) of
           [] => I
         | ds' => cons (c, sort_strings ds')))
       |> sort_by #1;
 
     fun is_arity t ar algebra = member (op =) (Symtab.lookup_list (arities_of algebra) t) ar;
     fun add_arity t (c, Ss) = not (exists (is_arity t (c, Ss)) parents) ? cons (t, Ss, c);
     val arities =
       (arities, []) |-> Symtab.fold (fn (t, ars) => fold_rev (add_arity t) (sort_by #1 ars))
       |> sort_by #1;
   in {classrel = classrel, arities = arities} end;
 
 
 (* algebra projections *)  (* FIXME potentially violates abstract type integrity *)
 
 fun subalgebra context P sargs (algebra as Algebra {classes, arities}) =
   let
     val restrict_sort = minimize_sort algebra o filter P o Graph.all_succs classes;
     fun restrict_arity t (c, Ss) =
       if P c then
         (case sargs (c, t) of
           SOME sorts =>
             SOME (c, Ss |> map2 (curry (inter_sort algebra)) sorts |> map restrict_sort)
         | NONE => NONE)
       else NONE;
     val classes' = classes |> Graph.restrict P;
     val arities' = arities |> Symtab.map (map_filter o restrict_arity);
   in (restrict_sort, rebuild_arities context (make_algebra (classes', arities'))) end;
 
 
 
 (** sorts of types **)
 
 (* errors -- performance tuning via delayed message composition *)
 
 datatype class_error =
   No_Classrel of class * class |
   No_Arity of string * class |
   No_Subsort of sort * sort;
 
 fun class_error context =
   let val ctxt = Syntax.init_pretty context in
     fn No_Classrel (c1, c2) => "No class relation " ^ Syntax.string_of_classrel ctxt [c1, c2]
      | No_Arity (a, c) => "No type arity " ^ Syntax.string_of_arity ctxt (a, [], [c])
      | No_Subsort (S1, S2) =>
         "Cannot derive subsort relation " ^
           Syntax.string_of_sort ctxt S1 ^ " < " ^ Syntax.string_of_sort ctxt S2
   end;
 
 exception CLASS_ERROR of class_error;
 
 
 (* instances *)
 
 fun has_instance algebra a =
   forall (AList.defined (op =) (Symtab.lookup_list (arities_of algebra) a));
 
 fun mg_domain algebra a S =
   let
     val ars = Symtab.lookup_list (arities_of algebra) a;
     fun dom c =
       (case AList.lookup (op =) ars c of
         NONE => raise CLASS_ERROR (No_Arity (a, c))
       | SOME Ss => Ss);
     fun dom_inter c Ss = ListPair.map (inter_sort algebra) (dom c, Ss);
   in
     (case S of
       [] => raise Fail "Unknown domain of empty intersection"
     | c :: cs => fold dom_inter cs (dom c))
   end;
 
 
 (* meet_sort *)
 
 fun meet_sort algebra =
   let
     fun inters S S' = inter_sort algebra (S, S');
     fun meet _ [] = I
       | meet (TFree (_, S)) S' =
           if sort_le algebra (S, S') then I
           else raise CLASS_ERROR (No_Subsort (S, S'))
       | meet (TVar (v, S)) S' =
           if sort_le algebra (S, S') then I
           else Vartab.map_default (v, S) (inters S')
       | meet (Type (a, Ts)) S = fold2 meet Ts (mg_domain algebra a S);
   in uncurry meet end;
 
 fun meet_sort_typ algebra (T, S) =
-  let val tab = meet_sort algebra (T, S) Vartab.empty;
+  let val tab = Vartab.build (meet_sort algebra (T, S));
   in Term.map_type_tvar (fn (v, _) => TVar (v, (the o Vartab.lookup tab) v)) end;
 
 
 (* of_sort *)
 
 fun of_sort algebra =
   let
     fun ofS (_, []) = true
       | ofS (TFree (_, S), S') = sort_le algebra (S, S')
       | ofS (TVar (_, S), S') = sort_le algebra (S, S')
       | ofS (Type (a, Ts), S) =
           let val Ss = mg_domain algebra a S in
             ListPair.all ofS (Ts, Ss)
           end handle CLASS_ERROR _ => false;
   in ofS end;
 
 
 (* animating derivations *)
 
 fun of_sort_derivation algebra {class_relation, type_constructor, type_variable} =
   let
     val arities = arities_of algebra;
 
     fun weaken T D1 S2 =
       let val S1 = map snd D1 in
         if S1 = S2 then map fst D1
         else
           S2 |> map (fn c2 =>
             (case D1 |> filter (fn (_, c1) => class_le algebra (c1, c2)) of
               [d1] => class_relation T true d1 c2
             | (d1 :: _ :: _) => class_relation T false d1 c2
             | [] => raise CLASS_ERROR (No_Subsort (S1, S2))))
       end;
 
     fun derive (_, []) = []
       | derive (Type (a, Us), S) =
           let
             val Ss = mg_domain algebra a S;
             val dom = map2 (fn U => fn S => derive (U, S) ~~ S) Us Ss;
           in
             S |> map (fn c =>
               let
                 val Ss' = the (AList.lookup (op =) (Symtab.lookup_list arities a) c);
                 val dom' = map (fn ((U, d), S') => weaken U d S' ~~ S') ((Us ~~ dom) ~~ Ss');
               in type_constructor (a, Us) dom' c end)
           end
       | derive (T, S) = weaken T (type_variable T) S;
   in derive end;
 
 fun classrel_derivation algebra class_relation =
   let
     fun path (x, c1 :: c2 :: cs) = path (class_relation (x, c1) c2, c2 :: cs)
       | path (x, _) = x;
   in
     fn (x, c1) => fn c2 =>
       (case Graph.irreducible_paths (classes_of algebra) (c1, c2) of
         [] => raise CLASS_ERROR (No_Classrel (c1, c2))
       | cs :: _ => path (x, cs))
   end;
 
 
 (* witness_sorts *)
 
 fun witness_sorts algebra ground_types hyps sorts =
   let
     fun le S1 S2 = sort_le algebra (S1, S2);
     fun get S2 (T, S1) = if le S1 S2 then SOME (T, S2) else NONE;
     fun mg_dom t S = SOME (mg_domain algebra t S) handle CLASS_ERROR _ => NONE;
 
     fun witn_sort _ [] solved_failed = (SOME (propT, []), solved_failed)
       | witn_sort path S (solved, failed) =
           if exists (le S) failed then (NONE, (solved, failed))
           else
             (case get_first (get S) solved of
               SOME w => (SOME w, (solved, failed))
             | NONE =>
                 (case get_first (get S) hyps of
                   SOME w => (SOME w, (w :: solved, failed))
                 | NONE => witn_types path ground_types S (solved, failed)))
 
     and witn_sorts path x = fold_map (witn_sort path) x
 
     and witn_types _ [] S (solved, failed) = (NONE, (solved, S :: failed))
       | witn_types path (t :: ts) S solved_failed =
           (case mg_dom t S of
             SOME SS =>
               (*do not descend into stronger args (achieving termination)*)
               if exists (fn D => le D S orelse exists (le D) path) SS then
                 witn_types path ts S solved_failed
               else
                 let val (ws, (solved', failed')) = witn_sorts (S :: path) SS solved_failed in
                   if forall is_some ws then
                     let val w = (Type (t, map (#1 o the) ws), S)
                     in (SOME w, (w :: solved', failed')) end
                   else witn_types path ts S (solved', failed')
                 end
           | NONE => witn_types path ts S solved_failed);
 
   in map_filter I (#1 (witn_sorts [] sorts ([], []))) end;
 
 end;
diff --git a/src/Pure/term_subst.ML b/src/Pure/term_subst.ML
--- a/src/Pure/term_subst.ML
+++ b/src/Pure/term_subst.ML
@@ -1,289 +1,289 @@
 (*  Title:      Pure/term_subst.ML
     Author:     Makarius
 
 Efficient type/term substitution.
 *)
 
 signature INST_TABLE =
 sig
   include TABLE
   val add: key * 'a -> 'a table -> 'a table
   val table: (key * 'a) list -> 'a table
 end;
 
 functor Inst_Table(Key: KEY): INST_TABLE =
 struct
 
 structure Tab = Table(Key);
 
 fun add entry = Tab.insert (K true) entry;
-fun table entries = fold add entries Tab.empty;
+fun table entries = Tab.build (fold add entries);
 
 open Tab;
 
 end;
 
 signature TERM_SUBST =
 sig
   structure TFrees: INST_TABLE
   structure TVars: INST_TABLE
   structure Frees: INST_TABLE
   structure Vars: INST_TABLE
   val add_tfreesT: typ -> TFrees.set -> TFrees.set
   val add_tfrees: term -> TFrees.set -> TFrees.set
   val add_tvarsT: typ -> TVars.set -> TVars.set
   val add_tvars: term -> TVars.set -> TVars.set
   val add_frees: term -> Frees.set -> Frees.set
   val add_vars: term -> Vars.set -> Vars.set
   val add_tfree_namesT: typ -> Symtab.set -> Symtab.set
   val add_tfree_names: term -> Symtab.set -> Symtab.set
   val add_free_names: term -> Symtab.set -> Symtab.set
   val map_atypsT_same: typ Same.operation -> typ Same.operation
   val map_types_same: typ Same.operation -> term Same.operation
   val map_aterms_same: term Same.operation -> term Same.operation
   val generalizeT_same: Symtab.set -> int -> typ Same.operation
   val generalize_same: Symtab.set * Symtab.set -> int -> term Same.operation
   val generalizeT: Symtab.set -> int -> typ -> typ
   val generalize: Symtab.set * Symtab.set -> int -> term -> term
   val instantiateT_maxidx: (typ * int) TVars.table -> typ -> int -> typ * int
   val instantiate_maxidx: (typ * int) TVars.table * (term * int) Vars.table ->
     term -> int -> term * int
   val instantiateT_frees_same: typ TFrees.table -> typ Same.operation
   val instantiate_frees_same: typ TFrees.table * term Frees.table -> term Same.operation
   val instantiateT_frees: typ TFrees.table -> typ -> typ
   val instantiate_frees: typ TFrees.table * term Frees.table -> term -> term
   val instantiateT_same: typ TVars.table -> typ Same.operation
   val instantiate_same: typ TVars.table * term Vars.table -> term Same.operation
   val instantiateT: typ TVars.table -> typ -> typ
   val instantiate: typ TVars.table * term Vars.table -> term -> term
   val zero_var_indexes_inst: Name.context -> term list -> typ TVars.table * term Vars.table
   val zero_var_indexes: term -> term
   val zero_var_indexes_list: term list -> term list
 end;
 
 structure Term_Subst: TERM_SUBST =
 struct
 
 (* instantiation as table *)
 
 structure TFrees = Inst_Table(
   type key = string * sort
   val ord = pointer_eq_ord (prod_ord fast_string_ord Term_Ord.sort_ord)
 );
 
 structure TVars = Inst_Table(
   type key = indexname * sort
   val ord = pointer_eq_ord (prod_ord Term_Ord.fast_indexname_ord Term_Ord.sort_ord)
 );
 
 structure Frees = Inst_Table(
   type key = string * typ
   val ord = pointer_eq_ord (prod_ord fast_string_ord Term_Ord.typ_ord)
 );
 
 structure Vars = Inst_Table(
   type key = indexname * typ
   val ord = pointer_eq_ord (prod_ord Term_Ord.fast_indexname_ord Term_Ord.typ_ord)
 );
 
 val add_tfreesT = fold_atyps (fn TFree v => TFrees.add (v, ()) | _ => I);
 val add_tfrees = fold_types add_tfreesT;
 val add_tvarsT = fold_atyps (fn TVar v => TVars.add (v, ()) | _ => I);
 val add_tvars = fold_types add_tvarsT;
 val add_frees = fold_aterms (fn Free v => Frees.add (v, ()) | _ => I);
 val add_vars = fold_aterms (fn Var v => Vars.add (v, ()) | _ => I);
 val add_tfree_namesT = fold_atyps (fn TFree (a, _) => Symtab.insert_set a | _ => I);
 val add_tfree_names = fold_types add_tfree_namesT;
 val add_free_names = fold_aterms (fn Free (x, _) => Symtab.insert_set x | _ => I);
 
 
 (* generic mapping *)
 
 fun map_atypsT_same f =
   let
     fun typ (Type (a, Ts)) = Type (a, Same.map typ Ts)
       | typ T = f T;
   in typ end;
 
 fun map_types_same f =
   let
     fun term (Const (a, T)) = Const (a, f T)
       | term (Free (a, T)) = Free (a, f T)
       | term (Var (v, T)) = Var (v, f T)
       | term (Bound _) = raise Same.SAME
       | term (Abs (x, T, t)) =
           (Abs (x, f T, Same.commit term t)
             handle Same.SAME => Abs (x, T, term t))
       | term (t $ u) = (term t $ Same.commit term u handle Same.SAME => t $ term u);
   in term end;
 
 fun map_aterms_same f =
   let
     fun term (Abs (x, T, t)) = Abs (x, T, term t)
       | term (t $ u) = (term t $ Same.commit term u handle Same.SAME => t $ term u)
       | term a = f a;
   in term end;
 
 
 (* generalization of fixed variables *)
 
 fun generalizeT_same tfrees idx ty =
   if Symtab.is_empty tfrees then raise Same.SAME
   else
     let
       fun gen (Type (a, Ts)) = Type (a, Same.map gen Ts)
         | gen (TFree (a, S)) =
             if Symtab.defined tfrees a then TVar ((a, idx), S)
             else raise Same.SAME
         | gen _ = raise Same.SAME;
     in gen ty end;
 
 fun generalize_same (tfrees, frees) idx tm =
   if Symtab.is_empty tfrees andalso Symtab.is_empty frees then raise Same.SAME
   else
     let
       val genT = generalizeT_same tfrees idx;
       fun gen (Free (x, T)) =
             if Symtab.defined frees x then
               Var (Name.clean_index (x, idx), Same.commit genT T)
             else Free (x, genT T)
         | gen (Var (xi, T)) = Var (xi, genT T)
         | gen (Const (c, T)) = Const (c, genT T)
         | gen (Bound _) = raise Same.SAME
         | gen (Abs (x, T, t)) =
             (Abs (x, genT T, Same.commit gen t)
               handle Same.SAME => Abs (x, T, gen t))
         | gen (t $ u) = (gen t $ Same.commit gen u handle Same.SAME => t $ gen u);
     in gen tm end;
 
 fun generalizeT names i ty = Same.commit (generalizeT_same names i) ty;
 fun generalize names i tm = Same.commit (generalize_same names i) tm;
 
 
 (* instantiation of free variables (types before terms) *)
 
 fun instantiateT_frees_same instT ty =
   if TFrees.is_empty instT then raise Same.SAME
   else
     let
       fun subst (Type (a, Ts)) = Type (a, Same.map subst Ts)
         | subst (TFree v) =
             (case TFrees.lookup instT v of
               SOME T => T
             | NONE => raise Same.SAME)
         | subst _ = raise Same.SAME;
     in subst ty end;
 
 fun instantiate_frees_same (instT, inst) tm =
   if TFrees.is_empty instT andalso Frees.is_empty inst then raise Same.SAME
   else
     let
       val substT = instantiateT_frees_same instT;
       fun subst (Const (c, T)) = Const (c, substT T)
         | subst (Free (x, T)) =
             let val (T', same) = (substT T, false) handle Same.SAME => (T, true) in
               (case Frees.lookup inst (x, T') of
                  SOME t => t
                | NONE => if same then raise Same.SAME else Free (x, T'))
             end
         | subst (Var (xi, T)) = Var (xi, substT T)
         | subst (Bound _) = raise Same.SAME
         | subst (Abs (x, T, t)) =
             (Abs (x, substT T, Same.commit subst t)
               handle Same.SAME => Abs (x, T, subst t))
         | subst (t $ u) = (subst t $ Same.commit subst u handle Same.SAME => t $ subst u);
     in subst tm end;
 
 fun instantiateT_frees instT ty = Same.commit (instantiateT_frees_same instT) ty;
 fun instantiate_frees inst tm = Same.commit (instantiate_frees_same inst) tm;
 
 
 (* instantiation of schematic variables (types before terms) -- recomputes maxidx *)
 
 local
 
 fun no_indexesT instT = TVars.map (fn _ => rpair ~1) instT;
 fun no_indexes inst = Vars.map (fn _ => rpair ~1) inst;
 
 fun instT_same maxidx instT ty =
   let
     fun maxify i = if i > ! maxidx then maxidx := i else ();
 
     fun subst_typ (Type (a, Ts)) = Type (a, subst_typs Ts)
       | subst_typ (TVar ((a, i), S)) =
           (case TVars.lookup instT ((a, i), S) of
             SOME (T, j) => (maxify j; T)
           | NONE => (maxify i; raise Same.SAME))
       | subst_typ _ = raise Same.SAME
     and subst_typs (T :: Ts) =
         (subst_typ T :: Same.commit subst_typs Ts
           handle Same.SAME => T :: subst_typs Ts)
       | subst_typs [] = raise Same.SAME;
   in subst_typ ty end;
 
 fun inst_same maxidx (instT, inst) tm =
   let
     fun maxify i = if i > ! maxidx then maxidx := i else ();
 
     val substT = instT_same maxidx instT;
     fun subst (Const (c, T)) = Const (c, substT T)
       | subst (Free (x, T)) = Free (x, substT T)
       | subst (Var ((x, i), T)) =
           let val (T', same) = (substT T, false) handle Same.SAME => (T, true) in
             (case Vars.lookup inst ((x, i), T') of
                SOME (t, j) => (maxify j; t)
              | NONE => (maxify i; if same then raise Same.SAME else Var ((x, i), T')))
           end
       | subst (Bound _) = raise Same.SAME
       | subst (Abs (x, T, t)) =
           (Abs (x, substT T, Same.commit subst t)
             handle Same.SAME => Abs (x, T, subst t))
       | subst (t $ u) = (subst t $ Same.commit subst u handle Same.SAME => t $ subst u);
   in subst tm end;
 
 in
 
 fun instantiateT_maxidx instT ty i =
   let val maxidx = Unsynchronized.ref i
   in (Same.commit (instT_same maxidx instT) ty, ! maxidx) end;
 
 fun instantiate_maxidx insts tm i =
   let val maxidx = Unsynchronized.ref i
   in (Same.commit (inst_same maxidx insts) tm, ! maxidx) end;
 
 fun instantiateT_same instT ty =
   if TVars.is_empty instT then raise Same.SAME
   else instT_same (Unsynchronized.ref ~1) (no_indexesT instT) ty;
 
 fun instantiate_same (instT, inst) tm =
   if TVars.is_empty instT andalso Vars.is_empty inst then raise Same.SAME
   else inst_same (Unsynchronized.ref ~1) (no_indexesT instT, no_indexes inst) tm;
 
 fun instantiateT instT ty = Same.commit (instantiateT_same instT) ty;
 fun instantiate inst tm = Same.commit (instantiate_same inst) tm;
 
 end;
 
 
 (* zero var indexes *)
 
 fun zero_var_inst ins mk (v as ((x, i), X)) (inst, used) =
   let val (x', used') = Name.variant (if Name.is_bound x then "u" else x) used
   in if x = x' andalso i = 0 then (inst, used') else (ins (v, mk ((x', 0), X)) inst, used') end;
 
 fun zero_var_indexes_inst used ts =
   let
     val (instT, _) =
       (TVars.empty, used) |> TVars.fold (zero_var_inst TVars.add TVar o #1)
-        ((fold o fold_types o fold_atyps) (fn TVar v =>
-          TVars.add (v, ()) | _ => I) ts TVars.empty);
+        (TVars.build (ts |> (fold o fold_types o fold_atyps)
+          (fn TVar v => TVars.add (v, ()) | _ => I)));
     val (inst, _) =
       (Vars.empty, used) |> Vars.fold (zero_var_inst Vars.add Var o #1)
-        ((fold o fold_aterms) (fn Var (xi, T) =>
-          Vars.add ((xi, instantiateT instT T), ()) | _ => I) ts Vars.empty);
+        (Vars.build (ts |> (fold o fold_aterms)
+          (fn Var (xi, T) => Vars.add ((xi, instantiateT instT T), ()) | _ => I)));
   in (instT, inst) end;
 
 fun zero_var_indexes_list ts = map (instantiate (zero_var_indexes_inst Name.context ts)) ts;
 val zero_var_indexes = singleton zero_var_indexes_list;
 
 end;
diff --git a/src/Pure/theory.ML b/src/Pure/theory.ML
--- a/src/Pure/theory.ML
+++ b/src/Pure/theory.ML
@@ -1,342 +1,342 @@
 (*  Title:      Pure/theory.ML
     Author:     Lawrence C Paulson and Markus Wenzel
 
 Logical theory content: axioms, definitions, and begin/end wrappers.
 *)
 
 signature THEORY =
 sig
   val parents_of: theory -> theory list
   val ancestors_of: theory -> theory list
   val nodes_of: theory -> theory list
   val setup: (theory -> theory) -> unit
   val local_setup: (Proof.context -> Proof.context) -> unit
   val install_pure: theory -> unit
   val get_pure: unit -> theory
   val get_pure_bootstrap: unit -> theory
   val get_markup: theory -> Markup.T
   val check: {long: bool} -> Proof.context -> string * Position.T -> theory
   val axiom_table: theory -> term Name_Space.table
   val axiom_space: theory -> Name_Space.T
   val all_axioms_of: theory -> (string * term) list
   val defs_of: theory -> Defs.T
   val at_begin: (theory -> theory option) -> theory -> theory
   val at_end: (theory -> theory option) -> theory -> theory
   val join_theory: theory list -> theory
   val begin_theory: string * Position.T -> theory list -> theory
   val end_theory: theory -> theory
   val add_axiom: Proof.context -> binding * term -> theory -> theory
   val const_dep: theory -> string * typ -> Defs.entry
   val type_dep: string * typ list -> Defs.entry
   val add_deps: Defs.context -> string -> Defs.entry -> Defs.entry list -> theory -> theory
   val add_deps_global: string -> Defs.entry -> Defs.entry list -> theory -> theory
   val add_def: Defs.context -> bool -> bool -> binding * term -> theory -> theory
   val specify_const: (binding * typ) * mixfix -> theory -> term * theory
   val check_overloading: Proof.context -> bool -> string * typ -> unit
 end
 
 structure Theory: THEORY =
 struct
 
 
 (** theory context operations **)
 
 val parents_of = Context.parents_of;
 val ancestors_of = Context.ancestors_of;
 fun nodes_of thy = thy :: ancestors_of thy;
 
 fun setup f = Context.>> (Context.map_theory f);
 fun local_setup f = Context.>> (Context.map_proof f);
 
 
 (* implicit theory Pure *)
 
 val pure: theory Single_Assignment.var = Single_Assignment.var "pure";
 
 fun install_pure thy = Single_Assignment.assign pure thy;
 
 fun get_pure () =
   (case Single_Assignment.peek pure of
     SOME thy => thy
   | NONE => raise Fail "Theory Pure not present");
 
 fun get_pure_bootstrap () =
   (case Single_Assignment.peek pure of
     SOME thy => thy
   | NONE => Context.the_global_context ());
 
 
 
 (** datatype thy **)
 
 type wrapper = (theory -> theory option) * stamp;
 
 fun apply_wrappers (wrappers: wrapper list) =
   perhaps (perhaps_loop (perhaps_apply (map fst wrappers)));
 
 datatype thy = Thy of
  {pos: Position.T,
   id: serial,
   axioms: term Name_Space.table,
   defs: Defs.T,
   wrappers: wrapper list * wrapper list};
 
 fun make_thy (pos, id, axioms, defs, wrappers) =
   Thy {pos = pos, id = id, axioms = axioms, defs = defs, wrappers = wrappers};
 
 structure Thy = Theory_Data'
 (
   type T = thy;
   val extend = I;
   val empty = make_thy (Position.none, 0, Name_Space.empty_table Markup.axiomN, Defs.empty, ([], []));
   fun merge old_thys (thy1, thy2) =
     let
       val Thy {pos, id, axioms = axioms1, defs = defs1, wrappers = (bgs1, ens1)} = thy1;
       val Thy {pos = _, id = _, axioms = axioms2, defs = defs2, wrappers = (bgs2, ens2)} = thy2;
 
       val axioms' = Name_Space.merge_tables (axioms1, axioms2);
       val defs' = Defs.merge (Defs.global_context (fst old_thys)) (defs1, defs2);
       val bgs' = Library.merge (eq_snd op =) (bgs1, bgs2);
       val ens' = Library.merge (eq_snd op =) (ens1, ens2);
     in make_thy (pos, id, axioms', defs', (bgs', ens')) end;
 );
 
 fun rep_theory thy = Thy.get thy |> (fn Thy args => args);
 
 fun map_thy f = Thy.map (fn (Thy {pos, id, axioms, defs, wrappers}) =>
   make_thy (f (pos, id, axioms, defs, wrappers)));
 
 fun map_axioms f =
   map_thy (fn (pos, id, axioms, defs, wrappers) => (pos, id, f axioms, defs, wrappers));
 
 fun map_defs f =
   map_thy (fn (pos, id, axioms, defs, wrappers) => (pos, id, axioms, f defs, wrappers));
 
 fun map_wrappers f =
   map_thy (fn (pos, id, axioms, defs, wrappers) => (pos, id, axioms, defs, f wrappers));
 
 
 (* entity markup *)
 
 fun theory_markup def name id pos =
   if id = 0 then Markup.empty
   else Position.make_entity_markup def id Markup.theoryN (name, pos);
 
 fun init_markup (name, pos) thy =
   let
     val id = serial ();
     val _ = Context_Position.reports_global thy [(pos, theory_markup true name id pos)];
   in map_thy (fn (_, _, axioms, defs, wrappers) => (pos, id, axioms, defs, wrappers)) thy end;
 
 fun get_markup thy =
   let val {pos, id, ...} = rep_theory thy
   in theory_markup false (Context.theory_long_name thy) id pos end;
 
 fun check long ctxt (name, pos) =
   let
     val thy = Proof_Context.theory_of ctxt;
     val thy' =
       Context.get_theory long thy name
         handle ERROR msg =>
           let
             val completion_report =
               Completion.make_report (name, pos)
                 (fn completed =>
                   map (Context.theory_name' long) (ancestors_of thy)
                   |> filter (completed o Long_Name.base_name)
                   |> sort_strings
                   |> map (fn a => (a, (Markup.theoryN, a))));
           in error (msg ^ Position.here pos ^ completion_report) end;
     val _ = Context_Position.report ctxt pos (get_markup thy');
   in thy' end;
 
 
 (* basic operations *)
 
 val axiom_table = #axioms o rep_theory;
 val axiom_space = Name_Space.space_of_table o axiom_table;
 
 val all_axioms_of = Name_Space.dest_table o axiom_table;
 
 val defs_of = #defs o rep_theory;
 
 
 (* join theory *)
 
 fun join_theory [] = raise List.Empty
   | join_theory [thy] = thy
   | join_theory thys = foldl1 Context.join_thys thys;
 
 
 (* begin/end theory *)
 
 val begin_wrappers = rev o #1 o #wrappers o rep_theory;
 val end_wrappers = rev o #2 o #wrappers o rep_theory;
 
 fun at_begin f = map_wrappers (apfst (cons (f, stamp ())));
 fun at_end f = map_wrappers (apsnd (cons (f, stamp ())));
 
 fun begin_theory (name, pos) imports =
   if name = Context.PureN then
     (case imports of
       [thy] => init_markup (name, pos) thy
     | _ => error "Bad bootstrapping of theory Pure")
   else
     let
       val thy = Context.begin_thy name imports;
       val wrappers = begin_wrappers thy;
     in
       thy
       |> init_markup (name, pos)
       |> Sign.init_naming
       |> Sign.local_path
       |> apply_wrappers wrappers
       |> tap (Syntax.force_syntax o Sign.syn_of)
     end;
 
 fun end_theory thy =
   thy
   |> apply_wrappers (end_wrappers thy)
   |> Sign.change_check
   |> Context.finish_thy;
 
 
 
 (** primitive specifications **)
 
 (* raw axioms *)
 
 fun cert_axm ctxt (b, raw_tm) =
   let
     val thy = Proof_Context.theory_of ctxt;
     val t = Sign.cert_prop thy raw_tm
       handle TYPE (msg, _, _) => error msg
         | TERM (msg, _) => error msg;
     val _ = Term.no_dummy_patterns t handle TERM (msg, _) => error msg;
 
     val bad_sorts =
       rev ((fold_types o fold_atyps_sorts) (fn (_, []) => I | (T, _) => insert (op =) T) t []);
     val _ = null bad_sorts orelse
       error ("Illegal sort constraints in primitive specification: " ^
         commas (map (Syntax.string_of_typ (Config.put show_sorts true ctxt)) bad_sorts));
   in (b, Sign.no_vars ctxt t) end
   handle ERROR msg => cat_error msg ("The error(s) above occurred in axiom " ^ Binding.print b);
 
 fun add_axiom ctxt raw_axm thy = thy |> map_axioms (fn axioms =>
   let
     val axm = apsnd Logic.varify_global (cert_axm ctxt raw_axm);
     val context = ctxt
       |> Sign.inherit_naming thy
       |> Context_Position.set_visible_generic false;
     val (_, axioms') = Name_Space.define context true axm axioms;
   in axioms' end);
 
 
 (* dependencies *)
 
 fun const_dep thy (c, T) = ((Defs.Const, c), Sign.const_typargs thy (c, T));
 fun type_dep (c, args) = ((Defs.Type, c), args);
 
 fun dependencies (context as (ctxt, _)) unchecked def description lhs rhs =
   let
     fun prep (item, args) =
       (case fold Term.add_tvarsT args [] of
         [] => (item, map Logic.varifyT_global args)
       | vs => raise TYPE ("Illegal schematic type variable(s)", map TVar vs, []));
 
-    val lhs_vars = fold Term_Subst.add_tfreesT (snd lhs) Term_Subst.TFrees.empty;
+    val lhs_vars = Term_Subst.TFrees.build (snd lhs |> fold Term_Subst.add_tfreesT);
     val rhs_extras =
       fold (fn (_, args) => args |> (fold o Term.fold_atyps) (fn TFree v =>
         if Term_Subst.TFrees.defined lhs_vars v then I else insert (op =) v)) rhs [];
     val _ =
       if null rhs_extras then ()
       else error ("Specification depends on extra type variables: " ^
         commas_quote (map (Syntax.string_of_typ ctxt o TFree) rhs_extras) ^
         "\nThe error(s) above occurred in " ^ quote description);
   in Defs.define context unchecked def description (prep lhs) (map prep rhs) end;
 
 fun cert_entry thy ((Defs.Const, c), args) =
       Sign.cert_term thy (Const (c, Sign.const_instance thy (c, args)))
       |> dest_Const |> const_dep thy
   | cert_entry thy ((Defs.Type, c), args) =
       Sign.certify_typ thy (Type (c, args)) |> dest_Type |> type_dep;
 
 fun add_deps context a raw_lhs raw_rhs thy =
   let
     val (lhs as ((_, lhs_name), _)) :: rhs = map (cert_entry thy) (raw_lhs :: raw_rhs);
     val description = if a = "" then lhs_name ^ " axiom" else a;
   in thy |> map_defs (dependencies context false NONE description lhs rhs) end;
 
 fun add_deps_global a x y thy =
   add_deps (Defs.global_context thy) a x y thy;
 
 fun specify_const decl thy =
   let val (t, thy') = Sign.declare_const_global decl thy;
   in (t, add_deps_global "" (const_dep thy' (dest_Const t)) [] thy') end;
 
 
 (* overloading *)
 
 fun check_overloading ctxt overloaded (c, T) =
   let
     val thy = Proof_Context.theory_of ctxt;
 
     val declT = Sign.the_const_constraint thy c
       handle TYPE (msg, _, _) => error msg;
     val T' = Logic.varifyT_global T;
 
     fun message sorts txt =
       [Pretty.block [Pretty.str "Specification of constant ",
         Pretty.str c, Pretty.str " ::", Pretty.brk 1,
         Pretty.quote (Syntax.pretty_typ (Config.put show_sorts sorts ctxt) T)],
         Pretty.str txt] |> Pretty.chunks |> Pretty.string_of;
   in
     if Sign.typ_instance thy (declT, T') then ()
     else if Type.raw_instance (declT, T') then
       error (message true "imposes additional sort constraints on the constant declaration")
     else if overloaded then ()
     else
       error (message false "is strictly less general than the declared type (overloading required)")
   end;
 
 
 (* definitional axioms *)
 
 local
 
 fun check_def (context as (ctxt, _)) thy unchecked overloaded (b, tm) defs =
   let
     val name = Sign.full_name thy b;
     val ((lhs, rhs), _, _) =
       Primitive_Defs.dest_def ctxt
         {check_head = Term.is_Const,
          check_free_lhs = K true,
          check_free_rhs = K false,
          check_tfree = K false} tm
       handle TERM (msg, _) => error msg;
     val lhs_const = Term.dest_Const (Term.head_of lhs);
 
     val rhs_consts =
       fold_aterms (fn Const const => insert (op =) (const_dep thy const) | _ => I) rhs [];
     val rhs_types =
       (fold_types o fold_subtypes) (fn Type t => insert (op =) (type_dep t) | _ => I) rhs [];
     val rhs_deps = rhs_consts @ rhs_types;
 
     val _ = check_overloading ctxt overloaded lhs_const;
   in defs |> dependencies context unchecked (SOME name) name (const_dep thy lhs_const) rhs_deps end
   handle ERROR msg => cat_error msg (Pretty.string_of (Pretty.block
    [Pretty.str ("The error(s) above occurred in definition " ^ Binding.print b ^ ":"),
     Pretty.fbrk, Pretty.quote (Syntax.pretty_term ctxt tm)]));
 
 in
 
 fun add_def (context as (ctxt, _)) unchecked overloaded raw_axm thy =
   let val axm = cert_axm ctxt raw_axm in
     thy
     |> map_defs (check_def context thy unchecked overloaded axm)
     |> add_axiom ctxt axm
   end;
 
 end;
 
 end;
diff --git a/src/Pure/thm.ML b/src/Pure/thm.ML
--- a/src/Pure/thm.ML
+++ b/src/Pure/thm.ML
@@ -1,2373 +1,2373 @@
 (*  Title:      Pure/thm.ML
     Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     Author:     Makarius
 
 The very core of Isabelle's Meta Logic: certified types and terms,
 derivations, theorems, inference rules (including lifting and
 resolution), oracles.
 *)
 
 infix 0 RS RSN;
 
 signature BASIC_THM =
 sig
   type ctyp
   type cterm
   exception CTERM of string * cterm list
   type thm
   type conv = cterm -> thm
   exception THM of string * int * thm list
   val RSN: thm * (int * thm) -> thm
   val RS: thm * thm -> thm
 end;
 
 signature THM =
 sig
   include BASIC_THM
   (*certified types*)
   val typ_of: ctyp -> typ
   val global_ctyp_of: theory -> typ -> ctyp
   val ctyp_of: Proof.context -> typ -> ctyp
   val dest_ctyp: ctyp -> ctyp list
   val dest_ctypN: int -> ctyp -> ctyp
   val dest_ctyp0: ctyp -> ctyp
   val dest_ctyp1: ctyp -> ctyp
   val make_ctyp: ctyp -> ctyp list -> ctyp
   (*certified terms*)
   val term_of: cterm -> term
   val typ_of_cterm: cterm -> typ
   val ctyp_of_cterm: cterm -> ctyp
   val maxidx_of_cterm: cterm -> int
   val global_cterm_of: theory -> term -> cterm
   val cterm_of: Proof.context -> term -> cterm
   val renamed_term: term -> cterm -> cterm
   val dest_comb: cterm -> cterm * cterm
   val dest_fun: cterm -> cterm
   val dest_arg: cterm -> cterm
   val dest_fun2: cterm -> cterm
   val dest_arg1: cterm -> cterm
   val dest_abs: string option -> cterm -> cterm * cterm
   val rename_tvar: indexname -> ctyp -> ctyp
   val var: indexname * ctyp -> cterm
   val apply: cterm -> cterm -> cterm
   val lambda_name: string * cterm -> cterm -> cterm
   val lambda: cterm -> cterm -> cterm
   val adjust_maxidx_cterm: int -> cterm -> cterm
   val incr_indexes_cterm: int -> cterm -> cterm
   val match: cterm * cterm ->
     ((indexname * sort) * ctyp) list * ((indexname * typ) * cterm) list
   val first_order_match: cterm * cterm ->
     ((indexname * sort) * ctyp) list * ((indexname * typ) * cterm) list
   (*theorems*)
   val fold_terms: (term -> 'a -> 'a) -> thm -> 'a -> 'a
   val fold_atomic_ctyps: (ctyp -> 'a -> 'a) -> thm -> 'a -> 'a
   val fold_atomic_cterms: (cterm -> 'a -> 'a) -> thm -> 'a -> 'a
   val terms_of_tpairs: (term * term) list -> term list
   val full_prop_of: thm -> term
   val theory_id: thm -> Context.theory_id
   val theory_name: thm -> string
   val maxidx_of: thm -> int
   val maxidx_thm: thm -> int -> int
   val shyps_of: thm -> sort Ord_List.T
   val hyps_of: thm -> term list
   val prop_of: thm -> term
   val tpairs_of: thm -> (term * term) list
   val concl_of: thm -> term
   val prems_of: thm -> term list
   val nprems_of: thm -> int
   val no_prems: thm -> bool
   val major_prem_of: thm -> term
   val cprop_of: thm -> cterm
   val cprem_of: thm -> int -> cterm
   val cconcl_of: thm -> cterm
   val cprems_of: thm -> cterm list
   val chyps_of: thm -> cterm list
   exception CONTEXT of string * ctyp list * cterm list * thm list * Context.generic option
   val theory_of_cterm: cterm -> theory
   val theory_of_thm: thm -> theory
   val trim_context_ctyp: ctyp -> ctyp
   val trim_context_cterm: cterm -> cterm
   val transfer_ctyp: theory -> ctyp -> ctyp
   val transfer_cterm: theory -> cterm -> cterm
   val transfer: theory -> thm -> thm
   val transfer': Proof.context -> thm -> thm
   val transfer'': Context.generic -> thm -> thm
   val join_transfer: theory -> thm -> thm
   val join_transfer_context: Proof.context * thm -> Proof.context * thm
   val renamed_prop: term -> thm -> thm
   val weaken: cterm -> thm -> thm
   val weaken_sorts: sort list -> cterm -> cterm
   val proof_bodies_of: thm list -> proof_body list
   val proof_body_of: thm -> proof_body
   val proof_of: thm -> proof
   val reconstruct_proof_of: thm -> Proofterm.proof
   val consolidate: thm list -> unit
   val expose_proofs: theory -> thm list -> unit
   val expose_proof: theory -> thm -> unit
   val future: thm future -> cterm -> thm
   val thm_deps: thm -> Proofterm.thm Ord_List.T
   val extra_shyps: thm -> sort list
   val strip_shyps: thm -> thm
   val derivation_closed: thm -> bool
   val derivation_name: thm -> string
   val derivation_id: thm -> Proofterm.thm_id option
   val raw_derivation_name: thm -> string
   val expand_name: thm -> Proofterm.thm_header -> string option
   val name_derivation: string * Position.T -> thm -> thm
   val close_derivation: Position.T -> thm -> thm
   val trim_context: thm -> thm
   val axiom: theory -> string -> thm
   val all_axioms_of: theory -> (string * thm) list
   val get_tags: thm -> Properties.T
   val map_tags: (Properties.T -> Properties.T) -> thm -> thm
   val norm_proof: thm -> thm
   val adjust_maxidx_thm: int -> thm -> thm
   (*type classes*)
   val the_classrel: theory -> class * class -> thm
   val the_arity: theory -> string * sort list * class -> thm
   val classrel_proof: theory -> class * class -> proof
   val arity_proof: theory -> string * sort list * class -> proof
   (*oracles*)
   val add_oracle: binding * ('a -> cterm) -> theory -> (string * ('a -> thm)) * theory
   val oracle_space: theory -> Name_Space.T
   val pretty_oracle: Proof.context -> string -> Pretty.T
   val extern_oracles: bool -> Proof.context -> (Markup.T * xstring) list
   val check_oracle: Proof.context -> xstring * Position.T -> string
   (*inference rules*)
   val assume: cterm -> thm
   val implies_intr: cterm -> thm -> thm
   val implies_elim: thm -> thm -> thm
   val forall_intr: cterm -> thm -> thm
   val forall_elim: cterm -> thm -> thm
   val reflexive: cterm -> thm
   val symmetric: thm -> thm
   val transitive: thm -> thm -> thm
   val beta_conversion: bool -> conv
   val eta_conversion: conv
   val eta_long_conversion: conv
   val abstract_rule: string -> cterm -> thm -> thm
   val combination: thm -> thm -> thm
   val equal_intr: thm -> thm -> thm
   val equal_elim: thm -> thm -> thm
   val solve_constraints: thm -> thm
   val flexflex_rule: Proof.context option -> thm -> thm Seq.seq
   val generalize: Symtab.set * Symtab.set -> int -> thm -> thm
   val generalize_cterm: Symtab.set * Symtab.set -> int -> cterm -> cterm
   val generalize_ctyp: Symtab.set -> int -> ctyp -> ctyp
   val instantiate: ((indexname * sort) * ctyp) list * ((indexname * typ) * cterm) list ->
     thm -> thm
   val instantiate_cterm: ((indexname * sort) * ctyp) list * ((indexname * typ) * cterm) list ->
     cterm -> cterm
   val trivial: cterm -> thm
   val of_class: ctyp * class -> thm
   val unconstrainT: thm -> thm
   val varifyT_global': (string * sort) list -> thm -> ((string * sort) * indexname) list * thm
   val varifyT_global: thm -> thm
   val legacy_freezeT: thm -> thm
   val plain_prop_of: thm -> term
   val dest_state: thm * int -> (term * term) list * term list * term * term
   val lift_rule: cterm -> thm -> thm
   val incr_indexes: int -> thm -> thm
   val assumption: Proof.context option -> int -> thm -> thm Seq.seq
   val eq_assumption: int -> thm -> thm
   val rotate_rule: int -> int -> thm -> thm
   val permute_prems: int -> int -> thm -> thm
   val bicompose: Proof.context option -> {flatten: bool, match: bool, incremented: bool} ->
     bool * thm * int -> int -> thm -> thm Seq.seq
   val biresolution: Proof.context option -> bool -> (bool * thm) list -> int -> thm -> thm Seq.seq
   val thynames_of_arity: theory -> string * class -> string list
   val add_classrel: thm -> theory -> theory
   val add_arity: thm -> theory -> theory
 end;
 
 structure Thm: THM =
 struct
 
 (*** Certified terms and types ***)
 
 (** certified types **)
 
 datatype ctyp = Ctyp of {cert: Context.certificate, T: typ, maxidx: int, sorts: sort Ord_List.T};
 
 fun typ_of (Ctyp {T, ...}) = T;
 
 fun global_ctyp_of thy raw_T =
   let
     val T = Sign.certify_typ thy raw_T;
     val maxidx = Term.maxidx_of_typ T;
     val sorts = Sorts.insert_typ T [];
   in Ctyp {cert = Context.Certificate thy, T = T, maxidx = maxidx, sorts = sorts} end;
 
 val ctyp_of = global_ctyp_of o Proof_Context.theory_of;
 
 fun dest_ctyp (Ctyp {cert, T = Type (_, Ts), maxidx, sorts}) =
       map (fn T => Ctyp {cert = cert, T = T, maxidx = maxidx, sorts = sorts}) Ts
   | dest_ctyp cT = raise TYPE ("dest_ctyp", [typ_of cT], []);
 
 fun dest_ctypN n (Ctyp {cert, T, maxidx, sorts}) =
   let fun err () = raise TYPE ("dest_ctypN", [T], []) in
     (case T of
       Type (_, Ts) =>
         Ctyp {cert = cert, T = nth Ts n handle General.Subscript => err (),
           maxidx = maxidx, sorts = sorts}
     | _ => err ())
   end;
 
 val dest_ctyp0 = dest_ctypN 0;
 val dest_ctyp1 = dest_ctypN 1;
 
 fun join_certificate_ctyp (Ctyp {cert, ...}) cert0 = Context.join_certificate (cert0, cert);
 fun union_sorts_ctyp (Ctyp {sorts, ...}) sorts0 = Sorts.union sorts0 sorts;
 fun maxidx_ctyp (Ctyp {maxidx, ...}) maxidx0 = Int.max (maxidx0, maxidx);
 
 fun make_ctyp (Ctyp {cert, T, maxidx = _, sorts = _}) cargs =
   let
     val As = map typ_of cargs;
     fun err () = raise TYPE ("make_ctyp", T :: As, []);
   in
     (case T of
       Type (a, args) =>
         Ctyp {
           cert = fold join_certificate_ctyp cargs cert,
           maxidx = fold maxidx_ctyp cargs ~1,
           sorts = fold union_sorts_ctyp cargs [],
           T = if length args = length cargs then Type (a, As) else err ()}
     | _ => err ())
   end;
 
 
 
 (** certified terms **)
 
 (*certified terms with checked typ, maxidx, and sorts*)
 datatype cterm =
   Cterm of {cert: Context.certificate, t: term, T: typ, maxidx: int, sorts: sort Ord_List.T};
 
 exception CTERM of string * cterm list;
 
 fun term_of (Cterm {t, ...}) = t;
 
 fun typ_of_cterm (Cterm {T, ...}) = T;
 
 fun ctyp_of_cterm (Cterm {cert, T, maxidx, sorts, ...}) =
   Ctyp {cert = cert, T = T, maxidx = maxidx, sorts = sorts};
 
 fun maxidx_of_cterm (Cterm {maxidx, ...}) = maxidx;
 
 fun global_cterm_of thy tm =
   let
     val (t, T, maxidx) = Sign.certify_term thy tm;
     val sorts = Sorts.insert_term t [];
   in Cterm {cert = Context.Certificate thy, t = t, T = T, maxidx = maxidx, sorts = sorts} end;
 
 val cterm_of = global_cterm_of o Proof_Context.theory_of;
 
 fun join_certificate0 (Cterm {cert = cert1, ...}, Cterm {cert = cert2, ...}) =
   Context.join_certificate (cert1, cert2);
 
 fun renamed_term t' (Cterm {cert, t, T, maxidx, sorts}) =
   if t aconv t' then Cterm {cert = cert, t = t', T = T, maxidx = maxidx, sorts = sorts}
   else raise TERM ("renamed_term: terms disagree", [t, t']);
 
 
 (* destructors *)
 
 fun dest_comb (Cterm {t = c $ a, T, cert, maxidx, sorts}) =
       let val A = Term.argument_type_of c 0 in
         (Cterm {t = c, T = A --> T, cert = cert, maxidx = maxidx, sorts = sorts},
          Cterm {t = a, T = A, cert = cert, maxidx = maxidx, sorts = sorts})
       end
   | dest_comb ct = raise CTERM ("dest_comb", [ct]);
 
 fun dest_fun (Cterm {t = c $ _, T, cert, maxidx, sorts}) =
       let val A = Term.argument_type_of c 0
       in Cterm {t = c, T = A --> T, cert = cert, maxidx = maxidx, sorts = sorts} end
   | dest_fun ct = raise CTERM ("dest_fun", [ct]);
 
 fun dest_arg (Cterm {t = c $ a, T = _, cert, maxidx, sorts}) =
       let val A = Term.argument_type_of c 0
       in Cterm {t = a, T = A, cert = cert, maxidx = maxidx, sorts = sorts} end
   | dest_arg ct = raise CTERM ("dest_arg", [ct]);
 
 
 fun dest_fun2 (Cterm {t = c $ _ $ _, T, cert, maxidx, sorts}) =
       let
         val A = Term.argument_type_of c 0;
         val B = Term.argument_type_of c 1;
       in Cterm {t = c, T = A --> B --> T, cert = cert, maxidx = maxidx, sorts = sorts} end
   | dest_fun2 ct = raise CTERM ("dest_fun2", [ct]);
 
 fun dest_arg1 (Cterm {t = c $ a $ _, T = _, cert, maxidx, sorts}) =
       let val A = Term.argument_type_of c 0
       in Cterm {t = a, T = A, cert = cert, maxidx = maxidx, sorts = sorts} end
   | dest_arg1 ct = raise CTERM ("dest_arg1", [ct]);
 
 fun dest_abs a (Cterm {t = Abs (x, T, t), T = Type ("fun", [_, U]), cert, maxidx, sorts}) =
       let val (y', t') = Term.dest_abs (the_default x a, T, t) in
         (Cterm {t = Free (y', T), T = T, cert = cert, maxidx = maxidx, sorts = sorts},
           Cterm {t = t', T = U, cert = cert, maxidx = maxidx, sorts = sorts})
       end
   | dest_abs _ ct = raise CTERM ("dest_abs", [ct]);
 
 
 (* constructors *)
 
 fun rename_tvar (a, i) (Ctyp {cert, T, maxidx, sorts}) =
   let
     val S =
       (case T of
         TFree (_, S) => S
       | TVar (_, S) => S
       | _ => raise TYPE ("rename_tvar: no variable", [T], []));
     val _ = if i < 0 then raise TYPE ("rename_tvar: bad index", [TVar ((a, i), S)], []) else ();
   in Ctyp {cert = cert, T = TVar ((a, i), S), maxidx = Int.max (i, maxidx), sorts = sorts} end;
 
 fun var ((x, i), Ctyp {cert, T, maxidx, sorts}) =
   if i < 0 then raise TERM ("var: bad index", [Var ((x, i), T)])
   else Cterm {cert = cert, t = Var ((x, i), T), T = T, maxidx = Int.max (i, maxidx), sorts = sorts};
 
 fun apply
   (cf as Cterm {t = f, T = Type ("fun", [dty, rty]), maxidx = maxidx1, sorts = sorts1, ...})
   (cx as Cterm {t = x, T, maxidx = maxidx2, sorts = sorts2, ...}) =
     if T = dty then
       Cterm {cert = join_certificate0 (cf, cx),
         t = f $ x,
         T = rty,
         maxidx = Int.max (maxidx1, maxidx2),
         sorts = Sorts.union sorts1 sorts2}
       else raise CTERM ("apply: types don't agree", [cf, cx])
   | apply cf cx = raise CTERM ("apply: first arg is not a function", [cf, cx]);
 
 fun lambda_name
   (x, ct1 as Cterm {t = t1, T = T1, maxidx = maxidx1, sorts = sorts1, ...})
   (ct2 as Cterm {t = t2, T = T2, maxidx = maxidx2, sorts = sorts2, ...}) =
     let val t = Term.lambda_name (x, t1) t2 in
       Cterm {cert = join_certificate0 (ct1, ct2),
         t = t, T = T1 --> T2,
         maxidx = Int.max (maxidx1, maxidx2),
         sorts = Sorts.union sorts1 sorts2}
     end;
 
 fun lambda t u = lambda_name ("", t) u;
 
 
 (* indexes *)
 
 fun adjust_maxidx_cterm i (ct as Cterm {cert, t, T, maxidx, sorts}) =
   if maxidx = i then ct
   else if maxidx < i then
     Cterm {maxidx = i, cert = cert, t = t, T = T, sorts = sorts}
   else
     Cterm {maxidx = Int.max (maxidx_of_term t, i), cert = cert, t = t, T = T, sorts = sorts};
 
 fun incr_indexes_cterm i (ct as Cterm {cert, t, T, maxidx, sorts}) =
   if i < 0 then raise CTERM ("negative increment", [ct])
   else if i = 0 then ct
   else Cterm {cert = cert, t = Logic.incr_indexes ([], [], i) t,
     T = Logic.incr_tvar i T, maxidx = maxidx + i, sorts = sorts};
 
 
 
 (*** Derivations and Theorems ***)
 
 (* sort constraints *)
 
 type constraint = {theory: theory, typ: typ, sort: sort};
 
 local
 
 val constraint_ord : constraint ord =
   Context.theory_id_ord o apply2 (Context.theory_id o #theory)
   ||| Term_Ord.typ_ord o apply2 #typ
   ||| Term_Ord.sort_ord o apply2 #sort;
 
 val smash_atyps =
   map_atyps (fn TVar (_, S) => Term.aT S | TFree (_, S) => Term.aT S | T => T);
 
 in
 
 val union_constraints = Ord_List.union constraint_ord;
 
 fun insert_constraints thy (T, S) =
   let
     val ignored =
       S = [] orelse
         (case T of
           TFree (_, S') => S = S'
         | TVar (_, S') => S = S'
         | _ => false);
   in
     if ignored then I
     else Ord_List.insert constraint_ord {theory = thy, typ = smash_atyps T, sort = S}
   end;
 
 fun insert_constraints_env thy env =
   let
     val tyenv = Envir.type_env env;
     fun insert ([], _) = I
       | insert (S, T) = insert_constraints thy (Envir.norm_type tyenv T, S);
   in tyenv |> Vartab.fold (insert o #2) end;
 
 end;
 
 
 (* datatype thm *)
 
 datatype thm = Thm of
  deriv *                        (*derivation*)
  {cert: Context.certificate,    (*background theory certificate*)
   tags: Properties.T,           (*additional annotations/comments*)
   maxidx: int,                  (*maximum index of any Var or TVar*)
   constraints: constraint Ord_List.T,  (*implicit proof obligations for sort constraints*)
   shyps: sort Ord_List.T,       (*sort hypotheses*)
   hyps: term Ord_List.T,        (*hypotheses*)
   tpairs: (term * term) list,   (*flex-flex pairs*)
   prop: term}                   (*conclusion*)
 and deriv = Deriv of
  {promises: (serial * thm future) Ord_List.T,
   body: Proofterm.proof_body};
 
 type conv = cterm -> thm;
 
 (*errors involving theorems*)
 exception THM of string * int * thm list;
 
 fun rep_thm (Thm (_, args)) = args;
 
 fun fold_terms f (Thm (_, {tpairs, prop, hyps, ...})) =
   fold (fn (t, u) => f t #> f u) tpairs #> f prop #> fold f hyps;
 
 fun fold_atomic_ctyps f (th as Thm (_, {cert, maxidx, shyps, ...})) =
   let fun ctyp T = Ctyp {cert = cert, T = T, maxidx = maxidx, sorts = shyps}
   in (fold_terms o fold_types o fold_atyps) (f o ctyp) th end;
 
 fun fold_atomic_cterms f (th as Thm (_, {cert, maxidx, shyps, ...})) =
   let fun cterm t T = Cterm {cert = cert, t = t, T = T, maxidx = maxidx, sorts = shyps} in
     (fold_terms o fold_aterms)
       (fn t as Const (_, T) => f (cterm t T)
         | t as Free (_, T) => f (cterm t T)
         | t as Var (_, T) => f (cterm t T)
         | _ => I) th
   end;
 
 
 fun terms_of_tpairs tpairs = fold_rev (fn (t, u) => cons t o cons u) tpairs [];
 
 fun eq_tpairs ((t, u), (t', u')) = t aconv t' andalso u aconv u';
 fun union_tpairs ts us = Library.merge eq_tpairs (ts, us);
 val maxidx_tpairs = fold (fn (t, u) => Term.maxidx_term t #> Term.maxidx_term u);
 
 fun attach_tpairs tpairs prop =
   Logic.list_implies (map Logic.mk_equals tpairs, prop);
 
 fun full_prop_of (Thm (_, {tpairs, prop, ...})) = attach_tpairs tpairs prop;
 
 
 val union_hyps = Ord_List.union Term_Ord.fast_term_ord;
 val insert_hyps = Ord_List.insert Term_Ord.fast_term_ord;
 val remove_hyps = Ord_List.remove Term_Ord.fast_term_ord;
 
 fun join_certificate1 (Cterm {cert = cert1, ...}, Thm (_, {cert = cert2, ...})) =
   Context.join_certificate (cert1, cert2);
 
 fun join_certificate2 (Thm (_, {cert = cert1, ...}), Thm (_, {cert = cert2, ...})) =
   Context.join_certificate (cert1, cert2);
 
 
 (* basic components *)
 
 val cert_of = #cert o rep_thm;
 val theory_id = Context.certificate_theory_id o cert_of;
 val theory_name = Context.theory_id_name o theory_id;
 
 val maxidx_of = #maxidx o rep_thm;
 fun maxidx_thm th i = Int.max (maxidx_of th, i);
 val shyps_of = #shyps o rep_thm;
 val hyps_of = #hyps o rep_thm;
 val prop_of = #prop o rep_thm;
 val tpairs_of = #tpairs o rep_thm;
 
 val concl_of = Logic.strip_imp_concl o prop_of;
 val prems_of = Logic.strip_imp_prems o prop_of;
 val nprems_of = Logic.count_prems o prop_of;
 fun no_prems th = nprems_of th = 0;
 
 fun major_prem_of th =
   (case prems_of th of
     prem :: _ => Logic.strip_assums_concl prem
   | [] => raise THM ("major_prem_of: rule with no premises", 0, [th]));
 
 fun cprop_of (Thm (_, {cert, maxidx, shyps, prop, ...})) =
   Cterm {cert = cert, maxidx = maxidx, T = propT, t = prop, sorts = shyps};
 
 fun cprem_of (th as Thm (_, {cert, maxidx, shyps, prop, ...})) i =
   Cterm {cert = cert, maxidx = maxidx, T = propT, sorts = shyps,
     t = Logic.nth_prem (i, prop) handle TERM _ => raise THM ("cprem_of", i, [th])};
 
 fun cconcl_of (th as Thm (_, {cert, maxidx, shyps, ...})) =
   Cterm {cert = cert, maxidx = maxidx, T = propT, sorts = shyps, t = concl_of th};
 
 fun cprems_of (th as Thm (_, {cert, maxidx, shyps, ...})) =
   map (fn t => Cterm {cert = cert, maxidx = maxidx, T = propT, sorts = shyps, t = t})
     (prems_of th);
 
 fun chyps_of (Thm (_, {cert, shyps, hyps, ...})) =
   map (fn t => Cterm {cert = cert, maxidx = ~1, T = propT, sorts = shyps, t = t}) hyps;
 
 
 (* implicit theory context *)
 
 exception CONTEXT of string * ctyp list * cterm list * thm list * Context.generic option;
 
 fun theory_of_cterm (ct as Cterm {cert, ...}) =
   Context.certificate_theory cert
     handle ERROR msg => raise CONTEXT (msg, [], [ct], [], NONE);
 
 fun theory_of_thm th =
   Context.certificate_theory (cert_of th)
     handle ERROR msg => raise CONTEXT (msg, [], [], [th], NONE);
 
 fun trim_context_ctyp cT =
   (case cT of
     Ctyp {cert = Context.Certificate_Id _, ...} => cT
   | Ctyp {cert = Context.Certificate thy, T, maxidx, sorts} =>
       Ctyp {cert = Context.Certificate_Id (Context.theory_id thy),
         T = T, maxidx = maxidx, sorts = sorts});
 
 fun trim_context_cterm ct =
   (case ct of
     Cterm {cert = Context.Certificate_Id _, ...} => ct
   | Cterm {cert = Context.Certificate thy, t, T, maxidx, sorts} =>
       Cterm {cert = Context.Certificate_Id (Context.theory_id thy),
         t = t, T = T, maxidx = maxidx, sorts = sorts});
 
 fun trim_context_thm th =
   (case th of
     Thm (_, {constraints = _ :: _, ...}) =>
       raise THM ("trim_context: pending sort constraints", 0, [th])
   | Thm (_, {cert = Context.Certificate_Id _, ...}) => th
   | Thm (der,
       {cert = Context.Certificate thy, tags, maxidx, constraints = [], shyps, hyps,
         tpairs, prop}) =>
       Thm (der,
        {cert = Context.Certificate_Id (Context.theory_id thy),
         tags = tags, maxidx = maxidx, constraints = [], shyps = shyps, hyps = hyps,
         tpairs = tpairs, prop = prop}));
 
 fun transfer_ctyp thy' cT =
   let
     val Ctyp {cert, T, maxidx, sorts} = cT;
     val _ =
       Context.subthy_id (Context.certificate_theory_id cert, Context.theory_id thy') orelse
         raise CONTEXT ("Cannot transfer: not a super theory", [cT], [], [],
           SOME (Context.Theory thy'));
     val cert' = Context.join_certificate (Context.Certificate thy', cert);
   in
     if Context.eq_certificate (cert, cert') then cT
     else Ctyp {cert = cert', T = T, maxidx = maxidx, sorts = sorts}
   end;
 
 fun transfer_cterm thy' ct =
   let
     val Cterm {cert, t, T, maxidx, sorts} = ct;
     val _ =
       Context.subthy_id (Context.certificate_theory_id cert, Context.theory_id thy') orelse
         raise CONTEXT ("Cannot transfer: not a super theory", [], [ct], [],
           SOME (Context.Theory thy'));
     val cert' = Context.join_certificate (Context.Certificate thy', cert);
   in
     if Context.eq_certificate (cert, cert') then ct
     else Cterm {cert = cert', t = t, T = T, maxidx = maxidx, sorts = sorts}
   end;
 
 fun transfer thy' th =
   let
     val Thm (der, {cert, tags, maxidx, constraints, shyps, hyps, tpairs, prop}) = th;
     val _ =
       Context.subthy_id (Context.certificate_theory_id cert, Context.theory_id thy') orelse
         raise CONTEXT ("Cannot transfer: not a super theory", [], [], [th],
           SOME (Context.Theory thy'));
     val cert' = Context.join_certificate (Context.Certificate thy', cert);
   in
     if Context.eq_certificate (cert, cert') then th
     else
       Thm (der,
        {cert = cert',
         tags = tags,
         maxidx = maxidx,
         constraints = constraints,
         shyps = shyps,
         hyps = hyps,
         tpairs = tpairs,
         prop = prop})
   end;
 
 val transfer' = transfer o Proof_Context.theory_of;
 val transfer'' = transfer o Context.theory_of;
 
 fun join_transfer thy th =
   (Context.subthy_id (theory_id th, Context.theory_id thy) ? transfer thy) th;
 
 fun join_transfer_context (ctxt, th) =
   if Context.subthy_id (theory_id th, Context.theory_id (Proof_Context.theory_of ctxt))
   then (ctxt, transfer' ctxt th)
   else (Context.raw_transfer (theory_of_thm th) ctxt, th);
 
 
 (* matching *)
 
 local
 
 fun gen_match match
     (ct1 as Cterm {t = t1, sorts = sorts1, ...},
      ct2 as Cterm {t = t2, sorts = sorts2, maxidx = maxidx2, ...}) =
   let
     val cert = join_certificate0 (ct1, ct2);
     val thy = Context.certificate_theory cert
       handle ERROR msg => raise CONTEXT (msg, [], [ct1, ct2], [], NONE);
     val (Tinsts, tinsts) = match thy (t1, t2) (Vartab.empty, Vartab.empty);
     val sorts = Sorts.union sorts1 sorts2;
     fun mk_cTinst ((a, i), (S, T)) =
       (((a, i), S), Ctyp {T = T, cert = cert, maxidx = maxidx2, sorts = sorts});
     fun mk_ctinst ((x, i), (U, t)) =
       let val T = Envir.subst_type Tinsts U in
         (((x, i), T), Cterm {t = t, T = T, cert = cert, maxidx = maxidx2, sorts = sorts})
       end;
   in (Vartab.fold (cons o mk_cTinst) Tinsts [], Vartab.fold (cons o mk_ctinst) tinsts []) end;
 
 in
 
 val match = gen_match Pattern.match;
 val first_order_match = gen_match Pattern.first_order_match;
 
 end;
 
 
 (*implicit alpha-conversion*)
 fun renamed_prop prop' (Thm (der, {cert, tags, maxidx, constraints, shyps, hyps, tpairs, prop})) =
   if prop aconv prop' then
     Thm (der, {cert = cert, tags = tags, maxidx = maxidx, constraints = constraints, shyps = shyps,
       hyps = hyps, tpairs = tpairs, prop = prop'})
   else raise TERM ("renamed_prop: props disagree", [prop, prop']);
 
 fun make_context ths NONE cert =
       (Context.Theory (Context.certificate_theory cert)
         handle ERROR msg => raise CONTEXT (msg, [], [], ths, NONE))
   | make_context ths (SOME ctxt) cert =
       let
         val thy_id = Context.certificate_theory_id cert;
         val thy_id' = Context.theory_id (Proof_Context.theory_of ctxt);
       in
         if Context.subthy_id (thy_id, thy_id') then Context.Proof ctxt
         else raise CONTEXT ("Bad context", [], [], ths, SOME (Context.Proof ctxt))
       end;
 
 fun make_context_certificate ths opt_ctxt cert =
   let
     val context = make_context ths opt_ctxt cert;
     val cert' = Context.Certificate (Context.theory_of context);
   in (context, cert') end;
 
 (*explicit weakening: maps |- B to A |- B*)
 fun weaken raw_ct th =
   let
     val ct as Cterm {t = A, T, sorts, maxidx = maxidxA, ...} = adjust_maxidx_cterm ~1 raw_ct;
     val Thm (der, {tags, maxidx, constraints, shyps, hyps, tpairs, prop, ...}) = th;
   in
     if T <> propT then
       raise THM ("weaken: assumptions must have type prop", 0, [])
     else if maxidxA <> ~1 then
       raise THM ("weaken: assumptions may not contain schematic variables", maxidxA, [])
     else
       Thm (der,
        {cert = join_certificate1 (ct, th),
         tags = tags,
         maxidx = maxidx,
         constraints = constraints,
         shyps = Sorts.union sorts shyps,
         hyps = insert_hyps A hyps,
         tpairs = tpairs,
         prop = prop})
   end;
 
 fun weaken_sorts raw_sorts ct =
   let
     val Cterm {cert, t, T, maxidx, sorts} = ct;
     val thy = theory_of_cterm ct;
     val more_sorts = Sorts.make (map (Sign.certify_sort thy) raw_sorts);
     val sorts' = Sorts.union sorts more_sorts;
   in Cterm {cert = cert, t = t, T = T, maxidx = maxidx, sorts = sorts'} end;
 
 
 
 (** derivations and promised proofs **)
 
 fun make_deriv promises oracles thms proof =
   Deriv {promises = promises, body = PBody {oracles = oracles, thms = thms, proof = proof}};
 
 val empty_deriv = make_deriv [] [] [] MinProof;
 
 
 (* inference rules *)
 
 val promise_ord: (serial * thm future) ord = fn ((i, _), (j, _)) => int_ord (j, i);
 
 fun bad_proofs i =
   error ("Illegal level of detail for proof objects: " ^ string_of_int i);
 
 fun deriv_rule2 f
     (Deriv {promises = ps1, body = PBody {oracles = oracles1, thms = thms1, proof = prf1}})
     (Deriv {promises = ps2, body = PBody {oracles = oracles2, thms = thms2, proof = prf2}}) =
   let
     val ps = Ord_List.union promise_ord ps1 ps2;
     val oracles = Proofterm.unions_oracles [oracles1, oracles2];
     val thms = Proofterm.unions_thms [thms1, thms2];
     val prf =
       (case ! Proofterm.proofs of
         2 => f prf1 prf2
       | 1 => MinProof
       | 0 => MinProof
       | i => bad_proofs i);
   in make_deriv ps oracles thms prf end;
 
 fun deriv_rule1 f = deriv_rule2 (K f) empty_deriv;
 
 fun deriv_rule0 make_prf =
   if ! Proofterm.proofs <= 1 then empty_deriv
   else deriv_rule1 I (make_deriv [] [] [] (make_prf ()));
 
 fun deriv_rule_unconditional f (Deriv {promises, body = PBody {oracles, thms, proof}}) =
   make_deriv promises oracles thms (f proof);
 
 
 (* fulfilled proofs *)
 
 fun raw_promises_of (Thm (Deriv {promises, ...}, _)) = promises;
 
 fun join_promises [] = ()
   | join_promises promises = join_promises_of (Future.joins (map snd promises))
 and join_promises_of thms = join_promises (Ord_List.make promise_ord (maps raw_promises_of thms));
 
 fun fulfill_body (th as Thm (Deriv {promises, body}, _)) =
   let val fulfilled_promises = map #1 promises ~~ map fulfill_body (Future.joins (map #2 promises))
   in Proofterm.fulfill_norm_proof (theory_of_thm th) fulfilled_promises body end;
 
 fun proof_bodies_of thms = (join_promises_of thms; map fulfill_body thms);
 val proof_body_of = singleton proof_bodies_of;
 val proof_of = Proofterm.proof_of o proof_body_of;
 
 fun reconstruct_proof_of thm =
   Proofterm.reconstruct_proof (theory_of_thm thm) (prop_of thm) (proof_of thm);
 
 val consolidate = ignore o proof_bodies_of;
 
 fun expose_proofs thy thms =
   if Proofterm.export_proof_boxes_required thy then
     Proofterm.export_proof_boxes (proof_bodies_of (map (transfer thy) thms))
   else ();
 
 fun expose_proof thy = expose_proofs thy o single;
 
 
 (* future rule *)
 
 fun future_result i orig_cert orig_shyps orig_prop thm =
   let
     fun err msg = raise THM ("future_result: " ^ msg, 0, [thm]);
     val Thm (Deriv {promises, ...}, {cert, constraints, shyps, hyps, tpairs, prop, ...}) = thm;
 
     val _ = Context.eq_certificate (cert, orig_cert) orelse err "bad theory";
     val _ = prop aconv orig_prop orelse err "bad prop";
     val _ = null constraints orelse err "bad sort constraints";
     val _ = null tpairs orelse err "bad flex-flex constraints";
     val _ = null hyps orelse err "bad hyps";
     val _ = Sorts.subset (shyps, orig_shyps) orelse err "bad shyps";
     val _ = forall (fn (j, _) => i <> j) promises orelse err "bad dependencies";
     val _ = join_promises promises;
   in thm end;
 
 fun future future_thm ct =
   let
     val Cterm {cert = cert, t = prop, T, maxidx, sorts} = ct;
     val _ = T <> propT andalso raise CTERM ("future: prop expected", [ct]);
     val _ =
       if Proofterm.proofs_enabled ()
       then raise CTERM ("future: proof terms enabled", [ct]) else ();
 
     val i = serial ();
     val future = future_thm |> Future.map (future_result i cert sorts prop);
   in
     Thm (make_deriv [(i, future)] [] [] MinProof,
      {cert = cert,
       tags = [],
       maxidx = maxidx,
       constraints = [],
       shyps = sorts,
       hyps = [],
       tpairs = [],
       prop = prop})
   end;
 
 
 
 (** Axioms **)
 
 fun axiom thy name =
   (case Name_Space.lookup (Theory.axiom_table thy) name of
     SOME prop =>
       let
         val der = deriv_rule0 (fn () => Proofterm.axm_proof name prop);
         val cert = Context.Certificate thy;
         val maxidx = maxidx_of_term prop;
         val shyps = Sorts.insert_term prop [];
       in
         Thm (der,
           {cert = cert, tags = [], maxidx = maxidx,
             constraints = [], shyps = shyps, hyps = [], tpairs = [], prop = prop})
       end
   | NONE => raise THEORY ("No axiom " ^ quote name, [thy]));
 
 fun all_axioms_of thy =
   map (fn (name, _) => (name, axiom thy name)) (Theory.all_axioms_of thy);
 
 
 (* tags *)
 
 val get_tags = #tags o rep_thm;
 
 fun map_tags f (Thm (der, {cert, tags, maxidx, constraints, shyps, hyps, tpairs, prop})) =
   Thm (der, {cert = cert, tags = f tags, maxidx = maxidx, constraints = constraints,
     shyps = shyps, hyps = hyps, tpairs = tpairs, prop = prop});
 
 
 (* technical adjustments *)
 
 fun norm_proof (th as Thm (der, args)) =
   Thm (deriv_rule1 (Proofterm.rew_proof (theory_of_thm th)) der, args);
 
 fun adjust_maxidx_thm i
     (th as Thm (der, {cert, tags, maxidx, constraints, shyps, hyps, tpairs, prop})) =
   if maxidx = i then th
   else if maxidx < i then
     Thm (der, {maxidx = i, cert = cert, tags = tags, constraints = constraints, shyps = shyps,
       hyps = hyps, tpairs = tpairs, prop = prop})
   else
     Thm (der, {maxidx = Int.max (maxidx_tpairs tpairs (maxidx_of_term prop), i),
       cert = cert, tags = tags, constraints = constraints, shyps = shyps,
       hyps = hyps, tpairs = tpairs, prop = prop});
 
 
 
 (*** Theory data ***)
 
 (* type classes *)
 
 structure Aritytab =
   Table(
     type key = string * sort list * class;
     val ord =
       fast_string_ord o apply2 #1
       ||| fast_string_ord o apply2 #3
       ||| list_ord Term_Ord.sort_ord o apply2 #2;
   );
 
 datatype classes = Classes of
  {classrels: thm Symreltab.table,
   arities: (thm * string * serial) Aritytab.table};
 
 fun make_classes (classrels, arities) = Classes {classrels = classrels, arities = arities};
 
 val empty_classes = make_classes (Symreltab.empty, Aritytab.empty);
 
 (*see Theory.at_begin hook for transitive closure of classrels and arity completion*)
 fun merge_classes
    (Classes {classrels = classrels1, arities = arities1},
     Classes {classrels = classrels2, arities = arities2}) =
   let
     val classrels' = Symreltab.merge (K true) (classrels1, classrels2);
     val arities' = Aritytab.merge (K true) (arities1, arities2);
   in make_classes (classrels', arities') end;
 
 
 (* data *)
 
 structure Data = Theory_Data
 (
   type T =
     unit Name_Space.table *  (*oracles: authentic derivation names*)
     classes;  (*type classes within the logic*)
 
   val empty : T = (Name_Space.empty_table Markup.oracleN, empty_classes);
   val extend = I;
   fun merge ((oracles1, sorts1), (oracles2, sorts2)) : T =
     (Name_Space.merge_tables (oracles1, oracles2), merge_classes (sorts1, sorts2));
 );
 
 val get_oracles = #1 o Data.get;
 val map_oracles = Data.map o apfst;
 
 val get_classes = (fn (_, Classes args) => args) o Data.get;
 val get_classrels = #classrels o get_classes;
 val get_arities = #arities o get_classes;
 
 fun map_classes f =
   (Data.map o apsnd) (fn Classes {classrels, arities} => make_classes (f (classrels, arities)));
 fun map_classrels f = map_classes (fn (classrels, arities) => (f classrels, arities));
 fun map_arities f = map_classes (fn (classrels, arities) => (classrels, f arities));
 
 
 (* type classes *)
 
 fun the_classrel thy (c1, c2) =
   (case Symreltab.lookup (get_classrels thy) (c1, c2) of
     SOME thm => transfer thy thm
   | NONE => error ("Unproven class relation " ^
       Syntax.string_of_classrel (Proof_Context.init_global thy) [c1, c2]));
 
 fun the_arity thy (a, Ss, c) =
   (case Aritytab.lookup (get_arities thy) (a, Ss, c) of
     SOME (thm, _, _) => transfer thy thm
   | NONE => error ("Unproven type arity " ^
       Syntax.string_of_arity (Proof_Context.init_global thy) (a, Ss, [c])));
 
 val classrel_proof = proof_of oo the_classrel;
 val arity_proof = proof_of oo the_arity;
 
 
 (* solve sort constraints by pro-forma proof *)
 
 local
 
 fun union_digest (oracles1, thms1) (oracles2, thms2) =
   (Proofterm.unions_oracles [oracles1, oracles2], Proofterm.unions_thms [thms1, thms2]);
 
 fun thm_digest (Thm (Deriv {body = PBody {oracles, thms, ...}, ...}, _)) =
   (oracles, thms);
 
 fun constraint_digest ({theory = thy, typ, sort, ...}: constraint) =
   Sorts.of_sort_derivation (Sign.classes_of thy)
    {class_relation = fn _ => fn _ => fn (digest, c1) => fn c2 =>
       if c1 = c2 then ([], []) else union_digest digest (thm_digest (the_classrel thy (c1, c2))),
     type_constructor = fn (a, _) => fn dom => fn c =>
       let val arity_digest = thm_digest (the_arity thy (a, (map o map) #2 dom, c))
       in (fold o fold) (union_digest o #1) dom arity_digest end,
     type_variable = fn T => map (pair ([], [])) (Type.sort_of_atyp T)}
    (typ, sort);
 
 in
 
 fun solve_constraints (thm as Thm (_, {constraints = [], ...})) = thm
   | solve_constraints (thm as Thm (der, args)) =
       let
         val {cert, tags, maxidx, constraints, shyps, hyps, tpairs, prop} = args;
 
         val thy = Context.certificate_theory cert;
         val bad_thys =
           constraints |> map_filter (fn {theory = thy', ...} =>
             if Context.eq_thy (thy, thy') then NONE else SOME thy');
         val () =
           if null bad_thys then ()
           else
             raise THEORY ("solve_constraints: bad theories for theorem\n" ^
               Syntax.string_of_term_global thy (prop_of thm), thy :: bad_thys);
 
         val Deriv {promises, body = PBody {oracles, thms, proof}} = der;
         val (oracles', thms') = (oracles, thms)
           |> fold (fold union_digest o constraint_digest) constraints;
         val body' = PBody {oracles = oracles', thms = thms', proof = proof};
       in
         Thm (Deriv {promises = promises, body = body'},
           {constraints = [], cert = cert, tags = tags, maxidx = maxidx,
             shyps = shyps, hyps = hyps, tpairs = tpairs, prop = prop})
       end;
 
 end;
 
 (*Dangling sort constraints of a thm*)
 fun extra_shyps (th as Thm (_, {shyps, ...})) =
   Sorts.subtract (fold_terms Sorts.insert_term th []) shyps;
 
 (*Remove extra sorts that are witnessed by type signature information*)
 fun strip_shyps thm =
   (case thm of
     Thm (_, {shyps = [], ...}) => thm
   | Thm (der, {cert, tags, maxidx, constraints, shyps, hyps, tpairs, prop}) =>
       let
         val thy = theory_of_thm thm;
 
         val algebra = Sign.classes_of thy;
         val minimize = Sorts.minimize_sort algebra;
         val le = Sorts.sort_le algebra;
         fun lt (S1, S2) = le (S1, S2) andalso not (le (S2, S1));
         fun rel (S1, S2) = if S1 = S2 then [] else [(Term.aT S1, S2)];
 
         val present = (fold_terms o fold_types o fold_atyps_sorts) (insert (eq_fst op =)) thm [];
         val extra = fold (Sorts.remove_sort o #2) present shyps;
         val witnessed = Sign.witness_sorts thy present extra;
         val non_witnessed = fold (Sorts.remove_sort o #2) witnessed extra |> map (`minimize);
 
         val extra' =
           non_witnessed |> map_filter (fn (S, _) =>
             if non_witnessed |> exists (fn (S', _) => lt (S', S)) then NONE else SOME S)
           |> Sorts.make;
 
         val constrs' =
           non_witnessed |> maps (fn (S1, S2) =>
             let val S0 = the (find_first (fn S => le (S, S1)) extra')
             in rel (S0, S1) @ rel (S1, S2) end);
 
         val constraints' = fold (insert_constraints thy) (witnessed @ constrs') constraints;
         val shyps' = fold (Sorts.insert_sort o #2) present extra';
       in
         Thm (deriv_rule_unconditional
           (Proofterm.strip_shyps_proof algebra present witnessed extra') der,
          {cert = cert, tags = tags, maxidx = maxidx, constraints = constraints',
           shyps = shyps', hyps = hyps, tpairs = tpairs, prop = prop})
       end)
   |> solve_constraints;
 
 
 
 (*** Closed theorems with official name ***)
 
 (*non-deterministic, depends on unknown promises*)
 fun derivation_closed (Thm (Deriv {body, ...}, _)) =
   Proofterm.compact_proof (Proofterm.proof_of body);
 
 (*non-deterministic, depends on unknown promises*)
 fun raw_derivation_name (Thm (Deriv {body, ...}, {shyps, hyps, prop, ...})) =
   Proofterm.get_approximative_name shyps hyps prop (Proofterm.proof_of body);
 
 fun expand_name (Thm (Deriv {body, ...}, {shyps, hyps, prop, ...})) =
   let
     val self_id =
       (case Proofterm.get_identity shyps hyps prop (Proofterm.proof_of body) of
         NONE => K false
       | SOME {serial, ...} => fn (header: Proofterm.thm_header) => serial = #serial header);
     fun expand header = if self_id header orelse #name header = "" then SOME "" else NONE;
   in expand end;
 
 (*deterministic name of finished proof*)
 fun derivation_name (thm as Thm (_, {shyps, hyps, prop, ...})) =
   Proofterm.get_approximative_name shyps hyps prop (proof_of thm);
 
 (*identified PThm node*)
 fun derivation_id (thm as Thm (_, {shyps, hyps, prop, ...})) =
   Proofterm.get_id shyps hyps prop (proof_of thm);
 
 (*dependencies of PThm node*)
 fun thm_deps (thm as Thm (Deriv {promises = [], body = PBody {thms, ...}, ...}, _)) =
       (case (derivation_id thm, thms) of
         (SOME {serial = i, ...}, [(j, thm_node)]) =>
           if i = j then Proofterm.thm_node_thms thm_node else thms
       | _ => thms)
   | thm_deps thm = raise THM ("thm_deps: bad promises", 0, [thm]);
 
 fun name_derivation name_pos =
   strip_shyps #> (fn thm as Thm (der, args) =>
     let
       val thy = theory_of_thm thm;
 
       val Deriv {promises, body} = der;
       val {shyps, hyps, prop, tpairs, ...} = args;
 
       val _ = null tpairs orelse raise THM ("name_derivation: bad flex-flex constraints", 0, [thm]);
 
       val ps = map (apsnd (Future.map fulfill_body)) promises;
       val (pthm, proof) =
         Proofterm.thm_proof thy (classrel_proof thy) (arity_proof thy)
           name_pos shyps hyps prop ps body;
       val der' = make_deriv [] [] [pthm] proof;
     in Thm (der', args) end);
 
 fun close_derivation pos =
   solve_constraints #> (fn thm =>
     if not (null (tpairs_of thm)) orelse derivation_closed thm then thm
     else name_derivation ("", pos) thm);
 
 val trim_context = solve_constraints #> trim_context_thm;
 
 
 
 (*** Oracles ***)
 
 fun add_oracle (b, oracle_fn) thy =
   let
     val (name, oracles') = Name_Space.define (Context.Theory thy) true (b, ()) (get_oracles thy);
     val thy' = map_oracles (K oracles') thy;
     fun invoke_oracle arg =
       let val Cterm {cert = cert2, t = prop, T, maxidx, sorts} = oracle_fn arg in
         if T <> propT then
           raise THM ("Oracle's result must have type prop: " ^ name, 0, [])
         else
           let
             val (oracle, prf) =
               (case ! Proofterm.proofs of
                 2 => (((name, Position.thread_data ()), SOME prop), Proofterm.oracle_proof name prop)
               | 1 => (((name, Position.thread_data ()), SOME prop), MinProof)
               | 0 => (((name, Position.none), NONE), MinProof)
               | i => bad_proofs i);
           in
             Thm (make_deriv [] [oracle] [] prf,
              {cert = Context.join_certificate (Context.Certificate thy', cert2),
               tags = [],
               maxidx = maxidx,
               constraints = [],
               shyps = sorts,
               hyps = [],
               tpairs = [],
               prop = prop})
           end
       end;
   in ((name, invoke_oracle), thy') end;
 
 val oracle_space = Name_Space.space_of_table o get_oracles;
 
 fun pretty_oracle ctxt =
   Name_Space.pretty ctxt (oracle_space (Proof_Context.theory_of ctxt));
 
 fun extern_oracles verbose ctxt =
   map #1 (Name_Space.markup_table verbose ctxt (get_oracles (Proof_Context.theory_of ctxt)));
 
 fun check_oracle ctxt =
   Name_Space.check (Context.Proof ctxt) (get_oracles (Proof_Context.theory_of ctxt)) #> #1;
 
 
 
 (*** Meta rules ***)
 
 (** primitive rules **)
 
 (*The assumption rule A |- A*)
 fun assume raw_ct =
   let val Cterm {cert, t = prop, T, maxidx, sorts} = adjust_maxidx_cterm ~1 raw_ct in
     if T <> propT then
       raise THM ("assume: prop", 0, [])
     else if maxidx <> ~1 then
       raise THM ("assume: variables", maxidx, [])
     else Thm (deriv_rule0 (fn () => Proofterm.Hyp prop),
      {cert = cert,
       tags = [],
       maxidx = ~1,
       constraints = [],
       shyps = sorts,
       hyps = [prop],
       tpairs = [],
       prop = prop})
   end;
 
 (*Implication introduction
     [A]
      :
      B
   -------
   A \<Longrightarrow> B
 *)
 fun implies_intr
     (ct as Cterm {t = A, T, maxidx = maxidx1, sorts, ...})
     (th as Thm (der, {maxidx = maxidx2, hyps, constraints, shyps, tpairs, prop, ...})) =
   if T <> propT then
     raise THM ("implies_intr: assumptions must have type prop", 0, [th])
   else
     Thm (deriv_rule1 (Proofterm.implies_intr_proof A) der,
      {cert = join_certificate1 (ct, th),
       tags = [],
       maxidx = Int.max (maxidx1, maxidx2),
       constraints = constraints,
       shyps = Sorts.union sorts shyps,
       hyps = remove_hyps A hyps,
       tpairs = tpairs,
       prop = Logic.mk_implies (A, prop)});
 
 
 (*Implication elimination
   A \<Longrightarrow> B    A
   ------------
         B
 *)
 fun implies_elim thAB thA =
   let
     val Thm (derA,
       {maxidx = maxidx1, hyps = hypsA, constraints = constraintsA, shyps = shypsA,
         tpairs = tpairsA, prop = propA, ...}) = thA
     and Thm (der, {maxidx = maxidx2, hyps, constraints, shyps, tpairs, prop, ...}) = thAB;
     fun err () = raise THM ("implies_elim: major premise", 0, [thAB, thA]);
   in
     (case prop of
       Const ("Pure.imp", _) $ A $ B =>
         if A aconv propA then
           Thm (deriv_rule2 (curry Proofterm.%%) der derA,
            {cert = join_certificate2 (thAB, thA),
             tags = [],
             maxidx = Int.max (maxidx1, maxidx2),
             constraints = union_constraints constraintsA constraints,
             shyps = Sorts.union shypsA shyps,
             hyps = union_hyps hypsA hyps,
             tpairs = union_tpairs tpairsA tpairs,
             prop = B})
         else err ()
     | _ => err ())
   end;
 
 (*Forall introduction.  The Free or Var x must not be free in the hypotheses.
     [x]
      :
      A
   ------
   \<And>x. A
 *)
 fun forall_intr
     (ct as Cterm {maxidx = maxidx1, t = x, T, sorts, ...})
     (th as Thm (der, {maxidx = maxidx2, constraints, shyps, hyps, tpairs, prop, ...})) =
   let
     fun result a =
       Thm (deriv_rule1 (Proofterm.forall_intr_proof (a, x) NONE) der,
        {cert = join_certificate1 (ct, th),
         tags = [],
         maxidx = Int.max (maxidx1, maxidx2),
         constraints = constraints,
         shyps = Sorts.union sorts shyps,
         hyps = hyps,
         tpairs = tpairs,
         prop = Logic.all_const T $ Abs (a, T, abstract_over (x, prop))});
     fun check_occs a x ts =
       if exists (fn t => Logic.occs (x, t)) ts then
         raise THM ("forall_intr: variable " ^ quote a ^ " free in assumptions", 0, [th])
       else ();
   in
     (case x of
       Free (a, _) => (check_occs a x hyps; check_occs a x (terms_of_tpairs tpairs); result a)
     | Var ((a, _), _) => (check_occs a x (terms_of_tpairs tpairs); result a)
     | _ => raise THM ("forall_intr: not a variable", 0, [th]))
   end;
 
 (*Forall elimination
   \<And>x. A
   ------
   A[t/x]
 *)
 fun forall_elim
     (ct as Cterm {t, T, maxidx = maxidx1, sorts, ...})
     (th as Thm (der, {maxidx = maxidx2, constraints, shyps, hyps, tpairs, prop, ...})) =
   (case prop of
     Const ("Pure.all", Type ("fun", [Type ("fun", [qary, _]), _])) $ A =>
       if T <> qary then
         raise THM ("forall_elim: type mismatch", 0, [th])
       else
         Thm (deriv_rule1 (Proofterm.% o rpair (SOME t)) der,
          {cert = join_certificate1 (ct, th),
           tags = [],
           maxidx = Int.max (maxidx1, maxidx2),
           constraints = constraints,
           shyps = Sorts.union sorts shyps,
           hyps = hyps,
           tpairs = tpairs,
           prop = Term.betapply (A, t)})
   | _ => raise THM ("forall_elim: not quantified", 0, [th]));
 
 
 (* Equality *)
 
 (*Reflexivity
   t \<equiv> t
 *)
 fun reflexive (Cterm {cert, t, T = _, maxidx, sorts}) =
   Thm (deriv_rule0 (fn () => Proofterm.reflexive_proof),
    {cert = cert,
     tags = [],
     maxidx = maxidx,
     constraints = [],
     shyps = sorts,
     hyps = [],
     tpairs = [],
     prop = Logic.mk_equals (t, t)});
 
 (*Symmetry
   t \<equiv> u
   ------
   u \<equiv> t
 *)
 fun symmetric (th as Thm (der, {cert, maxidx, constraints, shyps, hyps, tpairs, prop, ...})) =
   (case prop of
     (eq as Const ("Pure.eq", _)) $ t $ u =>
       Thm (deriv_rule1 Proofterm.symmetric_proof der,
        {cert = cert,
         tags = [],
         maxidx = maxidx,
         constraints = constraints,
         shyps = shyps,
         hyps = hyps,
         tpairs = tpairs,
         prop = eq $ u $ t})
     | _ => raise THM ("symmetric", 0, [th]));
 
 (*Transitivity
   t1 \<equiv> u    u \<equiv> t2
   ------------------
        t1 \<equiv> t2
 *)
 fun transitive th1 th2 =
   let
     val Thm (der1, {maxidx = maxidx1, hyps = hyps1, constraints = constraints1, shyps = shyps1,
         tpairs = tpairs1, prop = prop1, ...}) = th1
     and Thm (der2, {maxidx = maxidx2, hyps = hyps2, constraints = constraints2, shyps = shyps2,
         tpairs = tpairs2, prop = prop2, ...}) = th2;
     fun err msg = raise THM ("transitive: " ^ msg, 0, [th1, th2]);
   in
     case (prop1, prop2) of
       ((eq as Const ("Pure.eq", Type (_, [U, _]))) $ t1 $ u, Const ("Pure.eq", _) $ u' $ t2) =>
         if not (u aconv u') then err "middle term"
         else
           Thm (deriv_rule2 (Proofterm.transitive_proof U u) der1 der2,
            {cert = join_certificate2 (th1, th2),
             tags = [],
             maxidx = Int.max (maxidx1, maxidx2),
             constraints = union_constraints constraints1 constraints2,
             shyps = Sorts.union shyps1 shyps2,
             hyps = union_hyps hyps1 hyps2,
             tpairs = union_tpairs tpairs1 tpairs2,
             prop = eq $ t1 $ t2})
      | _ =>  err "premises"
   end;
 
 (*Beta-conversion
   (\<lambda>x. t) u \<equiv> t[u/x]
   fully beta-reduces the term if full = true
 *)
 fun beta_conversion full (Cterm {cert, t, T = _, maxidx, sorts}) =
   let val t' =
     if full then Envir.beta_norm t
     else
       (case t of Abs (_, _, bodt) $ u => subst_bound (u, bodt)
       | _ => raise THM ("beta_conversion: not a redex", 0, []));
   in
     Thm (deriv_rule0 (fn () => Proofterm.reflexive_proof),
      {cert = cert,
       tags = [],
       maxidx = maxidx,
       constraints = [],
       shyps = sorts,
       hyps = [],
       tpairs = [],
       prop = Logic.mk_equals (t, t')})
   end;
 
 fun eta_conversion (Cterm {cert, t, T = _, maxidx, sorts}) =
   Thm (deriv_rule0 (fn () => Proofterm.reflexive_proof),
    {cert = cert,
     tags = [],
     maxidx = maxidx,
     constraints = [],
     shyps = sorts,
     hyps = [],
     tpairs = [],
     prop = Logic.mk_equals (t, Envir.eta_contract t)});
 
 fun eta_long_conversion (Cterm {cert, t, T = _, maxidx, sorts}) =
   Thm (deriv_rule0 (fn () => Proofterm.reflexive_proof),
    {cert = cert,
     tags = [],
     maxidx = maxidx,
     constraints = [],
     shyps = sorts,
     hyps = [],
     tpairs = [],
     prop = Logic.mk_equals (t, Envir.eta_long [] t)});
 
 (*The abstraction rule.  The Free or Var x must not be free in the hypotheses.
   The bound variable will be named "a" (since x will be something like x320)
       t \<equiv> u
   --------------
   \<lambda>x. t \<equiv> \<lambda>x. u
 *)
 fun abstract_rule a
     (Cterm {t = x, T, sorts, ...})
     (th as Thm (der, {cert, maxidx, hyps, constraints, shyps, tpairs, prop, ...})) =
   let
     val (t, u) = Logic.dest_equals prop
       handle TERM _ => raise THM ("abstract_rule: premise not an equality", 0, [th]);
     val result =
       Thm (deriv_rule1 (Proofterm.abstract_rule_proof (a, x)) der,
        {cert = cert,
         tags = [],
         maxidx = maxidx,
         constraints = constraints,
         shyps = Sorts.union sorts shyps,
         hyps = hyps,
         tpairs = tpairs,
         prop = Logic.mk_equals
           (Abs (a, T, abstract_over (x, t)), Abs (a, T, abstract_over (x, u)))});
     fun check_occs a x ts =
       if exists (fn t => Logic.occs (x, t)) ts then
         raise THM ("abstract_rule: variable " ^ quote a ^ " free in assumptions", 0, [th])
       else ();
   in
     (case x of
       Free (a, _) => (check_occs a x hyps; check_occs a x (terms_of_tpairs tpairs); result)
     | Var ((a, _), _) => (check_occs a x (terms_of_tpairs tpairs); result)
     | _ => raise THM ("abstract_rule: not a variable", 0, [th]))
   end;
 
 (*The combination rule
   f \<equiv> g  t \<equiv> u
   -------------
     f t \<equiv> g u
 *)
 fun combination th1 th2 =
   let
     val Thm (der1, {maxidx = maxidx1, constraints = constraints1, shyps = shyps1,
         hyps = hyps1, tpairs = tpairs1, prop = prop1, ...}) = th1
     and Thm (der2, {maxidx = maxidx2, constraints = constraints2, shyps = shyps2,
         hyps = hyps2, tpairs = tpairs2, prop = prop2, ...}) = th2;
     fun chktypes fT tT =
       (case fT of
         Type ("fun", [T1, _]) =>
           if T1 <> tT then
             raise THM ("combination: types", 0, [th1, th2])
           else ()
       | _ => raise THM ("combination: not function type", 0, [th1, th2]));
   in
     (case (prop1, prop2) of
       (Const ("Pure.eq", Type ("fun", [fT, _])) $ f $ g,
        Const ("Pure.eq", Type ("fun", [tT, _])) $ t $ u) =>
         (chktypes fT tT;
           Thm (deriv_rule2 (Proofterm.combination_proof f g t u) der1 der2,
            {cert = join_certificate2 (th1, th2),
             tags = [],
             maxidx = Int.max (maxidx1, maxidx2),
             constraints = union_constraints constraints1 constraints2,
             shyps = Sorts.union shyps1 shyps2,
             hyps = union_hyps hyps1 hyps2,
             tpairs = union_tpairs tpairs1 tpairs2,
             prop = Logic.mk_equals (f $ t, g $ u)}))
      | _ => raise THM ("combination: premises", 0, [th1, th2]))
   end;
 
 (*Equality introduction
   A \<Longrightarrow> B  B \<Longrightarrow> A
   ----------------
        A \<equiv> B
 *)
 fun equal_intr th1 th2 =
   let
     val Thm (der1, {maxidx = maxidx1, constraints = constraints1, shyps = shyps1,
       hyps = hyps1, tpairs = tpairs1, prop = prop1, ...}) = th1
     and Thm (der2, {maxidx = maxidx2, constraints = constraints2, shyps = shyps2,
       hyps = hyps2, tpairs = tpairs2, prop = prop2, ...}) = th2;
     fun err msg = raise THM ("equal_intr: " ^ msg, 0, [th1, th2]);
   in
     (case (prop1, prop2) of
       (Const("Pure.imp", _) $ A $ B, Const("Pure.imp", _) $ B' $ A') =>
         if A aconv A' andalso B aconv B' then
           Thm (deriv_rule2 (Proofterm.equal_intr_proof A B) der1 der2,
            {cert = join_certificate2 (th1, th2),
             tags = [],
             maxidx = Int.max (maxidx1, maxidx2),
             constraints = union_constraints constraints1 constraints2,
             shyps = Sorts.union shyps1 shyps2,
             hyps = union_hyps hyps1 hyps2,
             tpairs = union_tpairs tpairs1 tpairs2,
             prop = Logic.mk_equals (A, B)})
         else err "not equal"
     | _ =>  err "premises")
   end;
 
 (*The equal propositions rule
   A \<equiv> B  A
   ---------
       B
 *)
 fun equal_elim th1 th2 =
   let
     val Thm (der1, {maxidx = maxidx1, constraints = constraints1, shyps = shyps1,
       hyps = hyps1, tpairs = tpairs1, prop = prop1, ...}) = th1
     and Thm (der2, {maxidx = maxidx2, constraints = constraints2, shyps = shyps2,
       hyps = hyps2, tpairs = tpairs2, prop = prop2, ...}) = th2;
     fun err msg = raise THM ("equal_elim: " ^ msg, 0, [th1, th2]);
   in
     (case prop1 of
       Const ("Pure.eq", _) $ A $ B =>
         if prop2 aconv A then
           Thm (deriv_rule2 (Proofterm.equal_elim_proof A B) der1 der2,
            {cert = join_certificate2 (th1, th2),
             tags = [],
             maxidx = Int.max (maxidx1, maxidx2),
             constraints = union_constraints constraints1 constraints2,
             shyps = Sorts.union shyps1 shyps2,
             hyps = union_hyps hyps1 hyps2,
             tpairs = union_tpairs tpairs1 tpairs2,
             prop = B})
         else err "not equal"
      | _ =>  err "major premise")
   end;
 
 
 
 (**** Derived rules ****)
 
 (*Smash unifies the list of term pairs leaving no flex-flex pairs.
   Instantiates the theorem and deletes trivial tpairs.  Resulting
   sequence may contain multiple elements if the tpairs are not all
   flex-flex.*)
 fun flexflex_rule opt_ctxt =
   solve_constraints #> (fn th =>
     let
       val Thm (der, {cert, maxidx, constraints, shyps, hyps, tpairs, prop, ...}) = th;
       val (context, cert') = make_context_certificate [th] opt_ctxt cert;
     in
       Unify.smash_unifiers context tpairs (Envir.empty maxidx)
       |> Seq.map (fn env =>
           if Envir.is_empty env then th
           else
             let
               val tpairs' = tpairs |> map (apply2 (Envir.norm_term env))
                 (*remove trivial tpairs, of the form t \<equiv> t*)
                 |> filter_out (op aconv);
               val der' = deriv_rule1 (Proofterm.norm_proof' env) der;
               val constraints' =
                 insert_constraints_env (Context.certificate_theory cert') env constraints;
               val prop' = Envir.norm_term env prop;
               val maxidx = maxidx_tpairs tpairs' (maxidx_of_term prop');
               val shyps = Envir.insert_sorts env shyps;
             in
               Thm (der', {cert = cert', tags = [], maxidx = maxidx, constraints = constraints',
                 shyps = shyps, hyps = hyps, tpairs = tpairs', prop = prop'})
             end)
     end);
 
 
 (*Generalization of fixed variables
            A
   --------------------
   A[?'a/'a, ?x/x, ...]
 *)
 
 fun generalize (tfrees, frees) idx th =
   if Symtab.is_empty tfrees andalso Symtab.is_empty frees then th
   else
     let
       val Thm (der, {cert, maxidx, constraints, shyps, hyps, tpairs, prop, ...}) = th;
       val _ = idx <= maxidx andalso raise THM ("generalize: bad index", idx, [th]);
 
       val bad_type =
         if Symtab.is_empty tfrees then K false
         else Term.exists_subtype (fn TFree (a, _) => Symtab.defined tfrees a | _ => false);
       fun bad_term (Free (x, T)) = bad_type T orelse Symtab.defined frees x
         | bad_term (Var (_, T)) = bad_type T
         | bad_term (Const (_, T)) = bad_type T
         | bad_term (Abs (_, T, t)) = bad_type T orelse bad_term t
         | bad_term (t $ u) = bad_term t orelse bad_term u
         | bad_term (Bound _) = false;
       val _ = exists bad_term hyps andalso
         raise THM ("generalize: variable free in assumptions", 0, [th]);
 
       val generalize = Term_Subst.generalize (tfrees, frees) idx;
       val prop' = generalize prop;
       val tpairs' = map (apply2 generalize) tpairs;
       val maxidx' = maxidx_tpairs tpairs' (maxidx_of_term prop');
     in
       Thm (deriv_rule1 (Proofterm.generalize_proof (tfrees, frees) idx prop) der,
        {cert = cert,
         tags = [],
         maxidx = maxidx',
         constraints = constraints,
         shyps = shyps,
         hyps = hyps,
         tpairs = tpairs',
         prop = prop'})
     end;
 
 fun generalize_cterm (tfrees, frees) idx (ct as Cterm {cert, t, T, maxidx, sorts}) =
   if Symtab.is_empty tfrees andalso Symtab.is_empty frees then ct
   else if idx <= maxidx then raise CTERM ("generalize_cterm: bad index", [ct])
   else
     Cterm {cert = cert, sorts = sorts,
       T = Term_Subst.generalizeT tfrees idx T,
       t = Term_Subst.generalize (tfrees, frees) idx t,
       maxidx = Int.max (maxidx, idx)};
 
 fun generalize_ctyp tfrees idx (cT as Ctyp {cert, T, maxidx, sorts}) =
   if Symtab.is_empty tfrees then cT
   else if idx <= maxidx then raise CTERM ("generalize_ctyp: bad index", [])
   else
     Ctyp {cert = cert, sorts = sorts,
       T = Term_Subst.generalizeT tfrees idx T,
       maxidx = Int.max (maxidx, idx)};
 
 
 (*Instantiation of schematic variables
            A
   --------------------
   A[t1/v1, ..., tn/vn]
 *)
 
 local
 
 fun add_cert cert_of (_, c) cert = Context.join_certificate (cert, cert_of c);
 val add_instT_cert = add_cert (fn Ctyp {cert, ...} => cert);
 val add_inst_cert = add_cert (fn Cterm {cert, ...} => cert);
 
 fun add_sorts sorts_of (_, c) sorts = Sorts.union (sorts_of c) sorts;
 val add_instT_sorts = add_sorts (fn Ctyp {sorts, ...} => sorts);
 val add_inst_sorts = add_sorts (fn Cterm {sorts, ...} => sorts);
 
 fun add_instT thy (v as (_, S), Ctyp {T = U, maxidx, ...}) =
   if Sign.of_sort thy (U, S) then Term_Subst.TVars.add (v, (U, maxidx))
   else raise TYPE ("Type not of sort " ^ Syntax.string_of_sort_global thy S, [U], []);
 
 fun add_inst thy (v as (_, T), Cterm {t = u, T = U, maxidx, ...}) =
   if T = U then Term_Subst.Vars.add (v, (u, maxidx))
   else
     let
       fun pretty_typing t ty =
         Pretty.block [Syntax.pretty_term_global thy t, Pretty.str " ::",
           Pretty.brk 1, Syntax.pretty_typ_global thy ty];
       val msg =
         Pretty.string_of (Pretty.block
          [Pretty.str "instantiate: type conflict",
           Pretty.fbrk, pretty_typing (Var v) T,
           Pretty.fbrk, pretty_typing u U])
     in raise TYPE (msg, [T, U], [Var v, u]) end;
 
 fun prep_insts (instT, inst) (cert, sorts) =
   let
     val cert' = cert
       |> fold add_instT_cert instT
       |> fold add_inst_cert inst;
     val thy' = Context.certificate_theory cert'
       handle ERROR msg => raise CONTEXT (msg, map #2 instT, map #2 inst, [], NONE);
 
     val sorts' = sorts
       |> fold add_instT_sorts instT
       |> fold add_inst_sorts inst;
 
-    val instT' = fold (add_instT thy') instT Term_Subst.TVars.empty;
-    val inst' = fold (add_inst thy') inst Term_Subst.Vars.empty;
+    val instT' = Term_Subst.TVars.build (fold (add_instT thy') instT);
+    val inst' = Term_Subst.Vars.build (fold (add_inst thy') inst);
   in ((instT', inst'), (cert', sorts')) end;
 
 in
 
 (*Left-to-right replacements: ctpairs = [..., (vi, ti), ...].
   Instantiates distinct Vars by terms of same type.
   Does NOT normalize the resulting theorem!*)
 fun instantiate ([], []) th = th
   | instantiate (instT, inst) th =
       let
         val Thm (der, {cert, hyps, constraints, shyps, tpairs, prop, ...}) = th;
         val ((instT', inst'), (cert', shyps')) = prep_insts (instT, inst) (cert, shyps)
           handle CONTEXT (msg, cTs, cts, ths, context) =>
             raise CONTEXT (msg, cTs, cts, th :: ths, context);
 
         val subst = Term_Subst.instantiate_maxidx (instT', inst');
         val (prop', maxidx1) = subst prop ~1;
         val (tpairs', maxidx') =
           fold_map (fn (t, u) => fn i => subst t i ||>> subst u) tpairs maxidx1;
 
         val thy' = Context.certificate_theory cert';
         val constraints' =
           Term_Subst.TVars.fold (fn ((_, S), (T, _)) => insert_constraints thy' (T, S))
             instT' constraints;
       in
         Thm (deriv_rule1
           (fn d =>
             Proofterm.instantiate
               (Term_Subst.TVars.map (K #1) instT', Term_Subst.Vars.map (K #1) inst') d) der,
          {cert = cert',
           tags = [],
           maxidx = maxidx',
           constraints = constraints',
           shyps = shyps',
           hyps = hyps,
           tpairs = tpairs',
           prop = prop'})
         |> solve_constraints
       end
       handle TYPE (msg, _, _) => raise THM (msg, 0, [th]);
 
 fun instantiate_cterm ([], []) ct = ct
   | instantiate_cterm (instT, inst) ct =
       let
         val Cterm {cert, t, T, sorts, ...} = ct;
         val ((instT', inst'), (cert', sorts')) = prep_insts (instT, inst) (cert, sorts);
         val subst = Term_Subst.instantiate_maxidx (instT', inst');
         val substT = Term_Subst.instantiateT_maxidx instT';
         val (t', maxidx1) = subst t ~1;
         val (T', maxidx') = substT T maxidx1;
       in Cterm {cert = cert', t = t', T = T', sorts = sorts', maxidx = maxidx'} end
       handle TYPE (msg, _, _) => raise CTERM (msg, [ct]);
 
 end;
 
 
 (*The trivial implication A \<Longrightarrow> A, justified by assume and forall rules.
   A can contain Vars, not so for assume!*)
 fun trivial (Cterm {cert, t = A, T, maxidx, sorts}) =
   if T <> propT then
     raise THM ("trivial: the term must have type prop", 0, [])
   else
     Thm (deriv_rule0 (fn () => Proofterm.trivial_proof),
      {cert = cert,
       tags = [],
       maxidx = maxidx,
       constraints = [],
       shyps = sorts,
       hyps = [],
       tpairs = [],
       prop = Logic.mk_implies (A, A)});
 
 (*Axiom-scheme reflecting signature contents
         T :: c
   -------------------
   OFCLASS(T, c_class)
 *)
 fun of_class (cT, raw_c) =
   let
     val Ctyp {cert, T, ...} = cT;
     val thy = Context.certificate_theory cert
       handle ERROR msg => raise CONTEXT (msg, [cT], [], [], NONE);
     val c = Sign.certify_class thy raw_c;
     val Cterm {t = prop, maxidx, sorts, ...} = global_cterm_of thy (Logic.mk_of_class (T, c));
   in
     if Sign.of_sort thy (T, [c]) then
       Thm (deriv_rule0 (fn () => Proofterm.PClass (T, c)),
        {cert = cert,
         tags = [],
         maxidx = maxidx,
         constraints = insert_constraints thy (T, [c]) [],
         shyps = sorts,
         hyps = [],
         tpairs = [],
         prop = prop})
     else raise THM ("of_class: type not of class " ^ Syntax.string_of_sort_global thy [c], 0, [])
   end |> solve_constraints;
 
 (*Internalize sort constraints of type variables*)
 val unconstrainT =
   strip_shyps #> (fn thm as Thm (der, args) =>
     let
       val Deriv {promises, body} = der;
       val {cert, shyps, hyps, tpairs, prop, ...} = args;
       val thy = theory_of_thm thm;
 
       fun err msg = raise THM ("unconstrainT: " ^ msg, 0, [thm]);
       val _ = null hyps orelse err "bad hyps";
       val _ = null tpairs orelse err "bad flex-flex constraints";
       val tfrees = rev (Term.add_tfree_names prop []);
       val _ = null tfrees orelse err ("illegal free type variables " ^ commas_quote tfrees);
 
       val ps = map (apsnd (Future.map fulfill_body)) promises;
       val (pthm, proof) =
         Proofterm.unconstrain_thm_proof thy (classrel_proof thy) (arity_proof thy)
           shyps prop ps body;
       val der' = make_deriv [] [] [pthm] proof;
       val prop' = Proofterm.thm_node_prop (#2 pthm);
     in
       Thm (der',
        {cert = cert,
         tags = [],
         maxidx = maxidx_of_term prop',
         constraints = [],
         shyps = [[]],  (*potentially redundant*)
         hyps = [],
         tpairs = [],
         prop = prop'})
     end);
 
 (*Replace all TFrees not fixed or in the hyps by new TVars*)
 fun varifyT_global' fixed (Thm (der, {cert, maxidx, constraints, shyps, hyps, tpairs, prop, ...})) =
   let
     val tfrees = fold Term.add_tfrees hyps fixed;
     val prop1 = attach_tpairs tpairs prop;
     val (al, prop2) = Type.varify_global tfrees prop1;
     val (ts, prop3) = Logic.strip_prems (length tpairs, [], prop2);
   in
     (al, Thm (deriv_rule1 (Proofterm.varify_proof prop tfrees) der,
      {cert = cert,
       tags = [],
       maxidx = Int.max (0, maxidx),
       constraints = constraints,
       shyps = shyps,
       hyps = hyps,
       tpairs = rev (map Logic.dest_equals ts),
       prop = prop3}))
   end;
 
 val varifyT_global = #2 o varifyT_global' [];
 
 (*Replace all TVars by TFrees that are often new*)
 fun legacy_freezeT (Thm (der, {cert, constraints, shyps, hyps, tpairs, prop, ...})) =
   let
     val prop1 = attach_tpairs tpairs prop;
     val prop2 = Type.legacy_freeze prop1;
     val (ts, prop3) = Logic.strip_prems (length tpairs, [], prop2);
   in
     Thm (deriv_rule1 (Proofterm.legacy_freezeT prop1) der,
      {cert = cert,
       tags = [],
       maxidx = maxidx_of_term prop2,
       constraints = constraints,
       shyps = shyps,
       hyps = hyps,
       tpairs = rev (map Logic.dest_equals ts),
       prop = prop3})
   end;
 
 fun plain_prop_of raw_thm =
   let
     val thm = strip_shyps raw_thm;
     fun err msg = raise THM ("plain_prop_of: " ^ msg, 0, [thm]);
   in
     if not (null (hyps_of thm)) then
       err "theorem may not contain hypotheses"
     else if not (null (extra_shyps thm)) then
       err "theorem may not contain sort hypotheses"
     else if not (null (tpairs_of thm)) then
       err "theorem may not contain flex-flex pairs"
     else prop_of thm
   end;
 
 
 
 (*** Inference rules for tactics ***)
 
 (*Destruct proof state into constraints, other goals, goal(i), rest *)
 fun dest_state (state as Thm (_, {prop,tpairs,...}), i) =
   (case  Logic.strip_prems(i, [], prop) of
       (B::rBs, C) => (tpairs, rev rBs, B, C)
     | _ => raise THM("dest_state", i, [state]))
   handle TERM _ => raise THM("dest_state", i, [state]);
 
 (*Prepare orule for resolution by lifting it over the parameters and
 assumptions of goal.*)
 fun lift_rule goal orule =
   let
     val Cterm {t = gprop, T, maxidx = gmax, sorts, ...} = goal;
     val inc = gmax + 1;
     val lift_abs = Logic.lift_abs inc gprop;
     val lift_all = Logic.lift_all inc gprop;
     val Thm (der, {maxidx, constraints, shyps, hyps, tpairs, prop, ...}) = orule;
     val (As, B) = Logic.strip_horn prop;
   in
     if T <> propT then raise THM ("lift_rule: the term must have type prop", 0, [])
     else
       Thm (deriv_rule1 (Proofterm.lift_proof gprop inc prop) der,
        {cert = join_certificate1 (goal, orule),
         tags = [],
         maxidx = maxidx + inc,
         constraints = constraints,
         shyps = Sorts.union shyps sorts,  (*sic!*)
         hyps = hyps,
         tpairs = map (apply2 lift_abs) tpairs,
         prop = Logic.list_implies (map lift_all As, lift_all B)})
   end;
 
 fun incr_indexes i (thm as Thm (der, {cert, maxidx, constraints, shyps, hyps, tpairs, prop, ...})) =
   if i < 0 then raise THM ("negative increment", 0, [thm])
   else if i = 0 then thm
   else
     Thm (deriv_rule1 (Proofterm.incr_indexes i) der,
      {cert = cert,
       tags = [],
       maxidx = maxidx + i,
       constraints = constraints,
       shyps = shyps,
       hyps = hyps,
       tpairs = map (apply2 (Logic.incr_indexes ([], [], i))) tpairs,
       prop = Logic.incr_indexes ([], [], i) prop});
 
 (*Solve subgoal Bi of proof state B1...Bn/C by assumption. *)
 fun assumption opt_ctxt i state =
   let
     val Thm (der, {cert, maxidx, constraints, shyps, hyps, ...}) = state;
     val (context, cert') = make_context_certificate [state] opt_ctxt cert;
     val (tpairs, Bs, Bi, C) = dest_state (state, i);
     fun newth n (env, tpairs) =
       let
         val normt = Envir.norm_term env;
         fun assumption_proof prf =
           Proofterm.assumption_proof (map normt Bs) (normt Bi) n prf;
       in
         Thm (deriv_rule1
           (assumption_proof #> not (Envir.is_empty env) ? Proofterm.norm_proof' env) der,
          {tags = [],
           maxidx = Envir.maxidx_of env,
           constraints = insert_constraints_env (Context.certificate_theory cert') env constraints,
           shyps = Envir.insert_sorts env shyps,
           hyps = hyps,
           tpairs = if Envir.is_empty env then tpairs else map (apply2 normt) tpairs,
           prop =
             if Envir.is_empty env then Logic.list_implies (Bs, C) (*avoid wasted normalizations*)
             else normt (Logic.list_implies (Bs, C)) (*normalize the new rule fully*),
           cert = cert'})
       end;
 
     val (close, asms, concl) = Logic.assum_problems (~1, Bi);
     val concl' = close concl;
     fun addprfs [] _ = Seq.empty
       | addprfs (asm :: rest) n = Seq.make (fn () => Seq.pull
           (Seq.mapp (newth n)
             (if Term.could_unify (asm, concl) then
               (Unify.unifiers (context, Envir.empty maxidx, (close asm, concl') :: tpairs))
              else Seq.empty)
             (addprfs rest (n + 1))))
   in addprfs asms 1 end;
 
 (*Solve subgoal Bi of proof state B1...Bn/C by assumption.
   Checks if Bi's conclusion is alpha/eta-convertible to one of its assumptions*)
 fun eq_assumption i state =
   let
     val Thm (der, {cert, maxidx, constraints, shyps, hyps, ...}) = state;
     val (tpairs, Bs, Bi, C) = dest_state (state, i);
     val (_, asms, concl) = Logic.assum_problems (~1, Bi);
   in
     (case find_index (fn asm => Envir.aeconv (asm, concl)) asms of
       ~1 => raise THM ("eq_assumption", 0, [state])
     | n =>
         Thm (deriv_rule1 (Proofterm.assumption_proof Bs Bi (n + 1)) der,
          {cert = cert,
           tags = [],
           maxidx = maxidx,
           constraints = constraints,
           shyps = shyps,
           hyps = hyps,
           tpairs = tpairs,
           prop = Logic.list_implies (Bs, C)}))
   end;
 
 
 (*For rotate_tac: fast rotation of assumptions of subgoal i*)
 fun rotate_rule k i state =
   let
     val Thm (der, {cert, maxidx, constraints, shyps, hyps, ...}) = state;
     val (tpairs, Bs, Bi, C) = dest_state (state, i);
     val params = Term.strip_all_vars Bi;
     val rest = Term.strip_all_body Bi;
     val asms = Logic.strip_imp_prems rest
     val concl = Logic.strip_imp_concl rest;
     val n = length asms;
     val m = if k < 0 then n + k else k;
     val Bi' =
       if 0 = m orelse m = n then Bi
       else if 0 < m andalso m < n then
         let val (ps, qs) = chop m asms
         in Logic.list_all (params, Logic.list_implies (qs @ ps, concl)) end
       else raise THM ("rotate_rule", k, [state]);
   in
     Thm (deriv_rule1 (Proofterm.rotate_proof Bs Bi' params asms m) der,
      {cert = cert,
       tags = [],
       maxidx = maxidx,
       constraints = constraints,
       shyps = shyps,
       hyps = hyps,
       tpairs = tpairs,
       prop = Logic.list_implies (Bs @ [Bi'], C)})
   end;
 
 
 (*Rotates a rule's premises to the left by k, leaving the first j premises
   unchanged.  Does nothing if k=0 or if k equals n-j, where n is the
   number of premises.  Useful with eresolve_tac and underlies defer_tac*)
 fun permute_prems j k rl =
   let
     val Thm (der, {cert, maxidx, constraints, shyps, hyps, tpairs, prop, ...}) = rl;
     val prems = Logic.strip_imp_prems prop
     and concl = Logic.strip_imp_concl prop;
     val moved_prems = List.drop (prems, j)
     and fixed_prems = List.take (prems, j)
       handle General.Subscript => raise THM ("permute_prems: j", j, [rl]);
     val n_j = length moved_prems;
     val m = if k < 0 then n_j + k else k;
     val (prems', prop') =
       if 0 = m orelse m = n_j then (prems, prop)
       else if 0 < m andalso m < n_j then
         let
           val (ps, qs) = chop m moved_prems;
           val prems' = fixed_prems @ qs @ ps;
         in (prems', Logic.list_implies (prems', concl)) end
       else raise THM ("permute_prems: k", k, [rl]);
   in
     Thm (deriv_rule1 (Proofterm.permute_prems_proof prems' j m) der,
      {cert = cert,
       tags = [],
       maxidx = maxidx,
       constraints = constraints,
       shyps = shyps,
       hyps = hyps,
       tpairs = tpairs,
       prop = prop'})
   end;
 
 
 (* strip_apply f B A strips off all assumptions/parameters from A
    introduced by lifting over B, and applies f to remaining part of A*)
 fun strip_apply f =
   let fun strip (Const ("Pure.imp", _) $ _  $ B1)
                 (Const ("Pure.imp", _) $ A2 $ B2) = Logic.mk_implies (A2, strip B1 B2)
         | strip ((c as Const ("Pure.all", _)) $ Abs (_, _, t1))
                 (      Const ("Pure.all", _)  $ Abs (a, T, t2)) = c $ Abs (a, T, strip t1 t2)
         | strip _ A = f A
   in strip end;
 
 fun strip_lifted (Const ("Pure.imp", _) $ _ $ B1)
                  (Const ("Pure.imp", _) $ _ $ B2) = strip_lifted B1 B2
   | strip_lifted (Const ("Pure.all", _) $ Abs (_, _, t1))
                  (Const ("Pure.all", _) $ Abs (_, _, t2)) = strip_lifted t1 t2
   | strip_lifted _ A = A;
 
 (*Use the alist to rename all bound variables and some unknowns in a term
   dpairs = current disagreement pairs;  tpairs = permanent ones (flexflex);
   Preserves unknowns in tpairs and on lhs of dpairs. *)
 fun rename_bvs [] _ _ _ _ = K I
   | rename_bvs al dpairs tpairs B As =
       let
         val add_var = fold_aterms (fn Var ((x, _), _) => insert (op =) x | _ => I);
         val vids = []
           |> fold (add_var o fst) dpairs
           |> fold (add_var o fst) tpairs
           |> fold (add_var o snd) tpairs;
         val vids' = fold (add_var o strip_lifted B) As [];
         (*unknowns appearing elsewhere be preserved!*)
         val al' = distinct ((op =) o apply2 fst)
           (filter_out (fn (x, y) =>
              not (member (op =) vids' x) orelse
              member (op =) vids x orelse member (op =) vids y) al);
         val unchanged = filter_out (AList.defined (op =) al') vids';
         fun del_clashing clash xs _ [] qs =
               if clash then del_clashing false xs xs qs [] else qs
           | del_clashing clash xs ys ((p as (x, y)) :: ps) qs =
               if member (op =) ys y
               then del_clashing true (x :: xs) (x :: ys) ps qs
               else del_clashing clash xs (y :: ys) ps (p :: qs);
         val al'' = del_clashing false unchanged unchanged al' [];
         fun rename (t as Var ((x, i), T)) =
               (case AList.lookup (op =) al'' x of
                  SOME y => Var ((y, i), T)
                | NONE => t)
           | rename (Abs (x, T, t)) =
               Abs (the_default x (AList.lookup (op =) al x), T, rename t)
           | rename (f $ t) = rename f $ rename t
           | rename t = t;
         fun strip_ren f Ai = f rename B Ai
       in strip_ren end;
 
 (*Function to rename bounds/unknowns in the argument, lifted over B*)
 fun rename_bvars dpairs =
   rename_bvs (fold_rev Term.match_bvars dpairs []) dpairs;
 
 
 
 (*** RESOLUTION ***)
 
 (** Lifting optimizations **)
 
 (*strip off pairs of assumptions/parameters in parallel -- they are
   identical because of lifting*)
 fun strip_assums2 (Const("Pure.imp", _) $ _ $ B1,
                    Const("Pure.imp", _) $ _ $ B2) = strip_assums2 (B1,B2)
   | strip_assums2 (Const("Pure.all",_)$Abs(a,T,t1),
                    Const("Pure.all",_)$Abs(_,_,t2)) =
       let val (B1,B2) = strip_assums2 (t1,t2)
       in  (Abs(a,T,B1), Abs(a,T,B2))  end
   | strip_assums2 BB = BB;
 
 
 (*Faster normalization: skip assumptions that were lifted over*)
 fun norm_term_skip env 0 t = Envir.norm_term env t
   | norm_term_skip env n (Const ("Pure.all", _) $ Abs (a, T, t)) =
       let
         val T' = Envir.norm_type (Envir.type_env env) T
         (*Must instantiate types of parameters because they are flattened;
           this could be a NEW parameter*)
       in Logic.all_const T' $ Abs (a, T', norm_term_skip env n t) end
   | norm_term_skip env n (Const ("Pure.imp", _) $ A $ B) =
       Logic.mk_implies (A, norm_term_skip env (n - 1) B)
   | norm_term_skip _ _ _ = error "norm_term_skip: too few assumptions??";
 
 
 (*unify types of schematic variables (non-lifted case)*)
 fun unify_var_types context (th1, th2) env =
   let
     fun unify_vars (T :: Us) = fold (fn U => Pattern.unify_types context (T, U)) Us
       | unify_vars _ = I;
     val add_vars =
       full_prop_of #>
       fold_aterms (fn Var v => Vartab.insert_list (op =) v | _ => I);
-    val vars = Vartab.empty |> add_vars th1 |> add_vars th2;
+    val vars = Vartab.build (add_vars th1 #> add_vars th2);
   in SOME (Vartab.fold (unify_vars o #2) vars env) end
   handle Pattern.Unif => NONE;
 
 (*Composition of object rule r=(A1...Am/B) with proof state s=(B1...Bn/C)
   Unifies B with Bi, replacing subgoal i    (1 <= i <= n)
   If match then forbid instantiations in proof state
   If lifted then shorten the dpair using strip_assums2.
   If eres_flg then simultaneously proves A1 by assumption.
   nsubgoal is the number of new subgoals (written m above).
   Curried so that resolution calls dest_state only once.
 *)
 local exception COMPOSE
 in
 fun bicompose_aux opt_ctxt {flatten, match, incremented} (state, (stpairs, Bs, Bi, C), lifted)
                         (eres_flg, orule, nsubgoal) =
  let val Thm (sder, {maxidx=smax, constraints = constraints2, shyps = shyps2, hyps = hyps2, ...}) = state
      and Thm (rder, {maxidx=rmax, constraints = constraints1, shyps = shyps1, hyps = hyps1,
              tpairs=rtpairs, prop=rprop,...}) = orule
          (*How many hyps to skip over during normalization*)
      and nlift = Logic.count_prems (strip_all_body Bi) + (if eres_flg then ~1 else 0)
      val (context, cert) =
        make_context_certificate [state, orule] opt_ctxt (join_certificate2 (state, orule));
      (*Add new theorem with prop = "\<lbrakk>Bs; As\<rbrakk> \<Longrightarrow> C" to thq*)
      fun addth A (As, oldAs, rder', n) ((env, tpairs), thq) =
        let val normt = Envir.norm_term env;
            (*perform minimal copying here by examining env*)
            val (ntpairs, normp) =
              if Envir.is_empty env then (tpairs, (Bs @ As, C))
              else
              let val ntps = map (apply2 normt) tpairs
              in if Envir.above env smax then
                   (*no assignments in state; normalize the rule only*)
                   if lifted
                   then (ntps, (Bs @ map (norm_term_skip env nlift) As, C))
                   else (ntps, (Bs @ map normt As, C))
                 else if match then raise COMPOSE
                 else (*normalize the new rule fully*)
                   (ntps, (map normt (Bs @ As), normt C))
              end
            val constraints' =
              union_constraints constraints1 constraints2
              |> insert_constraints_env (Context.certificate_theory cert) env;
            fun bicompose_proof prf1 prf2 =
              Proofterm.bicompose_proof flatten (map normt Bs) (map normt As) A oldAs n (nlift+1)
                prf1 prf2
            val th =
              Thm (deriv_rule2
                    (if Envir.is_empty env then bicompose_proof
                     else if Envir.above env smax then bicompose_proof o Proofterm.norm_proof' env
                     else Proofterm.norm_proof' env oo bicompose_proof) rder' sder,
                 {tags = [],
                  maxidx = Envir.maxidx_of env,
                  constraints = constraints',
                  shyps = Envir.insert_sorts env (Sorts.union shyps1 shyps2),
                  hyps = union_hyps hyps1 hyps2,
                  tpairs = ntpairs,
                  prop = Logic.list_implies normp,
                  cert = cert})
         in  Seq.cons th thq  end  handle COMPOSE => thq;
      val (rAs,B) = Logic.strip_prems(nsubgoal, [], rprop)
        handle TERM _ => raise THM("bicompose: rule", 0, [orule,state]);
      (*Modify assumptions, deleting n-th if n>0 for e-resolution*)
      fun newAs(As0, n, dpairs, tpairs) =
        let val (As1, rder') =
          if not lifted then (As0, rder)
          else
            let val rename = rename_bvars dpairs tpairs B As0
            in (map (rename strip_apply) As0,
              deriv_rule1 (Proofterm.map_proof_terms (rename K) I) rder)
            end;
        in (map (if flatten then (Logic.flatten_params n) else I) As1, As1, rder', n)
           handle TERM _ =>
           raise THM("bicompose: 1st premise", 0, [orule])
        end;
      val BBi = if lifted then strip_assums2(B,Bi) else (B,Bi);
      val dpairs = BBi :: (rtpairs@stpairs);
 
      (*elim-resolution: try each assumption in turn*)
      fun eres _ [] = raise THM ("bicompose: no premises", 0, [orule, state])
        | eres env (A1 :: As) =
            let
              val A = SOME A1;
              val (close, asms, concl) = Logic.assum_problems (nlift + 1, A1);
              val concl' = close concl;
              fun tryasms [] _ = Seq.empty
                | tryasms (asm :: rest) n =
                    if Term.could_unify (asm, concl) then
                      let val asm' = close asm in
                        (case Seq.pull (Unify.unifiers (context, env, (asm', concl') :: dpairs)) of
                          NONE => tryasms rest (n + 1)
                        | cell as SOME ((_, tpairs), _) =>
                            Seq.it_right (addth A (newAs (As, n, [BBi, (concl', asm')], tpairs)))
                              (Seq.make (fn () => cell),
                               Seq.make (fn () => Seq.pull (tryasms rest (n + 1)))))
                      end
                    else tryasms rest (n + 1);
            in tryasms asms 1 end;
 
      (*ordinary resolution*)
      fun res env =
        (case Seq.pull (Unify.unifiers (context, env, dpairs)) of
          NONE => Seq.empty
        | cell as SOME ((_, tpairs), _) =>
            Seq.it_right (addth NONE (newAs (rev rAs, 0, [BBi], tpairs)))
              (Seq.make (fn () => cell), Seq.empty));
 
      val env0 = Envir.empty (Int.max (rmax, smax));
  in
    (case if incremented then SOME env0 else unify_var_types context (state, orule) env0 of
      NONE => Seq.empty
    | SOME env => if eres_flg then eres env (rev rAs) else res env)
  end;
 end;
 
 fun bicompose opt_ctxt flags arg i state =
   bicompose_aux opt_ctxt flags (state, dest_state (state,i), false) arg;
 
 (*Quick test whether rule is resolvable with the subgoal with hyps Hs
   and conclusion B.  If eres_flg then checks 1st premise of rule also*)
 fun could_bires (Hs, B, eres_flg, rule) =
     let fun could_reshyp (A1::_) = exists (fn H => Term.could_unify (A1, H)) Hs
           | could_reshyp [] = false;  (*no premise -- illegal*)
     in  Term.could_unify(concl_of rule, B) andalso
         (not eres_flg  orelse  could_reshyp (prems_of rule))
     end;
 
 (*Bi-resolution of a state with a list of (flag,rule) pairs.
   Puts the rule above:  rule/state.  Renames vars in the rules. *)
 fun biresolution opt_ctxt match brules i state =
     let val (stpairs, Bs, Bi, C) = dest_state(state,i);
         val lift = lift_rule (cprem_of state i);
         val B = Logic.strip_assums_concl Bi;
         val Hs = Logic.strip_assums_hyp Bi;
         val compose =
           bicompose_aux opt_ctxt {flatten = true, match = match, incremented = true}
             (state, (stpairs, Bs, Bi, C), true);
         fun res [] = Seq.empty
           | res ((eres_flg, rule)::brules) =
               if Config.get_generic (make_context [state] opt_ctxt (cert_of state))
                   Pattern.unify_trace_failure orelse could_bires (Hs, B, eres_flg, rule)
               then Seq.make (*delay processing remainder till needed*)
                   (fn()=> SOME(compose (eres_flg, lift rule, nprems_of rule),
                                res brules))
               else res brules
     in  Seq.flat (res brules)  end;
 
 (*Resolution: exactly one resolvent must be produced*)
 fun tha RSN (i, thb) =
   (case Seq.chop 2 (biresolution NONE false [(false, tha)] i thb) of
     ([th], _) => solve_constraints th
   | ([], _) => raise THM ("RSN: no unifiers", i, [tha, thb])
   | _ => raise THM ("RSN: multiple unifiers", i, [tha, thb]));
 
 (*Resolution: P \<Longrightarrow> Q, Q \<Longrightarrow> R gives P \<Longrightarrow> R*)
 fun tha RS thb = tha RSN (1,thb);
 
 
 
 (**** Type classes ****)
 
 fun standard_tvars thm =
   let
     val thy = theory_of_thm thm;
     val tvars = rev (Term.add_tvars (prop_of thm) []);
     val names = Name.invent Name.context Name.aT (length tvars);
     val tinst =
       map2 (fn (ai, S) => fn b => ((ai, S), global_ctyp_of thy (TVar ((b, 0), S)))) tvars names;
   in instantiate (tinst, []) thm end
 
 
 (* class relations *)
 
 val is_classrel = Symreltab.defined o get_classrels;
 
 fun complete_classrels thy =
   let
     fun complete (c, (_, (all_preds, all_succs))) (finished1, thy1) =
       let
         fun compl c1 c2 (finished2, thy2) =
           if is_classrel thy2 (c1, c2) then (finished2, thy2)
           else
             (false,
               thy2
               |> (map_classrels o Symreltab.update) ((c1, c2),
                 (the_classrel thy2 (c1, c) RS the_classrel thy2 (c, c2))
                 |> standard_tvars
                 |> close_derivation \<^here>
                 |> tap (expose_proof thy2)
                 |> trim_context));
 
         val proven = is_classrel thy1;
         val preds = Graph.Keys.fold (fn c1 => proven (c1, c) ? cons c1) all_preds [];
         val succs = Graph.Keys.fold (fn c2 => proven (c, c2) ? cons c2) all_succs [];
       in
         fold_product compl preds succs (finished1, thy1)
       end;
   in
     (case Graph.fold complete (Sorts.classes_of (Sign.classes_of thy)) (true, thy) of
       (true, _) => NONE
     | (_, thy') => SOME thy')
   end;
 
 
 (* type arities *)
 
 fun thynames_of_arity thy (a, c) =
   (get_arities thy, []) |-> Aritytab.fold
     (fn ((a', _, c'), (_, name, ser)) => (a = a' andalso c = c') ? cons (name, ser))
   |> sort (int_ord o apply2 #2) |> map #1;
 
 fun insert_arity_completions thy ((t, Ss, c), (th, thy_name, ser)) (finished, arities) =
   let
     val completions =
       Sign.super_classes thy c |> map_filter (fn c1 =>
         if Aritytab.defined arities (t, Ss, c1) then NONE
         else
           let
             val th1 =
               (th RS the_classrel thy (c, c1))
               |> standard_tvars
               |> close_derivation \<^here>
               |> tap (expose_proof thy)
               |> trim_context;
           in SOME ((t, Ss, c1), (th1, thy_name, ser)) end);
     val finished' = finished andalso null completions;
     val arities' = fold Aritytab.update completions arities;
   in (finished', arities') end;
 
 fun complete_arities thy =
   let
     val arities = get_arities thy;
     val (finished, arities') =
       Aritytab.fold (insert_arity_completions thy) arities (true, get_arities thy);
   in
     if finished then NONE
     else SOME (map_arities (K arities') thy)
   end;
 
 val _ =
   Theory.setup
    (Theory.at_begin complete_classrels #>
     Theory.at_begin complete_arities);
 
 
 (* primitive rules *)
 
 fun add_classrel raw_th thy =
   let
     val th = strip_shyps (transfer thy raw_th);
     val th' = th |> unconstrainT |> tap (expose_proof thy) |> trim_context;
     val prop = plain_prop_of th;
     val (c1, c2) = Logic.dest_classrel prop;
   in
     thy
     |> Sign.primitive_classrel (c1, c2)
     |> map_classrels (Symreltab.update ((c1, c2), th'))
     |> perhaps complete_classrels
     |> perhaps complete_arities
   end;
 
 fun add_arity raw_th thy =
   let
     val th = strip_shyps (transfer thy raw_th);
     val th' = th |> unconstrainT |> tap (expose_proof thy) |> trim_context;
     val prop = plain_prop_of th;
     val (t, Ss, c) = Logic.dest_arity prop;
     val ar = ((t, Ss, c), (th', Context.theory_name thy, serial ()));
   in
     thy
     |> Sign.primitive_arity (t, Ss, [c])
     |> map_arities (Aritytab.update ar #> curry (insert_arity_completions thy ar) true #> #2)
   end;
 
 end;
 
 structure Basic_Thm: BASIC_THM = Thm;
 open Basic_Thm;
diff --git a/src/Pure/thm_deps.ML b/src/Pure/thm_deps.ML
--- a/src/Pure/thm_deps.ML
+++ b/src/Pure/thm_deps.ML
@@ -1,143 +1,144 @@
 (*  Title:      Pure/thm_deps.ML
     Author:     Stefan Berghofer, TU Muenchen
     Author:     Makarius
 
 Dependencies of theorems wrt. internal derivation.
 *)
 
 signature THM_DEPS =
 sig
   val all_oracles: thm list -> Proofterm.oracle list
   val has_skip_proof: thm list -> bool
   val pretty_thm_oracles: Proof.context -> thm list -> Pretty.T
   val thm_deps: theory -> thm list -> (Proofterm.thm_id * Thm_Name.T) list
   val pretty_thm_deps: theory -> thm list -> Pretty.T
   val unused_thms_cmd: theory list * theory list -> (string * thm) list
 end;
 
 structure Thm_Deps: THM_DEPS =
 struct
 
 (* oracles *)
 
 fun all_oracles thms =
   let
     fun collect (PBody {oracles, thms, ...}) =
       (if null oracles then I else apfst (cons oracles)) #>
       (tap Proofterm.join_thms thms |> fold (fn (i, thm_node) => fn (res, seen) =>
         if Inttab.defined seen i then (res, seen)
         else
           let val body = Future.join (Proofterm.thm_node_body thm_node)
           in collect body (res, Inttab.update (i, ()) seen) end));
     val bodies = map Thm.proof_body_of thms;
   in fold collect bodies ([], Inttab.empty) |> #1 |> Proofterm.unions_oracles end;
 
 fun has_skip_proof thms =
   all_oracles thms |> exists (fn ((name, _), _) => name = \<^oracle_name>\<open>skip_proof\<close>);
 
 fun pretty_thm_oracles ctxt thms =
   let
     val thy = Proof_Context.theory_of ctxt;
     fun prt_ora (name, pos) = Thm.pretty_oracle ctxt name :: Pretty.here pos;
     fun prt_oracle (ora, NONE) = prt_ora ora
       | prt_oracle (ora, SOME prop) =
           prt_ora ora @ [Pretty.str ":", Pretty.brk 1, Syntax.pretty_term_global thy prop];
     val oracles =
       (case try all_oracles thms of
         SOME oracles => oracles
       | NONE => error "Malformed proofs")
   in Pretty.big_list "oracles:" (map (Pretty.item o prt_oracle) oracles) end;
 
 
 (* thm_deps *)
 
 fun thm_deps thy =
   let
     val lookup = Global_Theory.lookup_thm_id thy;
     fun deps (i, thm_node) res =
       if Inttab.defined res i then res
       else
         let val thm_id = Proofterm.thm_id (i, thm_node) in
           (case lookup thm_id of
             SOME thm_name =>
               Inttab.update (i, SOME (thm_id, thm_name)) res
           | NONE =>
               Inttab.update (i, NONE) res
               |> fold deps (Proofterm.thm_node_thms thm_node))
         end;
   in
     fn thms =>
-      (fold (fold deps o Thm.thm_deps o Thm.transfer thy) thms Inttab.empty, [])
+      (Inttab.build (fold (fold deps o Thm.thm_deps o Thm.transfer thy) thms), [])
       |-> Inttab.fold_rev (fn (_, SOME entry) => cons entry | _ => I)
   end;
 
 fun pretty_thm_deps thy thms =
   let
     val ctxt = Proof_Context.init_global thy;
     val deps =
       (case try (thm_deps thy) thms of
         SOME deps => deps
       | NONE => error "Malformed proofs");
     val items =
       map #2 deps
       |> map (fn (name, i) => (Proof_Context.markup_extern_fact ctxt name, i))
       |> sort_by (#2 o #1)
       |> map (fn ((marks, xname), i) =>
           Pretty.item [Pretty.marks_str (marks, Thm_Name.print (xname, i))]);
   in Pretty.big_list ("dependencies: " ^ string_of_int (length items)) items end;
 
 
 (* unused_thms_cmd *)
 
 fun unused_thms_cmd (base_thys, thys) =
   let
     fun add_fact transfer space (name, ths) =
       if exists (fn thy => Global_Theory.defined_fact thy name) base_thys then I
       else
         let val {concealed, group, ...} = Name_Space.the_entry space name in
           fold_rev (transfer #> (fn th =>
             (case Thm.derivation_name th of
               "" => I
             | a => cons (a, (th, concealed, group))))) ths
         end;
     fun add_facts thy =
       let
         val transfer = Global_Theory.transfer_theories thy;
         val facts = Global_Theory.facts_of thy;
       in Facts.fold_static (add_fact transfer (Facts.space_of facts)) facts end;
 
     val new_thms =
       fold add_facts thys []
       |> sort_distinct (string_ord o apply2 #1);
 
     val used =
       Proofterm.fold_body_thms
         (fn {name = a, ...} => a <> "" ? Symtab.update (a, ()))
         (map Proofterm.strip_thm_body (Thm.proof_bodies_of (map (#1 o #2) new_thms)))
         Symtab.empty;
 
     fun is_unused a = not (Symtab.defined used a);
 
     (*groups containing at least one used theorem*)
-    val used_groups = fold (fn (a, (_, _, group)) =>
-      if is_unused a then I
-      else
-        (case group of
-          NONE => I
-        | SOME grp => Inttab.update (grp, ()))) new_thms Inttab.empty;
+    val used_groups =
+      Inttab.build (new_thms |> fold (fn (a, (_, _, group)) =>
+        if is_unused a then I
+        else
+          (case group of
+            NONE => I
+          | SOME grp => Inttab.update (grp, ()))));
 
     val (thms', _) = fold (fn (a, (th, concealed, group)) => fn q as (thms, seen_groups) =>
       if not concealed andalso
         (* FIXME replace by robust treatment of thm groups *)
         Thm.legacy_get_kind th = Thm.theoremK andalso is_unused a
       then
         (case group of
            NONE => ((a, th) :: thms, seen_groups)
          | SOME grp =>
              if Inttab.defined used_groups grp orelse
                Inttab.defined seen_groups grp then q
              else ((a, th) :: thms, Inttab.update (grp, ()) seen_groups))
       else q) new_thms ([], Inttab.empty);
   in rev thms' end;
 
 end;
diff --git a/src/Pure/type.ML b/src/Pure/type.ML
--- a/src/Pure/type.ML
+++ b/src/Pure/type.ML
@@ -1,713 +1,713 @@
 (*  Title:      Pure/type.ML
     Author:     Tobias Nipkow, Lawrence C Paulson, and Markus Wenzel
 
 Type signatures and certified types, special treatment of type vars,
 matching and unification of types, extend and merge type signatures.
 *)
 
 signature TYPE =
 sig
   (*constraints*)
   val mark_polymorphic: typ -> typ
   val constraint: typ -> term -> term
   val constraint_type: Proof.context -> typ -> typ
   val strip_constraints: term -> term
   val appl_error: Proof.context -> term -> typ -> term -> typ -> string
   (*type signatures and certified types*)
   datatype decl =
     LogicalType of int |
     Abbreviation of string list * typ * bool |
     Nonterminal
   type tsig
   val eq_tsig: tsig * tsig -> bool
   val rep_tsig: tsig ->
    {classes: Name_Space.T * Sorts.algebra,
     default: sort,
     types: decl Name_Space.table,
     log_types: string list}
   val change_base: bool -> tsig -> tsig
   val change_ignore: tsig -> tsig
   val empty_tsig: tsig
   val class_space: tsig -> Name_Space.T
   val defaultS: tsig -> sort
   val logical_types: tsig -> string list
   val eq_sort: tsig -> sort * sort -> bool
   val subsort: tsig -> sort * sort -> bool
   val of_sort: tsig -> typ * sort -> bool
   val inter_sort: tsig -> sort * sort -> sort
   val cert_class: tsig -> class -> class
   val cert_sort: tsig -> sort -> sort
   val minimize_sort: tsig -> sort -> sort
   val witness_sorts: tsig -> (typ * sort) list -> sort list -> (typ * sort) list
   type mode
   val mode_default: mode
   val mode_syntax: mode
   val mode_abbrev: mode
   val get_mode: Proof.context -> mode
   val set_mode: mode -> Proof.context -> Proof.context
   val restore_mode: Proof.context -> Proof.context -> Proof.context
   val type_space: tsig -> Name_Space.T
   val type_alias: Name_Space.naming -> binding -> string -> tsig -> tsig
   val check_decl: Context.generic -> tsig ->
     xstring * Position.T -> (string * Position.report list) * decl
   val the_decl: tsig -> string * Position.T -> decl
   val cert_typ_mode: mode -> tsig -> typ -> typ
   val cert_typ: tsig -> typ -> typ
   val arity_number: tsig -> string -> int
   val arity_sorts: Context.generic -> tsig -> string -> sort -> sort list
 
   (*special treatment of type vars*)
   val sort_of_atyp: typ -> sort
   val strip_sorts: typ -> typ
   val strip_sorts_dummy: typ -> typ
   val no_tvars: typ -> typ
   val varify_global: (string * sort) list -> term -> ((string * sort) * indexname) list * term
   val legacy_freeze_thaw_type: typ -> typ * (typ -> typ)
   val legacy_freeze_type: typ -> typ
   val legacy_freeze_thaw: term -> term * (term -> term)
   val legacy_freeze: term -> term
 
   (*matching and unification*)
   exception TYPE_MATCH
   type tyenv = (sort * typ) Vartab.table
   val lookup: tyenv -> indexname * sort -> typ option
   val devar: tyenv -> typ -> typ
   val typ_match: tsig -> typ * typ -> tyenv -> tyenv
   val typ_instance: tsig -> typ * typ -> bool
   val raw_match: typ * typ -> tyenv -> tyenv
   val raw_matches: typ list * typ list -> tyenv -> tyenv
   val could_match: typ * typ -> bool
   val could_matches: typ list * typ list -> bool
   val raw_instance: typ * typ -> bool
   exception TUNIFY
   val unify: tsig -> typ * typ -> tyenv * int -> tyenv * int
   val raw_unify: typ * typ -> tyenv -> tyenv
   val raw_unifys: typ list * typ list -> tyenv -> tyenv
   val could_unify: typ * typ -> bool
   val could_unifys: typ list * typ list -> bool
   val unified: tyenv -> typ * typ -> bool
 
   (*extend and merge type signatures*)
   val add_class: Context.generic -> binding * class list -> tsig -> tsig
   val hide_class: bool -> string -> tsig -> tsig
   val set_defsort: sort -> tsig -> tsig
   val add_type: Context.generic -> binding * int -> tsig -> tsig
   val add_abbrev: Context.generic -> binding * string list * typ -> tsig -> tsig
   val add_nonterminal: Context.generic -> binding -> tsig -> tsig
   val hide_type: bool -> string -> tsig -> tsig
   val add_arity: Context.generic -> arity -> tsig -> tsig
   val add_classrel: Context.generic -> class * class -> tsig -> tsig
   val merge_tsig: Context.generic -> tsig * tsig -> tsig
 end;
 
 structure Type: TYPE =
 struct
 
 (** constraints **)
 
 (*indicate polymorphic Vars*)
 fun mark_polymorphic T = Type ("_polymorphic_", [T]);
 
 fun constraint T t =
   if T = dummyT then t
   else Const ("_type_constraint_", T --> T) $ t;
 
 fun constraint_type ctxt T =
   let fun err () = error ("Malformed internal type constraint: " ^ Syntax.string_of_typ ctxt T);
   in (case T of Type ("fun", [A, B]) => if A = B then A else err () | _ => err ()) end;
 
 fun strip_constraints (Const ("_type_constraint_", _) $ t) = strip_constraints t
   | strip_constraints (t $ u) = strip_constraints t $ strip_constraints u
   | strip_constraints (Abs (x, T, t)) = Abs (x, T, strip_constraints t)
   | strip_constraints a = a;
 
 fun appl_error ctxt (Const ("_type_constraint_", Type ("fun", [T, _]))) _ u U =
       cat_lines
        ["Failed to meet type constraint:", "",
         Pretty.string_of (Pretty.block
          [Pretty.str "Term:", Pretty.brk 2, Syntax.pretty_term ctxt u,
           Pretty.str " ::", Pretty.brk 1, Syntax.pretty_typ ctxt U]),
         Pretty.string_of (Pretty.block
          [Pretty.str "Type:", Pretty.brk 2, Syntax.pretty_typ ctxt T])]
   | appl_error ctxt t T u U =
       cat_lines
        ["Type error in application: " ^
           (case T of
             Type ("fun", _) => "incompatible operand type"
           | _ => "operator not of function type"),
         "",
         Pretty.string_of (Pretty.block
           [Pretty.str "Operator:", Pretty.brk 2, Syntax.pretty_term ctxt t,
             Pretty.str " ::", Pretty.brk 1, Syntax.pretty_typ ctxt T]),
         Pretty.string_of (Pretty.block
           [Pretty.str "Operand:", Pretty.brk 3, Syntax.pretty_term ctxt u,
             Pretty.str " ::", Pretty.brk 1, Syntax.pretty_typ ctxt U])];
 
 
 
 (** type signatures and certified types **)
 
 (* type declarations *)
 
 datatype decl =
   LogicalType of int |
   Abbreviation of string list * typ * bool |
   Nonterminal;
 
 
 (* type tsig *)
 
 datatype tsig =
   TSig of {
     classes: Name_Space.T * Sorts.algebra,  (*order-sorted algebra of type classes*)
     default: sort,                          (*default sort on input*)
     types: decl Name_Space.table,           (*declared types*)
     log_types: string list};                (*logical types sorted by number of arguments*)
 
 fun eq_tsig
    (TSig {classes = classes1, default = default1, types = types1, log_types = _},
     TSig {classes = classes2, default = default2, types = types2, log_types = _}) =
   pointer_eq (classes1, classes2) andalso
   default1 = default2 andalso
   pointer_eq (types1, types2);
 
 fun rep_tsig (TSig comps) = comps;
 
 fun make_tsig (classes, default, types, log_types) =
   TSig {classes = classes, default = default, types = types, log_types = log_types};
 
 fun change_base begin (TSig {classes, default, types, log_types}) =
   make_tsig (classes, default, Name_Space.change_base begin types, log_types);
 
 fun change_ignore (TSig {classes, default, types, log_types}) =
   make_tsig (classes, default, Name_Space.change_ignore types, log_types);
 
 fun build_tsig (classes, default, types) =
   let
     val log_types =
       Name_Space.fold_table (fn (c, LogicalType n) => cons (c, n) | _ => I) types []
       |> Library.sort (int_ord o apply2 snd) |> map fst;
   in make_tsig (classes, default, types, log_types) end;
 
 fun map_tsig f (TSig {classes, default, types, log_types = _}) =
   build_tsig (f (classes, default, types));
 
 val empty_tsig =
   build_tsig ((Name_Space.empty Markup.classN, Sorts.empty_algebra), [],
     Name_Space.empty_table Markup.type_nameN);
 
 
 (* classes and sorts *)
 
 val class_space = #1 o #classes o rep_tsig;
 
 fun defaultS (TSig {default, ...}) = default;
 fun logical_types (TSig {log_types, ...}) = log_types;
 
 fun eq_sort (TSig {classes, ...}) = Sorts.sort_eq (#2 classes);
 fun subsort (TSig {classes, ...}) = Sorts.sort_le (#2 classes);
 fun of_sort (TSig {classes, ...}) = Sorts.of_sort (#2 classes);
 fun inter_sort (TSig {classes, ...}) = Sorts.inter_sort (#2 classes);
 
 fun cert_class (TSig {classes = (_, algebra), ...}) c =
   if can (Graph.get_entry (Sorts.classes_of algebra)) c then c
   else raise TYPE ("Undeclared class: " ^ quote c, [], []);
 
 val cert_sort = map o cert_class;
 
 fun minimize_sort (TSig {classes, ...}) = Sorts.minimize_sort (#2 classes);
 
 fun witness_sorts (TSig {classes, log_types, ...}) =
   Sorts.witness_sorts (#2 classes) log_types;
 
 
 (* certification mode *)
 
 datatype mode = Mode of {normalize: bool, logical: bool};
 
 val mode_default = Mode {normalize = true, logical = true};
 val mode_syntax = Mode {normalize = true, logical = false};
 val mode_abbrev = Mode {normalize = false, logical = false};
 
 structure Mode = Proof_Data
 (
   type T = mode;
   fun init _ = mode_default;
 );
 
 val get_mode = Mode.get;
 fun set_mode mode = Mode.map (K mode);
 fun restore_mode ctxt = set_mode (get_mode ctxt);
 
 
 (* types *)
 
 val type_space = Name_Space.space_of_table o #types o rep_tsig;
 
 fun type_alias naming binding name = map_tsig (fn (classes, default, types) =>
   (classes, default, (Name_Space.alias_table naming binding name types)));
 
 
 fun undecl_type c = "Undeclared type constructor: " ^ quote c;
 
 fun lookup_type (TSig {types, ...}) = Name_Space.lookup types;
 
 fun check_decl context (TSig {types, ...}) (c, pos) =
   Name_Space.check_reports context types (c, [pos]);
 
 fun the_decl tsig (c, pos) =
   (case lookup_type tsig c of
     NONE => error (undecl_type c ^ Position.here pos)
   | SOME decl => decl);
 
 
 (* certified types *)
 
 fun bad_nargs t = "Bad number of arguments for type constructor: " ^ quote t;
 
 local
 
 fun inst_typ env (Type (c, Ts)) = Type (c, map (inst_typ env) Ts)
   | inst_typ env (T as TFree (x, _)) = the_default T (AList.lookup (op =) env x)
   | inst_typ _ T = T;
 
 in
 
 fun cert_typ_mode (Mode {normalize, logical}) tsig ty =
   let
     fun err msg = raise TYPE (msg, [ty], []);
 
     val check_logical =
       if logical then fn c => err ("Illegal occurrence of syntactic type: " ^ quote c)
       else fn _ => ();
 
     fun cert (T as Type (c, Ts)) =
           let
             val Ts' = map cert Ts;
             fun nargs n = if length Ts <> n then err (bad_nargs c) else ();
           in
             (case the_decl tsig (c, Position.none) of
               LogicalType n => (nargs n; Type (c, Ts'))
             | Abbreviation (vs, U, syn) =>
                (nargs (length vs);
                 if syn then check_logical c else ();
                 if normalize then inst_typ (vs ~~ Ts') U
                 else Type (c, Ts'))
             | Nonterminal => (nargs 0; check_logical c; T))
           end
       | cert (TFree (x, S)) = TFree (x, cert_sort tsig S)
       | cert (TVar (xi as (_, i), S)) =
           if i < 0 then
             err ("Malformed type variable: " ^ quote (Term.string_of_vname xi))
           else TVar (xi, cert_sort tsig S);
 
     val ty' = cert ty;
   in if ty = ty' then ty else ty' end;  (*avoid copying of already normal type*)
 
 val cert_typ = cert_typ_mode mode_default;
 
 end;
 
 
 (* type arities *)
 
 fun arity_number tsig a =
   (case lookup_type tsig a of
     SOME (LogicalType n) => n
   | _ => error (undecl_type a));
 
 fun arity_sorts _ tsig a [] = replicate (arity_number tsig a) []
   | arity_sorts context (TSig {classes, ...}) a S =
       Sorts.mg_domain (#2 classes) a S
         handle Sorts.CLASS_ERROR err => error (Sorts.class_error context err);
 
 
 
 (** special treatment of type vars **)
 
 (* sort_of_atyp *)
 
 fun sort_of_atyp (TFree (_, S)) = S
   | sort_of_atyp (TVar (_, S)) = S
   | sort_of_atyp T = raise TYPE ("sort_of_atyp", [T], []);
 
 
 (* strip_sorts *)
 
 val strip_sorts = map_atyps
   (fn TFree (x, _) => TFree (x, [])
     | TVar (xi, _) => TVar (xi, []));
 
 val strip_sorts_dummy = map_atyps
   (fn TFree (x, _) => TFree (x, dummyS)
     | TVar (xi, _) => TVar (xi, dummyS));
 
 
 (* no_tvars *)
 
 fun no_tvars T =
   (case Term.add_tvarsT T [] of [] => T
   | vs => raise TYPE ("Illegal schematic type variable(s): " ^
       commas_quote (map (Term.string_of_vname o #1) (rev vs)), [T], []));
 
 
 (* varify_global *)
 
 fun varify_global fixed t =
   let
     val fs = Term.fold_types (Term.fold_atyps
       (fn TFree v => if member (op =) fixed v then I else insert (op =) v | _ => I)) t [];
     val used = Name.context
       |> fold_types (fold_atyps (fn TVar ((a, _), _) => Name.declare a | _ => I)) t;
     val fmap = fs ~~ map (rpair 0) (#1 (fold_map Name.variant (map fst fs) used));
     fun thaw (f as (_, S)) =
       (case AList.lookup (op =) fmap f of
         NONE => TFree f
       | SOME xi => TVar (xi, S));
   in (fmap, map_types (map_type_tfree thaw) t) end;
 
 
 (* freeze_thaw: freeze TVars in a term; return the "thaw" inverse *)
 
 local
 
 fun new_name ix (pairs, used) =
   let val v = singleton (Name.variant_list used) (string_of_indexname ix)
   in ((ix, v) :: pairs, v :: used) end;
 
 fun freeze_one alist (ix, sort) =
   TFree (the (AList.lookup (op =) alist ix), sort)
     handle Option.Option =>
       raise TYPE ("Failure during freezing of ?" ^ string_of_indexname ix, [], []);
 
 fun thaw_one alist (a, sort) = TVar (the (AList.lookup (op =) alist a), sort)
   handle Option.Option => TFree (a, sort);
 
 in
 
 fun legacy_freeze_thaw_type T =
   let
     val used = Term.add_tfree_namesT T [];
     val (alist, _) = fold_rev new_name (map #1 (Term.add_tvarsT T [])) ([], used);
   in (map_type_tvar (freeze_one alist) T, map_type_tfree (thaw_one (map swap alist))) end;
 
 val legacy_freeze_type = #1 o legacy_freeze_thaw_type;
 
 fun legacy_freeze_thaw t =
   let
     val used = Term.add_tfree_names t [];
     val (alist, _) = fold_rev new_name (map #1 (Term.add_tvars t [])) ([], used);
   in
     (case alist of
       [] => (t, fn x => x) (*nothing to do!*)
     | _ => (map_types (map_type_tvar (freeze_one alist)) t,
       map_types (map_type_tfree (thaw_one (map swap alist)))))
   end;
 
 val legacy_freeze = #1 o legacy_freeze_thaw;
 
 end;
 
 
 
 (** matching and unification of types **)
 
 type tyenv = (sort * typ) Vartab.table;
 
 fun tvar_clash ixn S S' =
   raise TYPE ("Type variable has two distinct sorts", [TVar (ixn, S), TVar (ixn, S')], []);
 
 fun lookup tye (ixn, S) =
   (case Vartab.lookup tye ixn of
     NONE => NONE
   | SOME (S', T) => if S = S' then SOME T else tvar_clash ixn S S');
 
 
 (* matching *)
 
 exception TYPE_MATCH;
 
 fun typ_match tsig =
   let
     fun match (TVar (v, S), T) subs =
           (case lookup subs (v, S) of
             NONE =>
               if of_sort tsig (T, S) then Vartab.update_new (v, (S, T)) subs
               else raise TYPE_MATCH
           | SOME U => if U = T then subs else raise TYPE_MATCH)
       | match (Type (a, Ts), Type (b, Us)) subs =
           if a <> b then raise TYPE_MATCH
           else matches (Ts, Us) subs
       | match (TFree x, TFree y) subs =
           if x = y then subs else raise TYPE_MATCH
       | match _ _ = raise TYPE_MATCH
     and matches (T :: Ts, U :: Us) subs = matches (Ts, Us) (match (T, U) subs)
       | matches _ subs = subs;
   in match end;
 
 fun typ_instance tsig (T, U) =
-  (typ_match tsig (U, T) Vartab.empty; true) handle TYPE_MATCH => false;
+  (Vartab.build (typ_match tsig (U, T)); true) handle TYPE_MATCH => false;
 
 (*purely structural matching*)
 fun raw_match (TVar (v, S), T) subs =
       (case lookup subs (v, S) of
         NONE => Vartab.update_new (v, (S, T)) subs
       | SOME U => if U = T then subs else raise TYPE_MATCH)
   | raw_match (Type (a, Ts), Type (b, Us)) subs =
       if a <> b then raise TYPE_MATCH
       else raw_matches (Ts, Us) subs
   | raw_match (TFree x, TFree y) subs =
       if x = y then subs else raise TYPE_MATCH
   | raw_match _ _ = raise TYPE_MATCH
 and raw_matches (T :: Ts, U :: Us) subs = raw_matches (Ts, Us) (raw_match (T, U) subs)
   | raw_matches ([], []) subs = subs
   | raw_matches _ _ = raise TYPE_MATCH;
 
 (*fast matching filter*)
 fun could_match (Type (a, Ts), Type (b, Us)) = a = b andalso could_matches (Ts, Us)
   | could_match (TFree (a, _), TFree (b, _)) = a = b
   | could_match (TVar _, _) = true
   | could_match _ = false
 and could_matches (T :: Ts, U :: Us) = could_match (T, U) andalso could_matches (Ts, Us)
   | could_matches ([], []) = true
   | could_matches _ = false;
 
 fun raw_instance (T, U) =
   if could_match (U, T) then
-    (raw_match (U, T) Vartab.empty; true) handle TYPE_MATCH => false
+    (Vartab.build (raw_match (U, T)); true) handle TYPE_MATCH => false
   else false;
 
 
 (* unification *)
 
 exception TUNIFY;
 
 (*occurs check*)
 fun occurs v tye =
   let
     fun occ (Type (_, Ts)) = exists occ Ts
       | occ (TFree _) = false
       | occ (TVar (w, S)) =
           Term.eq_ix (v, w) orelse
             (case lookup tye (w, S) of
               NONE => false
             | SOME U => occ U);
   in occ end;
 
 (*chase variable assignments; if devar returns a type var then it must be unassigned*)
 fun devar tye (T as TVar v) =
       (case lookup tye v of
         SOME U => devar tye U
       | NONE => T)
   | devar _ T = T;
 
 (*order-sorted unification*)
 fun unify (TSig {classes = (_, classes), ...}) TU (tyenv, maxidx) =
   let
     val tyvar_count = Unsynchronized.ref maxidx;
     fun gen_tyvar S = TVar ((Name.aT, Unsynchronized.inc tyvar_count), S);
 
     fun mg_domain a S = Sorts.mg_domain classes a S
       handle Sorts.CLASS_ERROR _ => raise TUNIFY;
 
     fun meet (_, []) tye = tye
       | meet (TVar (xi, S'), S) tye =
           if Sorts.sort_le classes (S', S) then tye
           else Vartab.update_new
             (xi, (S', gen_tyvar (Sorts.inter_sort classes (S', S)))) tye
       | meet (TFree (_, S'), S) tye =
           if Sorts.sort_le classes (S', S) then tye
           else raise TUNIFY
       | meet (Type (a, Ts), S) tye = meets (Ts, mg_domain a S) tye
     and meets (T :: Ts, S :: Ss) tye = meets (Ts, Ss) (meet (devar tye T, S) tye)
       | meets _ tye = tye;
 
     fun unif (ty1, ty2) tye =
       (case (devar tye ty1, devar tye ty2) of
         (T as TVar (v, S1), U as TVar (w, S2)) =>
           if Term.eq_ix (v, w) then
             if S1 = S2 then tye else tvar_clash v S1 S2
           else if Sorts.sort_le classes (S1, S2) then
             Vartab.update_new (w, (S2, T)) tye
           else if Sorts.sort_le classes (S2, S1) then
             Vartab.update_new (v, (S1, U)) tye
           else
             let val S = gen_tyvar (Sorts.inter_sort classes (S1, S2)) in
               Vartab.update_new (v, (S1, S)) (Vartab.update_new (w, (S2, S)) tye)
             end
       | (TVar (v, S), T) =>
           if occurs v tye T then raise TUNIFY
           else meet (T, S) (Vartab.update_new (v, (S, T)) tye)
       | (T, TVar (v, S)) =>
           if occurs v tye T then raise TUNIFY
           else meet (T, S) (Vartab.update_new (v, (S, T)) tye)
       | (Type (a, Ts), Type (b, Us)) =>
           if a <> b then raise TUNIFY
           else unifs (Ts, Us) tye
       | (T, U) => if T = U then tye else raise TUNIFY)
     and unifs (T :: Ts, U :: Us) tye = unifs (Ts, Us) (unif (T, U) tye)
       | unifs _ tye = tye;
   in (unif TU tyenv, ! tyvar_count) end;
 
 (*purely structural unification*)
 fun raw_unify (ty1, ty2) tye =
   (case (devar tye ty1, devar tye ty2) of
     (T as TVar (v, S1), TVar (w, S2)) =>
       if Term.eq_ix (v, w) then
         if S1 = S2 then tye else tvar_clash v S1 S2
       else Vartab.update_new (w, (S2, T)) tye
   | (TVar (v, S), T) =>
       if occurs v tye T then raise TUNIFY
       else Vartab.update_new (v, (S, T)) tye
   | (T, TVar (v, S)) =>
       if occurs v tye T then raise TUNIFY
       else Vartab.update_new (v, (S, T)) tye
   | (Type (a, Ts), Type (b, Us)) =>
       if a <> b then raise TUNIFY
       else raw_unifys (Ts, Us) tye
   | (T, U) => if T = U then tye else raise TUNIFY)
 and raw_unifys (T :: Ts, U :: Us) tye = raw_unifys (Ts, Us) (raw_unify (T, U) tye)
   | raw_unifys ([], []) tye = tye
   | raw_unifys _ _ = raise TUNIFY;
 
 (*fast unification filter*)
 fun could_unify (Type (a, Ts), Type (b, Us)) = a = b andalso could_unifys (Ts, Us)
   | could_unify (TFree (a, _), TFree (b, _)) = a = b
   | could_unify (TVar _, _) = true
   | could_unify (_, TVar _) = true
   | could_unify _ = false
 and could_unifys (T :: Ts, U :: Us) = could_unify (T, U) andalso could_unifys (Ts, Us)
   | could_unifys ([], []) = true
   | could_unifys _ = false;
 
 (*equality with respect to a type environment*)
 fun unified tye =
   let
     fun unif (T, T') =
       (case (devar tye T, devar tye T') of
          (Type (s, Ts), Type (s', Ts')) => s = s' andalso unifs (Ts, Ts')
        | (U, U') => U = U')
     and unifs ([], []) = true
       | unifs (T :: Ts, T' :: Ts') = unif (T', T') andalso unifs (Ts, Ts')
       | unifs _ = false;
   in if Vartab.is_empty tye then op = else unif end;
 
 
 
 (** extend and merge type signatures **)
 
 (* classes *)
 
 fun add_class context (c, cs) tsig =
   tsig |> map_tsig (fn ((space, classes), default, types) =>
     let
       val cs' = map (cert_class tsig) cs
         handle TYPE (msg, _, _) => error msg;
       val _ = Binding.check c;
       val (c', space') = space |> Name_Space.declare context true c;
       val classes' = classes |> Sorts.add_class context (c', cs');
     in ((space', classes'), default, types) end);
 
 fun hide_class fully c = map_tsig (fn ((space, classes), default, types) =>
   ((Name_Space.hide fully c space, classes), default, types));
 
 
 (* arities *)
 
 fun add_arity context (t, Ss, S) tsig = tsig |> map_tsig (fn ((space, classes), default, types) =>
   let
     val _ =
       (case lookup_type tsig t of
         SOME (LogicalType n) => if length Ss <> n then error (bad_nargs t) else ()
       | SOME _ => error ("Logical type constructor expected: " ^ quote t)
       | NONE => error (undecl_type t));
     val (Ss', S') = (map (cert_sort tsig) Ss, cert_sort tsig S)
       handle TYPE (msg, _, _) => error msg;
     val classes' = classes |> Sorts.add_arities context ((t, map (fn c' => (c', Ss')) S'));
   in ((space, classes'), default, types) end);
 
 
 (* classrel *)
 
 fun add_classrel context rel tsig =
   tsig |> map_tsig (fn ((space, classes), default, types) =>
     let
       val rel' = apply2 (cert_class tsig) rel
         handle TYPE (msg, _, _) => error msg;
       val classes' = classes |> Sorts.add_classrel context rel';
     in ((space, classes'), default, types) end);
 
 
 (* default sort *)
 
 fun set_defsort S tsig = tsig |> map_tsig (fn (classes, _, types) =>
   (classes, cert_sort tsig S handle TYPE (msg, _, _) => error msg, types));
 
 
 (* types *)
 
 local
 
 fun new_decl context (c, decl) types =
   (Binding.check c; #2 (Name_Space.define context true (c, decl) types));
 
 fun map_types f = map_tsig (fn (classes, default, types) =>
   let
     val types' = f types;
     val _ =
       not (Name_Space.defined types' "dummy") orelse
       Name_Space.intern (Name_Space.space_of_table types') "dummy" = "dummy" orelse
       error "Illegal declaration of dummy type";
   in (classes, default, types') end);
 
 fun syntactic tsig (Type (c, Ts)) =
       (case lookup_type tsig c of SOME Nonterminal => true | _ => false)
         orelse exists (syntactic tsig) Ts
   | syntactic _ _ = false;
 
 in
 
 fun add_type context (c, n) =
   if n < 0 then error ("Bad type constructor declaration " ^ Binding.print c)
   else map_types (new_decl context (c, LogicalType n));
 
 fun add_abbrev context (a, vs, rhs) tsig = tsig |> map_types (fn types =>
   let
     fun err msg =
       cat_error msg ("The error(s) above occurred in type abbreviation " ^ Binding.print a);
     val rhs' = strip_sorts (no_tvars (cert_typ_mode mode_syntax tsig rhs))
       handle TYPE (msg, _, _) => err msg;
     val _ =
       (case duplicates (op =) vs of
         [] => []
       | dups => err ("Duplicate variables on lhs: " ^ commas_quote dups));
     val _ =
       (case subtract (op =) vs (map #1 (Term.add_tfreesT rhs' [])) of
         [] => []
       | extras => err ("Extra variables on rhs: " ^ commas_quote extras));
   in types |> new_decl context (a, Abbreviation (vs, rhs', syntactic tsig rhs')) end);
 
 fun add_nonterminal context = map_types o new_decl context o rpair Nonterminal;
 
 end;
 
 fun hide_type fully c = map_tsig (fn (classes, default, types) =>
   (classes, default, Name_Space.hide_table fully c types));
 
 
 (* merge type signatures *)
 
 fun merge_tsig context (tsig1, tsig2) =
   let
     val (TSig {classes = (space1, classes1), default = default1, types = types1,
       log_types = _}) = tsig1;
     val (TSig {classes = (space2, classes2), default = default2, types = types2,
       log_types = _}) = tsig2;
 
     val space' = Name_Space.merge (space1, space2);
     val classes' = Sorts.merge_algebra context (classes1, classes2);
     val default' = Sorts.inter_sort classes' (default1, default2);
     val types' = Name_Space.merge_tables (types1, types2);
   in build_tsig ((space', classes'), default', types') end;
 
 end;
diff --git a/src/Pure/variable.ML b/src/Pure/variable.ML
--- a/src/Pure/variable.ML
+++ b/src/Pure/variable.ML
@@ -1,748 +1,746 @@
 (*  Title:      Pure/variable.ML
     Author:     Makarius
 
 Fixed type/term variables and polymorphic term abbreviations.
 *)
 
 signature VARIABLE =
 sig
   val names_of: Proof.context -> Name.context
   val binds_of: Proof.context -> (typ * term) Vartab.table
   val maxidx_of: Proof.context -> int
   val constraints_of: Proof.context -> typ Vartab.table * sort Vartab.table
   val is_declared: Proof.context -> string -> bool
   val check_name: binding -> string
   val default_type: Proof.context -> string -> typ option
   val def_type: Proof.context -> bool -> indexname -> typ option
   val def_sort: Proof.context -> indexname -> sort option
   val declare_maxidx: int -> Proof.context -> Proof.context
   val declare_names: term -> Proof.context -> Proof.context
   val declare_constraints: term -> Proof.context -> Proof.context
   val declare_internal: term -> Proof.context -> Proof.context
   val declare_term: term -> Proof.context -> Proof.context
   val declare_typ: typ -> Proof.context -> Proof.context
   val declare_prf: Proofterm.proof -> Proof.context -> Proof.context
   val declare_thm: thm -> Proof.context -> Proof.context
   val variant_frees: Proof.context -> term list -> (string * 'a) list -> (string * 'a) list
   val bind_term: indexname * term -> Proof.context -> Proof.context
   val unbind_term: indexname -> Proof.context -> Proof.context
   val maybe_bind_term: indexname * term option -> Proof.context -> Proof.context
   val expand_binds: Proof.context -> term -> term
   val lookup_const: Proof.context -> string -> string option
   val is_const: Proof.context -> string -> bool
   val declare_const: string * string -> Proof.context -> Proof.context
   val next_bound: string * typ -> Proof.context -> term * Proof.context
   val revert_bounds: Proof.context -> term -> term
   val is_body: Proof.context -> bool
   val set_body: bool -> Proof.context -> Proof.context
   val restore_body: Proof.context -> Proof.context -> Proof.context
   val improper_fixes: Proof.context -> Proof.context
   val restore_proper_fixes: Proof.context -> Proof.context -> Proof.context
   val is_improper: Proof.context -> string -> bool
   val is_fixed: Proof.context -> string -> bool
   val is_newly_fixed: Proof.context -> Proof.context -> string -> bool
   val fixed_ord: Proof.context -> string ord
   val intern_fixed: Proof.context -> string -> string
   val lookup_fixed: Proof.context -> string -> string option
   val revert_fixed: Proof.context -> string -> string
   val markup_fixed: Proof.context -> string -> Markup.T
   val markup: Proof.context -> string -> Markup.T
   val markup_entity_def: Proof.context -> string -> Markup.T
   val dest_fixes: Proof.context -> (string * string) list
   val add_fixed_names: Proof.context -> term -> string list -> string list
   val add_fixed: Proof.context -> term -> (string * typ) list -> (string * typ) list
   val add_newly_fixed: Proof.context -> Proof.context ->
     term -> (string * typ) list -> (string * typ) list
   val add_free_names: Proof.context -> term -> string list -> string list
   val add_frees: Proof.context -> term -> (string * typ) list -> (string * typ) list
   val add_fixes_binding: binding list -> Proof.context -> string list * Proof.context
   val add_fixes: string list -> Proof.context -> string list * Proof.context
   val add_fixes_direct: string list -> Proof.context -> Proof.context
   val add_fixes_implicit: term -> Proof.context -> Proof.context
   val fix_dummy_patterns: term -> Proof.context -> term * Proof.context
   val variant_fixes: string list -> Proof.context -> string list * Proof.context
   val gen_all: Proof.context -> thm -> thm
   val export_terms: Proof.context -> Proof.context -> term list -> term list
   val exportT_terms: Proof.context -> Proof.context -> term list -> term list
   val exportT: Proof.context -> Proof.context -> thm list -> thm list
   val export_prf: Proof.context -> Proof.context -> Proofterm.proof -> Proofterm.proof
   val export: Proof.context -> Proof.context -> thm list -> thm list
   val export_morphism: Proof.context -> Proof.context -> morphism
   val invent_types: sort list -> Proof.context -> (string * sort) list * Proof.context
   val importT_inst: term list -> Proof.context -> typ Term_Subst.TVars.table * Proof.context
   val import_inst: bool -> term list -> Proof.context ->
     (typ Term_Subst.TVars.table * term Term_Subst.Vars.table) * Proof.context
   val importT_terms: term list -> Proof.context -> term list * Proof.context
   val import_terms: bool -> term list -> Proof.context -> term list * Proof.context
   val importT: thm list -> Proof.context ->
     (((indexname * sort) * ctyp) list * thm list) * Proof.context
   val import_prf: bool -> Proofterm.proof -> Proof.context -> Proofterm.proof * Proof.context
   val import: bool -> thm list -> Proof.context ->
     ((((indexname * sort) * ctyp) list * ((indexname * typ) * cterm) list) * thm list) * Proof.context
   val import_vars: Proof.context -> thm -> thm
   val tradeT: (Proof.context -> thm list -> thm list) -> Proof.context -> thm list -> thm list
   val trade: (Proof.context -> thm list -> thm list) -> Proof.context -> thm list -> thm list
   val is_bound_focus: Proof.context -> bool
   val set_bound_focus: bool -> Proof.context -> Proof.context
   val restore_bound_focus: Proof.context -> Proof.context -> Proof.context
   val focus_params: binding list option -> term -> Proof.context ->
     (string list * (string * typ) list) * Proof.context
   val focus: binding list option -> term -> Proof.context ->
     ((string * (string * typ)) list * term) * Proof.context
   val focus_cterm: binding list option -> cterm -> Proof.context ->
     ((string * cterm) list * cterm) * Proof.context
   val focus_subgoal: binding list option -> int -> thm -> Proof.context ->
     ((string * cterm) list * cterm) * Proof.context
   val warn_extra_tfrees: Proof.context -> Proof.context -> unit
   val polymorphic_types: Proof.context -> term list -> (indexname * sort) list * term list
   val polymorphic: Proof.context -> term list -> term list
 end;
 
 structure Variable: VARIABLE =
 struct
 
 (** local context data **)
 
 type fixes = (string * bool) Name_Space.table;
 val empty_fixes: fixes = Name_Space.empty_table Markup.fixedN;
 
 datatype data = Data of
  {names: Name.context,                  (*type/term variable names*)
   consts: string Symtab.table,          (*consts within the local scope*)
   bounds: int * ((string * typ) * string) list,  (*next index, internal name, type, external name*)
   fixes: fixes,                         (*term fixes -- global name space, intern ~> extern*)
   binds: (typ * term) Vartab.table,     (*term bindings*)
   type_occs: string list Symtab.table,  (*type variables -- possibly within term variables*)
   maxidx: int,                          (*maximum var index*)
   constraints:
     typ Vartab.table *                  (*type constraints*)
     sort Vartab.table};                 (*default sorts*)
 
 fun make_data (names, consts, bounds, fixes, binds, type_occs, maxidx, constraints) =
   Data {names = names, consts = consts, bounds = bounds, fixes = fixes, binds = binds,
     type_occs = type_occs, maxidx = maxidx, constraints = constraints};
 
 val empty_data =
   make_data (Name.context, Symtab.empty, (0, []), empty_fixes, Vartab.empty,
     Symtab.empty, ~1, (Vartab.empty, Vartab.empty));
 
 structure Data = Proof_Data
 (
   type T = data;
   fun init _ = empty_data;
 );
 
 fun map_data f =
   Data.map (fn Data {names, consts, bounds, fixes, binds, type_occs, maxidx, constraints} =>
     make_data (f (names, consts, bounds, fixes, binds, type_occs, maxidx, constraints)));
 
 fun map_names f =
   map_data (fn (names, consts, bounds, fixes, binds, type_occs, maxidx, constraints) =>
     (f names, consts, bounds, fixes, binds, type_occs, maxidx, constraints));
 
 fun map_consts f =
   map_data (fn (names, consts, bounds, fixes, binds, type_occs, maxidx, constraints) =>
     (names, f consts, bounds, fixes, binds, type_occs, maxidx, constraints));
 
 fun map_bounds f =
   map_data (fn (names, consts, bounds, fixes, binds, type_occs, maxidx, constraints) =>
     (names, consts, f bounds, fixes, binds, type_occs, maxidx, constraints));
 
 fun map_fixes f =
   map_data (fn (names, consts, bounds, fixes, binds, type_occs, maxidx, constraints) =>
     (names, consts, bounds, f fixes, binds, type_occs, maxidx, constraints));
 
 fun map_binds f =
   map_data (fn (names, consts, bounds, fixes, binds, type_occs, maxidx, constraints) =>
     (names, consts, bounds, fixes, f binds, type_occs, maxidx, constraints));
 
 fun map_type_occs f =
   map_data (fn (names, consts, bounds, fixes, binds, type_occs, maxidx, constraints) =>
     (names, consts, bounds, fixes, binds, f type_occs, maxidx, constraints));
 
 fun map_maxidx f =
   map_data (fn (names, consts, bounds, fixes, binds, type_occs, maxidx, constraints) =>
     (names, consts, bounds, fixes, binds, type_occs, f maxidx, constraints));
 
 fun map_constraints f =
   map_data (fn (names, consts, bounds, fixes, binds, type_occs, maxidx, constraints) =>
     (names, consts, bounds, fixes, binds, type_occs, maxidx, f constraints));
 
 fun rep_data ctxt = Data.get ctxt |> (fn Data rep => rep);
 
 val names_of = #names o rep_data;
 val fixes_of = #fixes o rep_data;
 val fixes_space = Name_Space.space_of_table o fixes_of;
 val binds_of = #binds o rep_data;
 val type_occs_of = #type_occs o rep_data;
 val maxidx_of = #maxidx o rep_data;
 val constraints_of = #constraints o rep_data;
 
 val is_declared = Name.is_declared o names_of;
 
 val check_name = Name_Space.base_name o tap Binding.check;
 
 
 
 (** declarations **)
 
 (* default sorts and types *)
 
 fun default_type ctxt x = Vartab.lookup (#1 (constraints_of ctxt)) (x, ~1);
 
 fun def_type ctxt pattern xi =
   let val {binds, constraints = (types, _), ...} = rep_data ctxt in
     (case Vartab.lookup types xi of
       NONE =>
         if pattern then NONE
         else Vartab.lookup binds xi |> Option.map (Type.mark_polymorphic o #1)
     | some => some)
   end;
 
 val def_sort = Vartab.lookup o #2 o constraints_of;
 
 
 (* maxidx *)
 
 val declare_maxidx = map_maxidx o Integer.max;
 
 
 (* names *)
 
 fun declare_type_names t =
   map_names (fold_types (fold_atyps Term.declare_typ_names) t) #>
   map_maxidx (fold_types Term.maxidx_typ t);
 
 fun declare_names t =
   declare_type_names t #>
   map_names (fold_aterms Term.declare_term_frees t) #>
   map_maxidx (Term.maxidx_term t);
 
 
 (* type occurrences *)
 
 fun decl_type_occsT T = fold_atyps (fn TFree (a, _) => Symtab.default (a, []) | _ => I) T;
 
 val decl_type_occs = fold_term_types
   (fn Free (x, _) => fold_atyps (fn TFree (a, _) => Symtab.insert_list (op =) (a, x) | _ => I)
     | _ => decl_type_occsT);
 
 val declare_type_occsT = map_type_occs o fold_types decl_type_occsT;
 val declare_type_occs = map_type_occs o decl_type_occs;
 
 
 (* constraints *)
 
 fun constrain_tvar (xi, raw_S) =
   let val S = #2 (Term_Position.decode_positionS raw_S)
   in if S = dummyS then Vartab.delete_safe xi else Vartab.update (xi, S) end;
 
 fun declare_constraints t = map_constraints (fn (types, sorts) =>
   let
     val types' = fold_aterms
       (fn Free (x, T) => Vartab.update ((x, ~1), T)
         | Var v => Vartab.update v
         | _ => I) t types;
     val sorts' = (fold_types o fold_atyps)
       (fn TFree (x, S) => constrain_tvar ((x, ~1), S)
         | TVar v => constrain_tvar v
         | _ => I) t sorts;
   in (types', sorts') end)
   #> declare_type_occsT t
   #> declare_type_names t;
 
 
 (* common declarations *)
 
 fun declare_internal t =
   declare_names t #>
   declare_type_occs t #>
   Thm.declare_term_sorts t;
 
 fun declare_term t =
   declare_internal t #>
   declare_constraints t;
 
 val declare_typ = declare_term o Logic.mk_type;
 
 val declare_prf =
   Proofterm.fold_proof_terms_types declare_internal (declare_internal o Logic.mk_type);
 
 val declare_thm = Thm.fold_terms declare_internal;
 
 
 (* renaming term/type frees *)
 
 fun variant_frees ctxt ts frees =
   let
     val names = names_of (fold declare_names ts ctxt);
     val xs = fst (fold_map Name.variant (map #1 frees) names);
   in xs ~~ map snd frees end;
 
 
 
 (** term bindings **)
 
 fun bind_term ((x, i), t) =
   let
     val u = Term.close_schematic_term t;
     val U = Term.fastype_of u;
   in declare_term u #> map_binds (Vartab.update ((x, i), (U, u))) end;
 
 val unbind_term = map_binds o Vartab.delete_safe;
 
 fun maybe_bind_term (xi, SOME t) = bind_term (xi, t)
   | maybe_bind_term (xi, NONE) = unbind_term xi;
 
 fun expand_binds ctxt =
   let
     val binds = binds_of ctxt;
     val get = fn Var (xi, _) => Vartab.lookup binds xi | _ => NONE;
   in Envir.beta_norm o Envir.expand_term get end;
 
 
 
 (** consts **)
 
 val lookup_const = Symtab.lookup o #consts o rep_data;
 val is_const = is_some oo lookup_const;
 
 val declare_fixed = map_consts o Symtab.delete_safe;
 val declare_const = map_consts o Symtab.update;
 
 
 
 (** bounds **)
 
 fun next_bound (a, T) ctxt =
   let
     val b = Name.bound (#1 (#bounds (rep_data ctxt)));
     val ctxt' = ctxt |> map_bounds (fn (next, bounds) => (next + 1, ((b, T), a) :: bounds));
   in (Free (b, T), ctxt') end;
 
 fun revert_bounds ctxt t =
   (case #2 (#bounds (rep_data ctxt)) of
     [] => t
   | bounds =>
       let
         val names = Term.declare_term_names t (names_of ctxt);
         val xs = rev (#1 (fold_map Name.variant (rev (map #2 bounds)) names));
         fun subst ((b, T), _) x' = (Free (b, T), Syntax_Trans.mark_bound_abs (x', T));
       in Term.subst_atomic (map2 subst bounds xs) t end);
 
 
 
 (** fixes **)
 
 (* inner body mode *)
 
 val inner_body = Config.declare_bool ("inner_body", \<^here>) (K false);
 val is_body = Config.apply inner_body;
 val set_body = Config.put inner_body;
 val restore_body = set_body o is_body;
 
 
 (* proper mode *)
 
 val proper_fixes = Config.declare_bool ("proper_fixes", \<^here>) (K true);
 val improper_fixes = Config.put proper_fixes false;
 val restore_proper_fixes = Config.put proper_fixes o Config.apply proper_fixes;
 
 fun is_improper ctxt x =
   (case Name_Space.lookup (fixes_of ctxt) x of
     SOME (_, proper) => not proper
   | NONE => false);
 
 
 (* specialized name space *)
 
 val is_fixed = Name_Space.defined o fixes_of;
 fun is_newly_fixed inner outer = is_fixed inner andf (not o is_fixed outer);
 
 val fixed_ord = Name_Space.entry_ord o fixes_space;
 val intern_fixed = Name_Space.intern o fixes_space;
 
 fun lookup_fixed ctxt x =
   let val x' = intern_fixed ctxt x
   in if is_fixed ctxt x' then SOME x' else NONE end;
 
 fun revert_fixed ctxt x =
   (case Name_Space.lookup (fixes_of ctxt) x of
     SOME (x', _) => if intern_fixed ctxt x' = x then x' else x
   | NONE => x);
 
 fun markup_fixed ctxt x =
   Name_Space.markup (fixes_space ctxt) x
   |> Markup.name (revert_fixed ctxt x);
 
 fun markup ctxt x =
   if is_improper ctxt x then Markup.improper
   else if Name.is_skolem x then Markup.skolem
   else Markup.free;
 
 val markup_entity_def = Name_Space.markup_def o fixes_space;
 
 fun dest_fixes ctxt =
   Name_Space.fold_table (fn (x, (y, _)) => cons (y, x)) (fixes_of ctxt) []
   |> sort (Name_Space.entry_ord (fixes_space ctxt) o apply2 #2);
 
 
 (* collect variables *)
 
 fun add_free_names ctxt =
   fold_aterms (fn Free (x, _) => not (is_fixed ctxt x) ? insert (op =) x | _ => I);
 
 fun add_frees ctxt =
   fold_aterms (fn Free (x, T) => not (is_fixed ctxt x) ? insert (op =) (x, T) | _ => I);
 
 fun add_fixed_names ctxt =
   fold_aterms (fn Free (x, _) => is_fixed ctxt x ? insert (op =) x | _ => I);
 
 fun add_fixed ctxt =
   fold_aterms (fn Free (x, T) => is_fixed ctxt x ? insert (op =) (x, T) | _ => I);
 
 fun add_newly_fixed ctxt' ctxt =
   fold_aterms (fn Free (x, T) => is_newly_fixed ctxt' ctxt x ? insert (op =) (x, T) | _ => I);
 
 
 (* declarations *)
 
 local
 
 fun err_dups dups =
   error ("Duplicate fixed variable(s): " ^ commas (map Binding.print dups));
 
 fun new_fixed ((x, x'), pos) ctxt =
   if is_some (lookup_fixed ctxt x') then err_dups [Binding.make (x, pos)]
   else
     let
       val proper = Config.get ctxt proper_fixes;
       val context = Context.Proof ctxt
         |> Name_Space.map_naming (K Name_Space.global_naming)
         |> Context_Position.set_visible_generic false;
     in
       ctxt
       |> map_fixes
         (Name_Space.define context true (Binding.make (x', pos), (x, proper)) #> snd #>
           Name_Space.alias_table Name_Space.global_naming (Binding.make (x, pos)) x')
       |> declare_fixed x
       |> declare_constraints (Syntax.free x')
   end;
 
 fun new_fixes names' args =
   map_names (K names') #>
   fold new_fixed args #>
   pair (map (#2 o #1) args);
 
 in
 
 fun add_fixes_binding bs ctxt =
   let
     val _ =
       (case filter (Name.is_skolem o Binding.name_of) bs of
         [] => ()
       | bads => error ("Illegal internal Skolem constant(s): " ^ commas (map Binding.print bads)));
     val _ =
       (case duplicates (op = o apply2 Binding.name_of) bs of
         [] => ()
       | dups => err_dups dups);
 
     val xs = map check_name bs;
     val names = names_of ctxt;
     val (xs', names') =
       if is_body ctxt then fold_map Name.variant xs names |>> map Name.skolem
       else (xs, fold Name.declare xs names);
   in ctxt |> new_fixes names' ((xs ~~ xs') ~~ map Binding.pos_of bs) end;
 
 fun variant_names ctxt raw_xs =
   let
     val names = names_of ctxt;
     val xs = map (fn x => Name.clean x |> Name.is_internal x ? Name.internal) raw_xs;
     val (xs', names') = fold_map Name.variant xs names |>> (is_body ctxt ? map Name.skolem);
   in (names', xs ~~ xs') end;
 
 fun variant_fixes xs ctxt =
   let val (names', vs) = variant_names ctxt xs;
   in ctxt |> new_fixes names' (map (rpair Position.none) vs) end;
 
 fun bound_fixes xs ctxt =
   let
     val (names', vs) = variant_names ctxt (map #1 xs);
     val (ys, ctxt') = fold_map next_bound (map2 (fn (x', _) => fn (_, T) => (x', T)) vs xs) ctxt;
     val fixes = map2 (fn (x, _) => fn Free (y, _) => ((x, y), Position.none)) vs ys;
   in ctxt' |> new_fixes names' fixes end;
 
 end;
 
 val add_fixes = add_fixes_binding o map Binding.name;
 
 fun add_fixes_direct xs ctxt = ctxt
   |> set_body false
   |> (snd o add_fixes xs)
   |> restore_body ctxt;
 
 fun add_fixes_implicit t ctxt = ctxt
   |> not (is_body ctxt) ? add_fixes_direct (rev (add_free_names ctxt t []));
 
 
 (* dummy patterns *)
 
 fun fix_dummy_patterns (Const ("Pure.dummy_pattern", T)) ctxt =
       let val ([x], ctxt') = ctxt |> set_body true |> add_fixes [Name.uu_] ||> restore_body ctxt
       in (Free (x, T), ctxt') end
   | fix_dummy_patterns (Abs (x, T, b)) ctxt =
       let val (b', ctxt') = fix_dummy_patterns b ctxt
       in (Abs (x, T, b'), ctxt') end
   | fix_dummy_patterns (t $ u) ctxt =
       let
         val (t', ctxt') = fix_dummy_patterns t ctxt;
         val (u', ctxt'') = fix_dummy_patterns u ctxt';
       in (t' $ u', ctxt'') end
   | fix_dummy_patterns a ctxt = (a, ctxt);
 
 
 
 (** export -- generalize type/term variables (beware of closure sizes) **)
 
 fun gen_all ctxt th =
   let
     val i = Thm.maxidx_thm th (maxidx_of ctxt) + 1;
     fun gen (x, T) = Thm.forall_elim (Thm.cterm_of ctxt (Var ((x, i), T)));
   in fold gen (Drule.outer_params (Thm.prop_of th)) th end;
 
 fun export_inst inner outer =
   let
     val declared_outer = is_declared outer;
     val still_fixed = not o is_newly_fixed inner outer;
 
     val gen_fixes =
-      Name_Space.fold_table (fn (y, _) => not (is_fixed outer y) ? Symtab.insert_set y)
-        (fixes_of inner) Symtab.empty;
+      Symtab.build (fixes_of inner |> Name_Space.fold_table (fn (y, _) =>
+        not (is_fixed outer y) ? Symtab.insert_set y));
 
     val type_occs_inner = type_occs_of inner;
     fun gen_fixesT ts =
-      Symtab.fold (fn (a, xs) =>
+      Symtab.build (fold decl_type_occs ts type_occs_inner |> Symtab.fold (fn (a, xs) =>
         if declared_outer a orelse exists still_fixed xs
-        then I else Symtab.insert_set a) (fold decl_type_occs ts type_occs_inner) Symtab.empty;
+        then I else Symtab.insert_set a));
   in (gen_fixesT, gen_fixes) end;
 
 fun exportT_inst inner outer = #1 (export_inst inner outer);
 
 fun exportT_terms inner outer =
   let
     val mk_tfrees = exportT_inst inner outer;
     val maxidx = maxidx_of outer;
   in
     fn ts => ts |> map
       (Term_Subst.generalize (mk_tfrees ts, Symtab.empty)
         (fold (Term.fold_types Term.maxidx_typ) ts maxidx + 1))
   end;
 
 fun export_terms inner outer =
   let
     val (mk_tfrees, tfrees) = export_inst inner outer;
     val maxidx = maxidx_of outer;
   in
     fn ts => ts |> map
       (Term_Subst.generalize (mk_tfrees ts, tfrees)
         (fold Term.maxidx_term ts maxidx + 1))
   end;
 
 fun export_prf inner outer prf =
   let
     val (mk_tfrees, frees) = export_inst (declare_prf prf inner) outer;
     val tfrees = mk_tfrees [];
     val maxidx = maxidx_of outer;
     val idx = Proofterm.maxidx_proof prf maxidx + 1;
     val gen_term = Term_Subst.generalize_same (tfrees, frees) idx;
     val gen_typ = Term_Subst.generalizeT_same tfrees idx;
   in Same.commit (Proofterm.map_proof_terms_same gen_term gen_typ) prf end;
 
 
 fun gen_export (mk_tfrees, frees) maxidx ths =
   let
     val tfrees = mk_tfrees (map Thm.full_prop_of ths);
     val idx = fold Thm.maxidx_thm ths maxidx + 1;
   in map (Thm.generalize (tfrees, frees) idx) ths end;
 
 fun exportT inner outer = gen_export (exportT_inst inner outer, Symtab.empty) (maxidx_of outer);
 fun export inner outer = gen_export (export_inst inner outer) (maxidx_of outer);
 
 fun export_morphism inner outer =
   let
     val fact = export inner outer;
     val term = singleton (export_terms inner outer);
     val typ = Logic.type_map term;
   in
     Morphism.transfer_morphism' inner $>
     Morphism.transfer_morphism' outer $>
     Morphism.morphism "Variable.export" {binding = [], typ = [typ], term = [term], fact = [fact]}
   end;
 
 
 
 (** import -- fix schematic type/term variables **)
 
 fun invent_types Ss ctxt =
   let
     val tfrees = Name.invent (names_of ctxt) Name.aT (length Ss) ~~ Ss;
     val ctxt' = fold (declare_constraints o Logic.mk_type o TFree) tfrees ctxt;
   in (tfrees, ctxt') end;
 
 fun importT_inst ts ctxt =
   let
     val tvars = rev (fold Term.add_tvars ts []);
     val (tfrees, ctxt') = invent_types (map #2 tvars) ctxt;
     val instT =
-      fold2 (fn a => fn b => Term_Subst.TVars.add (a, TFree b))
-        tvars tfrees Term_Subst.TVars.empty;
+      Term_Subst.TVars.build (fold2 (fn a => fn b =>
+        Term_Subst.TVars.add (a, TFree b)) tvars tfrees);
   in (instT, ctxt') end;
 
 fun import_inst is_open ts ctxt =
   let
     val ren = Name.clean #> (if is_open then I else Name.internal);
     val (instT, ctxt') = importT_inst ts ctxt;
     val vars = map (apsnd (Term_Subst.instantiateT instT)) (rev (fold Term.add_vars ts []));
     val (ys, ctxt'') = variant_fixes (map (ren o #1 o #1) vars) ctxt';
     val inst =
-      fold2 (fn (x, T) => fn y => Term_Subst.Vars.add ((x, T), Free (y, T)))
-        vars ys Term_Subst.Vars.empty;
+      Term_Subst.Vars.build (fold2 (fn (x, T) => fn y =>
+        Term_Subst.Vars.add ((x, T), Free (y, T))) vars ys);
   in ((instT, inst), ctxt'') end;
 
 fun importT_terms ts ctxt =
   let val (instT, ctxt') = importT_inst ts ctxt
   in (map (Term_Subst.instantiate (instT, Term_Subst.Vars.empty)) ts, ctxt') end;
 
 fun import_terms is_open ts ctxt =
   let val (inst, ctxt') = import_inst is_open ts ctxt
   in (map (Term_Subst.instantiate inst) ts, ctxt') end;
 
 fun importT ths ctxt =
   let
     val (instT, ctxt') = importT_inst (map Thm.full_prop_of ths) ctxt;
     val instT' = Term_Subst.TVars.fold (fn (v, T) => cons (v, Thm.ctyp_of ctxt' T)) instT [];
     val ths' = map (Thm.instantiate (instT', [])) ths;
   in ((instT', ths'), ctxt') end;
 
 fun import_prf is_open prf ctxt =
   let
     val ts = rev (Proofterm.fold_proof_terms_types cons (cons o Logic.mk_type) prf []);
     val (insts, ctxt') = import_inst is_open ts ctxt;
   in (Proofterm.instantiate insts prf, ctxt') end;
 
 fun import is_open ths ctxt =
   let
     val ((instT, inst), ctxt') = import_inst is_open (map Thm.full_prop_of ths) ctxt;
     val instT' = Term_Subst.TVars.fold (fn (v, T) => cons (v, Thm.ctyp_of ctxt' T)) instT [];
     val inst' = Term_Subst.Vars.fold (fn (v, t) => cons (v, Thm.cterm_of ctxt' t)) inst [];
     val ths' = map (Thm.instantiate (instT', inst')) ths;
   in (((instT', inst'), ths'), ctxt') end;
 
 fun import_vars ctxt th =
   let val ((_, [th']), _) = ctxt |> set_body false |> import true [th];
   in th' end;
 
 
 (* import/export *)
 
 fun gen_trade imp exp f ctxt ths =
   let val ((_, ths'), ctxt') = imp ths ctxt
   in exp ctxt' ctxt (f ctxt' ths') end;
 
 val tradeT = gen_trade importT exportT;
 val trade = gen_trade (import true) export;
 
 
 (* focus on outermost parameters: \<And>x y z. B *)
 
 val bound_focus = Config.declare_bool ("bound_focus", \<^here>) (K false);
 val is_bound_focus = Config.apply bound_focus;
 val set_bound_focus = Config.put bound_focus;
 val restore_bound_focus = set_bound_focus o is_bound_focus;
 
 fun focus_params bindings t ctxt =
   let
     val ps = Term.variant_frees t (Term.strip_all_vars t);  (*as they are printed :-*)
     val (xs, Ts) = split_list ps;
     val (xs', ctxt') =
       (case bindings of
         SOME bs => ctxt |> set_body true |> add_fixes_binding bs ||> restore_body ctxt
       | NONE => if is_bound_focus ctxt then bound_fixes ps ctxt else variant_fixes xs ctxt);
     val ps' = xs' ~~ Ts;
     val ctxt'' = ctxt' |> fold (declare_constraints o Free) ps';
   in ((xs, ps'), ctxt'') end;
 
 fun focus bindings t ctxt =
   let
     val ((xs, ps), ctxt') = focus_params bindings t ctxt;
     val t' = Term.subst_bounds (rev (map Free ps), Term.strip_all_body t);
   in (((xs ~~ ps), t'), ctxt') end;
 
 fun forall_elim_prop t prop =
   Thm.beta_conversion false (Thm.apply (Thm.dest_arg prop) t)
   |> Thm.cprop_of |> Thm.dest_arg;
 
 fun focus_cterm bindings goal ctxt =
   let
     val ((xs, ps), ctxt') = focus_params bindings (Thm.term_of goal) ctxt;
     val ps' = map (Thm.cterm_of ctxt' o Free) ps;
     val goal' = fold forall_elim_prop ps' goal;
   in ((xs ~~ ps', goal'), ctxt') end;
 
 fun focus_subgoal bindings i st =
-  let
-    val all_vars = Thm.fold_terms Term_Subst.add_vars st Term_Subst.Vars.empty;
-  in
+  let val all_vars = Term_Subst.Vars.build (Thm.fold_terms Term_Subst.add_vars st) in
     Term_Subst.Vars.fold (unbind_term o #1 o #1) all_vars #>
     Term_Subst.Vars.fold (declare_constraints o Var o #1) all_vars #>
     focus_cterm bindings (Thm.cprem_of st i)
   end;
 
 
 
 (** implicit polymorphism **)
 
 (* warn_extra_tfrees *)
 
 fun warn_extra_tfrees ctxt1 ctxt2 =
   let
     fun occs_typ a = Term.exists_subtype (fn TFree (b, _) => a = b | _ => false);
     fun occs_free a x =
       (case def_type ctxt1 false (x, ~1) of
         SOME T => if occs_typ a T then I else cons (a, x)
       | NONE => cons (a, x));
 
     val occs1 = type_occs_of ctxt1;
     val occs2 = type_occs_of ctxt2;
     val extras = Symtab.fold (fn (a, xs) =>
       if Symtab.defined occs1 a then I else fold (occs_free a) xs) occs2 [];
     val tfrees = map #1 extras |> sort_distinct string_ord;
     val frees = map #2 extras |> sort_distinct string_ord;
   in
     if null extras orelse not (Context_Position.is_visible ctxt2) then ()
     else warning ("Introduced fixed type variable(s): " ^ commas tfrees ^ " in " ^
       space_implode " or " (map quote frees))
   end;
 
 
 (* polymorphic terms *)
 
 fun polymorphic_types ctxt ts =
   let
     val ctxt' = fold declare_term ts ctxt;
     val occs = type_occs_of ctxt;
     val occs' = type_occs_of ctxt';
     val types =
-      Symtab.fold (fn (a, _) =>
-        if Symtab.defined occs a then I else Symtab.insert_set a) occs' Symtab.empty;
+      Symtab.build (occs' |> Symtab.fold (fn (a, _) =>
+        if Symtab.defined occs a then I else Symtab.insert_set a));
     val idx = maxidx_of ctxt' + 1;
     val Ts' = (fold o fold_types o fold_atyps)
       (fn T as TFree _ =>
           (case Term_Subst.generalizeT types idx T of TVar v => insert (op =) v | _ => I)
         | _ => I) ts [];
     val ts' = map (Term_Subst.generalize (types, Symtab.empty) idx) ts;
   in (rev Ts', ts') end;
 
 fun polymorphic ctxt ts = snd (polymorphic_types ctxt ts);
 
 end;