50 val structure_generated = "Generated_Code"; |
50 val structure_generated = "Generated_Code"; |
51 |
51 |
52 datatype truth = Holds; |
52 datatype truth = Holds; |
53 |
53 |
54 val _ = Theory.setup |
54 val _ = Theory.setup |
55 (Code_Target.extend_target (target, (Code_ML.target_SML, K I)) |
55 (Code_Target.extend_target (target, (Code_ML.target_SML, I)) |
56 #> Code_Target.set_printings (Code_Symbol.Type_Constructor (@{type_name prop}, |
56 #> Code_Target.set_printings (Code_Symbol.Type_Constructor (@{type_name prop}, |
57 [(target, SOME (0, (K o K o K) (Code_Printer.str s_truth)))])) |
57 [(target, SOME (0, (K o K o K) (Code_Printer.str s_truth)))])) |
58 #> Code_Target.set_printings (Code_Symbol.Constant (@{const_name Code_Generator.holds}, |
58 #> Code_Target.set_printings (Code_Symbol.Constant (@{const_name Code_Generator.holds}, |
59 [(target, SOME (Code_Printer.plain_const_syntax s_Holds))])) |
59 [(target, SOME (Code_Printer.plain_const_syntax s_Holds))])) |
60 #> Code_Target.add_reserved target this |
60 #> Code_Target.add_reserved target this |
85 fun reject_vars thy t = |
85 fun reject_vars thy t = |
86 let |
86 let |
87 val ctxt = Proof_Context.init_global thy; |
87 val ctxt = Proof_Context.init_global thy; |
88 in ((Sign.no_frees ctxt o Sign.no_vars ctxt o map_types (K dummyT)) t; t) end; |
88 in ((Sign.no_frees ctxt o Sign.no_vars ctxt o map_types (K dummyT)) t; t) end; |
89 |
89 |
90 fun obtain_evaluator thy some_target naming program consts expr = |
90 fun obtain_evaluator thy some_target program consts expr = |
91 Code_Target.evaluator thy (the_default target some_target) naming program consts expr |
91 Code_Target.evaluator thy (the_default target some_target) program consts expr |
92 |> apfst (fn ml_modules => space_implode "\n\n" (map snd ml_modules)); |
92 |> apfst (fn ml_modules => space_implode "\n\n" (map snd ml_modules)); |
|
93 |
|
94 fun obtain_evaluator' thy some_target program = |
|
95 obtain_evaluator thy some_target program o map Code_Symbol.Constant; |
93 |
96 |
94 fun evaluation cookie thy evaluator vs_t args = |
97 fun evaluation cookie thy evaluator vs_t args = |
95 let |
98 let |
96 val ctxt = Proof_Context.init_global thy; |
99 val ctxt = Proof_Context.init_global thy; |
97 val (program_code, value_name) = evaluator vs_t; |
100 val (program_code, value_name) = evaluator vs_t; |
108 let |
111 let |
109 val _ = reject_vars thy t; |
112 val _ = reject_vars thy t; |
110 val _ = if ! trace |
113 val _ = if ! trace |
111 then tracing ("Evaluation of term " ^ quote (Syntax.string_of_term_global thy t)) |
114 then tracing ("Evaluation of term " ^ quote (Syntax.string_of_term_global thy t)) |
112 else () |
115 else () |
113 fun evaluator naming program ((_, vs_ty), t) deps = |
116 fun evaluator program ((_, vs_ty), t) deps = |
114 evaluation cookie thy (obtain_evaluator thy some_target naming program deps) (vs_ty, t) args; |
117 evaluation cookie thy (obtain_evaluator thy some_target program deps) (vs_ty, t) args; |
115 in Code_Thingol.dynamic_value thy (Exn.map_result o postproc) evaluator t end; |
118 in Code_Thingol.dynamic_value thy (Exn.map_result o postproc) evaluator t end; |
116 |
119 |
117 fun dynamic_value_strict cookie thy some_target postproc t args = |
120 fun dynamic_value_strict cookie thy some_target postproc t args = |
118 Exn.release (dynamic_value_exn cookie thy some_target postproc t args); |
121 Exn.release (dynamic_value_exn cookie thy some_target postproc t args); |
119 |
122 |
120 fun dynamic_value cookie thy some_target postproc t args = |
123 fun dynamic_value cookie thy some_target postproc t args = |
121 partiality_as_none (dynamic_value_exn cookie thy some_target postproc t args); |
124 partiality_as_none (dynamic_value_exn cookie thy some_target postproc t args); |
122 |
125 |
123 fun static_evaluator cookie thy some_target naming program consts' = |
126 fun static_evaluator cookie thy some_target program consts' = |
124 let |
127 let |
125 val evaluator = obtain_evaluator thy some_target naming program consts' |
128 val evaluator = obtain_evaluator' thy some_target program consts' |
126 in fn ((_, vs_ty), t) => fn _ => evaluation cookie thy evaluator (vs_ty, t) [] end; |
129 in fn ((_, vs_ty), t) => fn _ => evaluation cookie thy evaluator (vs_ty, t) [] end; |
127 |
130 |
128 fun static_value_exn cookie thy some_target postproc consts = |
131 fun static_value_exn cookie thy some_target postproc consts = |
129 Code_Thingol.static_value thy (Exn.map_result o postproc) consts |
132 Code_Thingol.static_value thy (Exn.map_result o postproc) consts |
130 (static_evaluator cookie thy some_target) o reject_vars thy; |
133 (static_evaluator cookie thy some_target) o reject_vars thy; |
173 raw_check_holds_oracle (thy, evaluator, (vs_ty, t), ct); |
176 raw_check_holds_oracle (thy, evaluator, (vs_ty, t), ct); |
174 |
177 |
175 in |
178 in |
176 |
179 |
177 fun dynamic_holds_conv thy = Code_Thingol.dynamic_conv thy |
180 fun dynamic_holds_conv thy = Code_Thingol.dynamic_conv thy |
178 (fn naming => fn program => fn vs_t => fn deps => |
181 (fn program => fn vs_t => fn deps => |
179 check_holds_oracle thy (obtain_evaluator thy NONE naming program deps) vs_t deps) |
182 check_holds_oracle thy (obtain_evaluator thy NONE program deps) vs_t deps) |
180 o reject_vars thy; |
183 o reject_vars thy; |
181 |
184 |
182 fun static_holds_conv thy consts = Code_Thingol.static_conv thy consts |
185 fun static_holds_conv thy consts = Code_Thingol.static_conv thy consts |
183 (fn naming => fn program => fn consts' => |
186 (fn program => fn consts' => |
184 check_holds_oracle thy (obtain_evaluator thy NONE naming program consts')) |
187 check_holds_oracle thy (obtain_evaluator' thy NONE program consts')) |
185 o reject_vars thy; |
188 o reject_vars thy; |
186 |
189 |
187 end; (*local*) |
190 end; (*local*) |
188 |
191 |
189 |
192 |
190 (** instrumentalization **) |
193 (** instrumentalization **) |
191 |
194 |
192 fun evaluation_code thy module_name tycos consts = |
195 fun evaluation_code thy module_name tycos consts = |
193 let |
196 let |
194 val ctxt = Proof_Context.init_global thy; |
197 val ctxt = Proof_Context.init_global thy; |
195 val (consts', (naming, program)) = Code_Thingol.consts_program thy false consts; |
198 val program = Code_Thingol.consts_program thy false consts; |
196 val tycos' = map (the o Code_Thingol.lookup_tyco naming) tycos; |
|
197 val (ml_modules, target_names) = |
199 val (ml_modules, target_names) = |
198 Code_Target.produce_code_for thy |
200 Code_Target.produce_code_for thy |
199 target NONE module_name [] naming program (consts' @ tycos'); |
201 target NONE module_name [] program (map Code_Symbol.Constant consts @ map Code_Symbol.Type_Constructor tycos); |
200 val ml_code = space_implode "\n\n" (map snd ml_modules); |
202 val ml_code = space_implode "\n\n" (map snd ml_modules); |
201 val (consts'', tycos'') = chop (length consts') target_names; |
203 val (consts', tycos') = chop (length consts) target_names; |
202 val consts_map = map2 (fn const => |
204 val consts_map = map2 (fn const => |
203 fn NONE => |
205 fn NONE => |
204 error ("Constant " ^ (quote o Code.string_of_const thy) const ^ |
206 error ("Constant " ^ (quote o Code.string_of_const thy) const ^ |
205 "\nhas a user-defined serialization") |
207 "\nhas a user-defined serialization") |
206 | SOME const'' => (const, const'')) consts consts'' |
208 | SOME const' => (const, const')) consts consts' |
207 val tycos_map = map2 (fn tyco => |
209 val tycos_map = map2 (fn tyco => |
208 fn NONE => |
210 fn NONE => |
209 error ("Type " ^ quote (Proof_Context.extern_type ctxt tyco) ^ |
211 error ("Type " ^ quote (Proof_Context.extern_type ctxt tyco) ^ |
210 "\nhas a user-defined serialization") |
212 "\nhas a user-defined serialization") |
211 | SOME tyco'' => (tyco, tyco'')) tycos tycos''; |
213 | SOME tyco' => (tyco, tyco')) tycos tycos'; |
212 in (ml_code, (tycos_map, consts_map)) end; |
214 in (ml_code, (tycos_map, consts_map)) end; |
213 |
215 |
214 |
216 |
215 (* by antiquotation *) |
217 (* by antiquotation *) |
216 |
218 |