src/Pure/Isar/code.ML
changeset 24624 b8383b1bbae3
parent 24585 c359896d0f48
child 24659 6b7ac2a43df8
     1.1 --- a/src/Pure/Isar/code.ML	Tue Sep 18 07:36:14 2007 +0200
     1.2 +++ b/src/Pure/Isar/code.ML	Tue Sep 18 07:36:15 2007 +0200
     1.3 @@ -8,10 +8,12 @@
     1.4  
     1.5  signature CODE =
     1.6  sig
     1.7 -  val add_func: bool -> thm -> theory -> theory
     1.8 +  val add_func: thm -> theory -> theory
     1.9 +  val add_liberal_func: thm -> theory -> theory
    1.10 +  val add_default_func: thm -> theory -> theory
    1.11 +  val add_default_func_attr: Attrib.src
    1.12    val del_func: thm -> theory -> theory
    1.13    val add_funcl: string * thm list Susp.T -> theory -> theory
    1.14 -  val add_func_attr: bool -> Attrib.src
    1.15    val add_inline: thm -> theory -> theory
    1.16    val del_inline: thm -> theory -> theory
    1.17    val add_inline_proc: string * (theory -> cterm list -> thm list) -> theory -> theory
    1.18 @@ -635,7 +637,8 @@
    1.19    in check_typ (const_of_func thy thm, thm) end;
    1.20  
    1.21  val mk_func = CodeUnit.error_thm (assert_func_typ o CodeUnit.mk_func);
    1.22 -val mk_func_liberal = CodeUnit.warning_thm (assert_func_typ o CodeUnit.mk_func);
    1.23 +val mk_liberal_func = CodeUnit.warning_thm (assert_func_typ o CodeUnit.mk_func);
    1.24 +val mk_default_func = CodeUnit.try_thm (assert_func_typ o CodeUnit.mk_func);
    1.25  
    1.26  end;
    1.27  
    1.28 @@ -643,6 +646,10 @@
    1.29  
    1.30  (** interfaces and attributes **)
    1.31  
    1.32 +fun delete_force msg key xs =
    1.33 +  if AList.defined (op =) xs key then AList.delete (op =) key xs
    1.34 +  else error ("No such " ^ msg ^ ": " ^ quote key);
    1.35 +
    1.36  fun get_datatype thy tyco =
    1.37    case Symtab.lookup ((the_dtyps o get_exec) thy) tyco
    1.38     of SOME spec => spec
    1.39 @@ -667,38 +674,48 @@
    1.40          in SOME (Logic.varifyT ty) end
    1.41      | NONE => NONE;
    1.42  
    1.43 -fun add_func true thm thy =
    1.44 -      let
    1.45 -        val func = mk_func thm;
    1.46 -        val c = const_of_func thy func;
    1.47 -        val _ = if (is_some o AxClass.class_of_param thy) c
    1.48 -          then error ("Rejected polymorphic equation for overloaded constant:\n"
    1.49 -            ^ string_of_thm thm)
    1.50 -          else ();
    1.51 -        val _ = if (is_some o get_datatype_of_constr thy) c
    1.52 -          then error ("Rejected equation for datatype constructor:\n"
    1.53 -            ^ string_of_thm func)
    1.54 -          else ();
    1.55 -      in
    1.56 -        (map_exec_purge (SOME [c]) o map_funcs) (Symtab.map_default
    1.57 -          (c, (Susp.value [], [])) (add_thm func)) thy
    1.58 -      end
    1.59 -  | add_func false thm thy =
    1.60 -      case mk_func_liberal thm
    1.61 -       of SOME func => let
    1.62 -              val c = const_of_func thy func
    1.63 -            in if (is_some o AxClass.class_of_param thy) c
    1.64 -              orelse (is_some o get_datatype_of_constr thy) c
    1.65 -              then thy
    1.66 -              else map_exec_purge (SOME [c]) (map_funcs
    1.67 -              (Symtab.map_default
    1.68 -                (c, (Susp.value [], [])) (add_thm func))) thy
    1.69 -            end
    1.70 -        | NONE => thy;
    1.71 +fun add_func thm thy =
    1.72 +  let
    1.73 +    val func = mk_func thm;
    1.74 +    val c = const_of_func thy func;
    1.75 +    val _ = if (is_some o AxClass.class_of_param thy) c
    1.76 +      then error ("Rejected polymorphic equation for overloaded constant:\n"
    1.77 +        ^ string_of_thm thm)
    1.78 +      else ();
    1.79 +    val _ = if (is_some o get_datatype_of_constr thy) c
    1.80 +      then error ("Rejected equation for datatype constructor:\n"
    1.81 +        ^ string_of_thm func)
    1.82 +      else ();
    1.83 +  in
    1.84 +    (map_exec_purge (SOME [c]) o map_funcs) (Symtab.map_default
    1.85 +      (c, (Susp.value [], [])) (add_thm func)) thy
    1.86 +  end;
    1.87  
    1.88 -fun delete_force msg key xs =
    1.89 -  if AList.defined (op =) xs key then AList.delete (op =) key xs
    1.90 -  else error ("No such " ^ msg ^ ": " ^ quote key);
    1.91 +fun add_liberal_func thm thy =
    1.92 +  case mk_liberal_func thm
    1.93 +   of SOME func => let
    1.94 +          val c = const_of_func thy func
    1.95 +        in if (is_some o AxClass.class_of_param thy) c
    1.96 +          orelse (is_some o get_datatype_of_constr thy) c
    1.97 +          then thy
    1.98 +          else map_exec_purge (SOME [c]) (map_funcs
    1.99 +            (Symtab.map_default
   1.100 +              (c, (Susp.value [], [])) (add_thm func))) thy
   1.101 +        end
   1.102 +    | NONE => thy;
   1.103 +
   1.104 +fun add_default_func thm thy =
   1.105 +  case mk_default_func thm
   1.106 +   of SOME func => let
   1.107 +          val c = const_of_func thy func
   1.108 +        in if (is_some o AxClass.class_of_param thy) c
   1.109 +          orelse (is_some o get_datatype_of_constr thy) c
   1.110 +          then thy
   1.111 +          else map_exec_purge (SOME [c]) (map_funcs
   1.112 +          (Symtab.map_default
   1.113 +            (c, (Susp.value [], [])) (add_thm func))) thy
   1.114 +        end
   1.115 +    | NONE => thy;
   1.116  
   1.117  fun del_func thm thy =
   1.118    let
   1.119 @@ -719,8 +736,8 @@
   1.120        (add_lthms lthms'))) thy
   1.121    end;
   1.122  
   1.123 -fun add_func_attr strict = Attrib.internal (fn _ => Thm.declaration_attribute
   1.124 -  (fn thm => Context.mapping (add_func strict thm) I));
   1.125 +val add_default_func_attr = Attrib.internal (fn _ => Thm.declaration_attribute
   1.126 +  (fn thm => Context.mapping (add_default_func thm) I));
   1.127  
   1.128  fun add_datatype raw_cs thy =
   1.129    let
   1.130 @@ -786,7 +803,7 @@
   1.131        add_attribute (name, Args.del |-- Scan.succeed (mk_attribute del)
   1.132          || Scan.succeed (mk_attribute add))
   1.133    in
   1.134 -    add_del_attribute ("func", (add_func true, del_func))
   1.135 +    add_del_attribute ("func", (add_func, del_func))
   1.136      #> add_del_attribute ("inline", (add_inline, del_inline))
   1.137      #> add_del_attribute ("post", (add_post, del_post))
   1.138    end);