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 |