src/Tools/Code/code_runtime.ML

--- a/src/Tools/Code/code_runtime.ML	Tue Dec 21 09:18:29 2010 +0100
+++ b/src/Tools/Code/code_runtime.ML	Tue Dec 21 09:18:29 2010 +0100
@@ -86,25 +86,15 @@
     val ctxt = ProofContext.init_global thy;
   in ((Sign.no_frees ctxt o Sign.no_vars ctxt o map_types (K dummyT)) t; t) end;
 
-fun obtain_serializer thy some_target = Code_Target.produce_code_for thy
-  (the_default target some_target) NONE "Code" [];
+fun obtain_evaluator thy some_target naming program deps =
+  Code_Target.evaluator thy (the_default target some_target) naming program deps;
 
-fun base_evaluator cookie serializer (naming : Code_Thingol.naming) thy program ((vs, ty), t) deps args =
+fun evaluation cookie thy evaluator vs_t args =
   let
     val ctxt = ProofContext.init_global thy;
-    val _ = if Code_Thingol.contains_dict_var t then
-      error "Term to be evaluated contains free dictionaries" else ();
-    val v' = Name.variant (map fst vs) "a";
-    val vs' = (v', []) :: vs;
-    val ty' = Code_Thingol.fun_tyco `%% [ITyVar v', ty];
-    val value_name = "Value.value.value"
-    val program' = program
-      |> Graph.new_node (value_name,
-          Code_Thingol.Fun (Term.dummy_patternN, (((vs', ty'), [(([IVar NONE], t), (NONE, true))]), NONE)))
-      |> fold (curry Graph.add_edge value_name) deps;
-    val (program_code, [SOME value_name']) = serializer naming program' [value_name];
+    val (program_code, value_name) = evaluator vs_t;
     val value_code = space_implode " "
-      (value_name' :: "()" :: map (enclose "(" ")") args);
+      (value_name :: "()" :: map (enclose "(" ")") args);
   in Exn.interruptible_capture (value ctxt cookie) (program_code, value_code) end;
 
 fun partiality_as_none e = SOME (Exn.release e)
@@ -119,7 +109,7 @@
       then tracing ("Evaluation of term " ^ quote (Syntax.string_of_term_global thy t))
       else ()
     fun evaluator naming program ((_, vs_ty), t) deps =
-      base_evaluator cookie (obtain_serializer thy some_target) naming thy program (vs_ty, t) deps args;
+      evaluation cookie thy (obtain_evaluator thy some_target naming program deps) (vs_ty, t) args;
   in Code_Thingol.dynamic_value thy (Exn.map_result o postproc) evaluator t end;
 
 fun dynamic_value_strict cookie thy some_target postproc t args =
@@ -128,18 +118,20 @@
 fun dynamic_value cookie thy some_target postproc t args =
   partiality_as_none (dynamic_value_exn cookie thy some_target postproc t args);
 
-fun static_value_exn cookie thy some_target postproc consts =
+fun static_evaluator cookie thy some_target naming program consts' =
   let
-    val serializer = obtain_serializer thy some_target;
-    fun evaluator naming program thy ((_, vs_ty), t) deps =
-      base_evaluator cookie serializer naming thy program (vs_ty, t) deps [];
-  in Code_Thingol.static_value thy (Exn.map_result o postproc) consts evaluator o reject_vars thy end;
+    val evaluator = obtain_evaluator thy some_target naming program consts'
+  in fn ((_, vs_ty), t) => fn _ => evaluation cookie thy evaluator (vs_ty, t) [] end;
 
-fun static_value_strict cookie thy some_target postproc consts t =
-  Exn.release (static_value_exn cookie thy some_target postproc consts t);
+fun static_value_exn cookie thy some_target postproc consts =
+  Code_Thingol.static_value thy (Exn.map_result o postproc) consts
+    (static_evaluator cookie thy some_target) o reject_vars thy;
 
-fun static_value cookie thy some_target postproc consts t =
-  partiality_as_none (static_value_exn cookie thy some_target postproc consts t);
+fun static_value_strict cookie thy some_target postproc consts =
+  Exn.release o static_value_exn cookie thy some_target postproc consts;
+
+fun static_value cookie thy some_target postproc consts =
+  partiality_as_none o static_value_exn cookie thy some_target postproc consts;
 
 
 (* evaluation for truth or nothing *)
@@ -154,14 +146,15 @@
 
 val reject_vars = fn thy => tap (reject_vars thy o Thm.term_of);
 
-fun check_holds serializer naming thy program vs_t deps ct =
+fun check_holds some_target naming thy program vs_t deps ct =
   let
     val t = Thm.term_of ct;
     val _ = if fastype_of t <> propT
       then error ("Not a proposition: " ^ Syntax.string_of_term_global thy t)
       else ();
     val iff = Thm.cterm_of thy (Term.Const ("==", propT --> propT --> propT));
-    val result = case partiality_as_none (base_evaluator truth_cookie serializer naming thy program vs_t deps [])
+    val result = case partiality_as_none
+      (evaluation truth_cookie thy (obtain_evaluator thy some_target naming program deps) vs_t [])
      of SOME Holds => true
       | _ => false;
   in
@@ -176,17 +169,13 @@
   raw_check_holds_oracle (serializer, naming, thy, program, (vs_ty, t), deps, ct);
 
 fun dynamic_holds_conv thy = Code_Thingol.dynamic_conv thy
-    (fn naming => check_holds_oracle (obtain_serializer thy NONE) naming thy)
+    (fn naming => check_holds_oracle NONE naming thy)
   o reject_vars thy;
 
 fun static_holds_conv thy consts =
-  let
-    val serializer = obtain_serializer thy NONE;
-  in
-    Code_Thingol.static_conv thy consts
-      (fn naming => fn program => fn thy => check_holds_oracle serializer naming thy program)
-    o reject_vars thy
-  end;
+  Code_Thingol.static_conv thy consts
+    (fn naming => fn program => fn consts' => check_holds_oracle NONE naming thy program)
+    o reject_vars thy;
 
 
 (** instrumentalization **)