src/Pure/Isar/code.ML
changeset 28673 d746a8c12c43
parent 28672 0baf1d9c6780
child 28695 f7a06d7284c8
equal deleted inserted replaced
28672:0baf1d9c6780 28673:d746a8c12c43
    13   val add_liberal_eqn: thm -> theory -> theory
    13   val add_liberal_eqn: thm -> theory -> theory
    14   val add_default_eqn: thm -> theory -> theory
    14   val add_default_eqn: thm -> theory -> theory
    15   val add_default_eqn_attr: Attrib.src
    15   val add_default_eqn_attr: Attrib.src
    16   val del_eqn: thm -> theory -> theory
    16   val del_eqn: thm -> theory -> theory
    17   val del_eqns: string -> theory -> theory
    17   val del_eqns: string -> theory -> theory
    18   val add_eqnl: string * (thm * bool) list Susp.T -> theory -> theory
    18   val add_eqnl: string * (thm * bool) list Lazy.T -> theory -> theory
    19   val map_pre: (MetaSimplifier.simpset -> MetaSimplifier.simpset) -> theory -> theory
    19   val map_pre: (MetaSimplifier.simpset -> MetaSimplifier.simpset) -> theory -> theory
    20   val map_post: (MetaSimplifier.simpset -> MetaSimplifier.simpset) -> theory -> theory
    20   val map_post: (MetaSimplifier.simpset -> MetaSimplifier.simpset) -> theory -> theory
    21   val add_inline: thm -> theory -> theory
    21   val add_inline: thm -> theory -> theory
    22   val del_inline: thm -> theory -> theory
    22   val del_inline: thm -> theory -> theory
    23   val add_post: thm -> theory -> theory
    23   val add_post: thm -> theory -> theory
   115 
   115 
   116 (** logical and syntactical specification of executable code **)
   116 (** logical and syntactical specification of executable code **)
   117 
   117 
   118 (* defining equations with linear flag, default flag and lazy theorems *)
   118 (* defining equations with linear flag, default flag and lazy theorems *)
   119 
   119 
   120 fun pretty_lthms ctxt r = case Susp.peek r
   120 fun pretty_lthms ctxt r = case Lazy.peek r
   121  of SOME thms => map (ProofContext.pretty_thm ctxt o fst) (Exn.release thms)
   121  of SOME thms => map (ProofContext.pretty_thm ctxt o fst) (Exn.release thms)
   122   | NONE => [Pretty.str "[...]"];
   122   | NONE => [Pretty.str "[...]"];
   123 
   123 
   124 fun certificate thy f r =
   124 fun certificate thy f r =
   125   case Susp.peek r
   125   case Lazy.peek r
   126    of SOME thms => (Susp.value o f thy) (Exn.release thms)
   126    of SOME thms => (Lazy.value o f thy) (Exn.release thms)
   127     | NONE => let
   127     | NONE => let
   128         val thy_ref = Theory.check_thy thy;
   128         val thy_ref = Theory.check_thy thy;
   129       in Susp.delay (fn () => (f (Theory.deref thy_ref) o Susp.force) r) end;
   129       in Lazy.lazy (fn () => (f (Theory.deref thy_ref) o Lazy.force) r) end;
   130 
   130 
   131 fun add_drop_redundant thy (thm, linear) thms =
   131 fun add_drop_redundant thy (thm, linear) thms =
   132   let
   132   let
   133     val args_of = snd o strip_comb o fst o Logic.dest_equals o Thm.plain_prop_of;
   133     val args_of = snd o strip_comb o fst o Logic.dest_equals o Thm.plain_prop_of;
   134     val args = args_of thm;
   134     val args = args_of thm;
   139       andalso matches_args (args_of thm') then 
   139       andalso matches_args (args_of thm') then 
   140         (warning ("Code generator: dropping redundant defining equation\n" ^ Display.string_of_thm thm'); true)
   140         (warning ("Code generator: dropping redundant defining equation\n" ^ Display.string_of_thm thm'); true)
   141       else false;
   141       else false;
   142   in (thm, linear) :: filter_out drop thms end;
   142   in (thm, linear) :: filter_out drop thms end;
   143 
   143 
   144 fun add_thm thy _ thm (false, thms) = (false, Susp.map_force (add_drop_redundant thy thm) thms)
   144 fun add_thm thy _ thm (false, thms) = (false, Lazy.map_force (add_drop_redundant thy thm) thms)
   145   | add_thm thy true thm (true, thms) = (true, Susp.map_force (fn thms => thms @ [thm]) thms)
   145   | add_thm thy true thm (true, thms) = (true, Lazy.map_force (fn thms => thms @ [thm]) thms)
   146   | add_thm thy false thm (true, thms) = (false, Susp.value [thm]);
   146   | add_thm thy false thm (true, thms) = (false, Lazy.value [thm]);
   147 
   147 
   148 fun add_lthms lthms _ = (false, lthms);
   148 fun add_lthms lthms _ = (false, lthms);
   149 
   149 
   150 fun del_thm thm = (apsnd o Susp.map_force) (remove (eq_fst Thm.eq_thm_prop) (thm, true));
   150 fun del_thm thm = (apsnd o Lazy.map_force) (remove (eq_fst Thm.eq_thm_prop) (thm, true));
   151 
   151 
   152 fun merge_defthms ((true, _), defthms2) = defthms2
   152 fun merge_defthms ((true, _), defthms2) = defthms2
   153   | merge_defthms (defthms1 as (false, _), (true, _)) = defthms1
   153   | merge_defthms (defthms1 as (false, _), (true, _)) = defthms1
   154   | merge_defthms ((false, _), defthms2 as (false, _)) = defthms2;
   154   | merge_defthms ((false, _), defthms2 as (false, _)) = defthms2;
   155 
   155 
   169 
   169 
   170 
   170 
   171 (* specification data *)
   171 (* specification data *)
   172 
   172 
   173 datatype spec = Spec of {
   173 datatype spec = Spec of {
   174   eqns: (bool * (thm * bool) list Susp.T) Symtab.table,
   174   eqns: (bool * (thm * bool) list Lazy.T) Symtab.table,
   175   dtyps: ((string * sort) list * (string * typ list) list) Symtab.table,
   175   dtyps: ((string * sort) list * (string * typ list) list) Symtab.table,
   176   cases: (int * string list) Symtab.table * unit Symtab.table
   176   cases: (int * string list) Symtab.table * unit Symtab.table
   177 };
   177 };
   178 
   178 
   179 fun mk_spec (eqns, (dtyps, cases)) =
   179 fun mk_spec (eqns, (dtyps, cases)) =
   469     val base_constraints = Sorts.mg_domain algebra tyco [class];
   469     val base_constraints = Sorts.mg_domain algebra tyco [class];
   470     val classparam_constraints = Sorts.complete_sort algebra [class]
   470     val classparam_constraints = Sorts.complete_sort algebra [class]
   471       |> maps (map fst o these o try (#params o AxClass.get_info thy))
   471       |> maps (map fst o these o try (#params o AxClass.get_info thy))
   472       |> map_filter (fn c => try (AxClass.param_of_inst thy) (c, tyco))
   472       |> map_filter (fn c => try (AxClass.param_of_inst thy) (c, tyco))
   473       |> map (Symtab.lookup ((the_eqns o the_exec) thy))
   473       |> map (Symtab.lookup ((the_eqns o the_exec) thy))
   474       |> (map o Option.map) (map fst o Susp.force o snd)
   474       |> (map o Option.map) (map fst o Lazy.force o snd)
   475       |> maps these
   475       |> maps these
   476       |> map (map (snd o dest_TVar) o Sign.const_typargs thy o Code_Unit.const_typ_eqn);
   476       |> map (map (snd o dest_TVar) o Sign.const_typargs thy o Code_Unit.const_typ_eqn);
   477     val inter_sorts = map2 (curry (Sorts.inter_sort algebra));
   477     val inter_sorts = map2 (curry (Sorts.inter_sort algebra));
   478   in fold inter_sorts classparam_constraints base_constraints end;
   478   in fold inter_sorts classparam_constraints base_constraints end;
   479 
   479 
   542             then error ("Rejected equation for datatype constructor:\n"
   542             then error ("Rejected equation for datatype constructor:\n"
   543               ^ Display.string_of_thm thm)
   543               ^ Display.string_of_thm thm)
   544             else ();
   544             else ();
   545         in
   545         in
   546           (map_exec_purge (SOME [c]) o map_eqns) (Symtab.map_default
   546           (map_exec_purge (SOME [c]) o map_eqns) (Symtab.map_default
   547             (c, (true, Susp.value [])) (add_thm thy default (thm, linear))) thy
   547             (c, (true, Lazy.value [])) (add_thm thy default (thm, linear))) thy
   548         end
   548         end
   549     | NONE => thy;
   549     | NONE => thy;
   550 
   550 
   551 val add_eqn = gen_add_eqn true true false;
   551 val add_eqn = gen_add_eqn true true false;
   552 val add_liberal_eqn = gen_add_eqn true false false;
   552 val add_liberal_eqn = gen_add_eqn true false false;
   557  of SOME (thm, _) => let val c = Code_Unit.const_eqn thm
   557  of SOME (thm, _) => let val c = Code_Unit.const_eqn thm
   558       in map_exec_purge (SOME [c]) (map_eqns (Symtab.map_entry c (del_thm thm))) thy end
   558       in map_exec_purge (SOME [c]) (map_eqns (Symtab.map_entry c (del_thm thm))) thy end
   559   | NONE => thy;
   559   | NONE => thy;
   560 
   560 
   561 fun del_eqns c = map_exec_purge (SOME [c])
   561 fun del_eqns c = map_exec_purge (SOME [c])
   562   (map_eqns (Symtab.map_entry c (K (false, Susp.value []))));
   562   (map_eqns (Symtab.map_entry c (K (false, Lazy.value []))));
   563 
   563 
   564 fun add_eqnl (c, lthms) thy =
   564 fun add_eqnl (c, lthms) thy =
   565   let
   565   let
   566     val lthms' = certificate thy
   566     val lthms' = certificate thy
   567       (fn thy => map (Code_Unit.assert_linear) o certify_const thy c) lthms;
   567       (fn thy => map (Code_Unit.assert_linear) o certify_const thy c) lthms;
   568   in
   568   in
   569     map_exec_purge (SOME [c])
   569     map_exec_purge (SOME [c])
   570       (map_eqns (Symtab.map_default (c, (true, Susp.value []))
   570       (map_eqns (Symtab.map_default (c, (true, Lazy.value []))
   571         (add_lthms lthms'))) thy
   571         (add_lthms lthms'))) thy
   572   end;
   572   end;
   573 
   573 
   574 val add_default_eqn_attr = Attrib.internal (fn _ => Thm.declaration_attribute
   574 val add_default_eqn_attr = Attrib.internal (fn _ => Thm.declaration_attribute
   575   (fn thm => Context.mapping (add_default_eqn thm) I));
   575   (fn thm => Context.mapping (add_default_eqn thm) I));
   646 
   646 
   647 local
   647 local
   648 
   648 
   649 fun get_eqns thy c =
   649 fun get_eqns thy c =
   650   Symtab.lookup ((the_eqns o the_exec) thy) c
   650   Symtab.lookup ((the_eqns o the_exec) thy) c
   651   |> Option.map (Susp.force o snd)
   651   |> Option.map (Lazy.force o snd)
   652   |> these
   652   |> these
   653   |> (map o apfst) (Thm.transfer thy);
   653   |> (map o apfst) (Thm.transfer thy);
   654 
   654 
   655 fun apply_functrans thy c _ [] = []
   655 fun apply_functrans thy c _ [] = []
   656   | apply_functrans thy c [] eqns = eqns
   656   | apply_functrans thy c [] eqns = eqns