error message only in case of an error
authortraytel
Wed, 05 Sep 2012 15:22:37 +0200
changeset 501712a361e09101b
parent 50170 f51ab68f882f
child 50172 6407346b74c7
error message only in case of an error
src/HOL/Codatatype/Tools/bnf_fp_util.ML
     1.1 --- a/src/HOL/Codatatype/Tools/bnf_fp_util.ML	Wed Sep 05 14:49:35 2012 +0200
     1.2 +++ b/src/HOL/Codatatype/Tools/bnf_fp_util.ML	Wed Sep 05 15:22:37 2012 +0200
     1.3 @@ -259,7 +259,7 @@
     1.4  fun fp_sort lhss Ass = Library.sort (Term_Ord.typ_ord o pairself TFree)
     1.5    (subtract (op =) lhss (fold (fold (insert (op =))) Ass [])) @ lhss;
     1.6  
     1.7 -fun mk_fp_bnf timer construct bs resBs sort bnfs deadss livess unfold lthy =
     1.8 +fun mk_fp_bnf timer construct bs resBs sort lhss bnfs deadss livess unfold lthy =
     1.9    let
    1.10      val name = fold_rev (fn b => fn s => Binding.name_of b ^ s) bs "";
    1.11      fun qualify i bind =
    1.12 @@ -273,7 +273,7 @@
    1.13      val resDs = fold (subtract (op =)) Ass resBs;
    1.14      val Ds = fold (fold Term.add_tfreesT) deadss resDs;
    1.15  
    1.16 -    val _ = (case Library.inter (op =) Ds (fold (union (op =)) Ass []) of [] => ()
    1.17 +    val _ = (case Library.inter (op =) Ds lhss of [] => ()
    1.18        | A :: _ => error ("Nonadmissible type recursion (cannot take fixed point of dead type \
    1.19          \variable " ^ quote (Syntax.string_of_typ lthy (TFree A)) ^ ")"));
    1.20  
    1.21 @@ -305,7 +305,7 @@
    1.22        (fold_map2 (fn b => bnf_of_typ Smart_Inline (Binding.suffix_name "RAW" b) I sort) bs rhss
    1.23          (empty_unfold, lthy));
    1.24    in
    1.25 -    mk_fp_bnf timer construct bs resBs sort bnfs Dss Ass unfold lthy'
    1.26 +    mk_fp_bnf timer construct bs resBs sort lhss bnfs Dss Ass unfold lthy'
    1.27    end;
    1.28  
    1.29  fun fp_bnf_cmd construct (bs, (raw_lhss, raw_bnfs)) lthy =
    1.30 @@ -318,7 +318,7 @@
    1.31          (bnf_of_typ Smart_Inline (Binding.suffix_name "RAW" b) I sort (Syntax.read_typ lthy rawT)))
    1.32          bs raw_bnfs (empty_unfold, lthy));
    1.33    in
    1.34 -    mk_fp_bnf timer construct bs [] sort bnfs Dss Ass unfold lthy'
    1.35 +    mk_fp_bnf timer construct bs [] sort lhss bnfs Dss Ass unfold lthy'
    1.36    end;
    1.37  
    1.38  end;