src/Tools/Code/code_eval.ML
changeset 38930 072363be3fd9
parent 38929 d9ac9dee764d
child 38931 5e84c11c4b8a
equal deleted inserted replaced
38929:d9ac9dee764d 38930:072363be3fd9
     7 signature CODE_EVAL =
     7 signature CODE_EVAL =
     8 sig
     8 sig
     9   val target: string
     9   val target: string
    10   val eval: string option -> string * (unit -> 'a) option Unsynchronized.ref
    10   val eval: string option -> string * (unit -> 'a) option Unsynchronized.ref
    11     -> ((term -> term) -> 'a -> 'a) -> theory -> term -> string list -> 'a
    11     -> ((term -> term) -> 'a -> 'a) -> theory -> term -> string list -> 'a
    12   val evaluation_code: theory -> string -> string list -> string list
       
    13     -> string * ((string * string) list * (string * string) list)
       
    14   val setup: theory -> theory
    12   val setup: theory -> theory
    15 end;
    13 end;
    16 
    14 
    17 structure Code_Eval : CODE_EVAL =
    15 structure Code_Eval : CODE_EVAL =
    18 struct
    16 struct
    19 
    17 
    20 (** generic **)
    18 (** generic **)
    21 
    19 
    22 val target = "Eval";
    20 val target = "Eval";
    23 
    21 
    24 val eval_struct_name = "Code";
    22 fun evaluation_code thy module_name tycos consts =
    25 
       
    26 fun evaluation_code thy struct_name_hint tycos consts =
       
    27   let
    23   let
    28     val (consts', (naming, program)) = Code_Thingol.consts_program thy false consts;
    24     val (consts', (naming, program)) = Code_Thingol.consts_program thy false consts;
    29     val tycos' = map (the o Code_Thingol.lookup_tyco naming) tycos;
    25     val tycos' = map (the o Code_Thingol.lookup_tyco naming) tycos;
    30     val struct_name = if struct_name_hint = "" then eval_struct_name
       
    31       else struct_name_hint;
       
    32     val (ml_code, target_names) = Code_Target.produce_code_for thy
    26     val (ml_code, target_names) = Code_Target.produce_code_for thy
    33       target NONE (SOME struct_name) [] naming program (consts' @ tycos');
    27       target NONE (SOME module_name) [] naming program (consts' @ tycos');
    34     val (consts'', tycos'') = chop (length consts') target_names;
    28     val (consts'', tycos'') = chop (length consts') target_names;
    35     val consts_map = map2 (fn const => fn NONE =>
    29     val consts_map = map2 (fn const => fn NONE =>
    36         error ("Constant " ^ (quote o Code.string_of_const thy) const
    30         error ("Constant " ^ (quote o Code.string_of_const thy) const
    37           ^ "\nhas a user-defined serialization")
    31           ^ "\nhas a user-defined serialization")
    38       | SOME const'' => (const, const'')) consts consts''
    32       | SOME const'' => (const, const'')) consts consts''
    67 
    61 
    68 (** instrumentalization by antiquotation **)
    62 (** instrumentalization by antiquotation **)
    69 
    63 
    70 local
    64 local
    71 
    65 
    72 structure CodeAntiqData = Proof_Data
    66 structure Code_Antiq_Data = Proof_Data
    73 (
    67 (
    74   type T = (string list * string list) * (bool * (string
    68   type T = (string list * string list) * (bool
    75     * (string * ((string * string) list * (string * string) list)) lazy));
    69     * (string * ((string * string) list * (string * string) list)) lazy);
    76   fun init _ = (([], []), (true, ("", Lazy.value ("", ([], [])))));
    70   fun init _ = (([], []), (true, (Lazy.value ("", ([], [])))));
    77 );
    71 );
    78 
    72 
    79 val is_first_occ = fst o snd o CodeAntiqData.get;
    73 val is_first_occ = fst o snd o Code_Antiq_Data.get;
    80 
    74 
    81 fun register_code new_tycos new_consts ctxt =
    75 fun register_code new_tycos new_consts ctxt =
    82   let
    76   let
    83     val ((tycos, consts), (_, (struct_name, _))) = CodeAntiqData.get ctxt;
    77     val ((tycos, consts), _) = Code_Antiq_Data.get ctxt;
    84     val tycos' = fold (insert (op =)) new_tycos tycos;
    78     val tycos' = fold (insert (op =)) new_tycos tycos;
    85     val consts' = fold (insert (op =)) new_consts consts;
    79     val consts' = fold (insert (op =)) new_consts consts;
    86     val (struct_name', ctxt') = if struct_name = ""
    80     val acc_code = Lazy.lazy (fn () =>
    87       then ML_Antiquote.variant eval_struct_name ctxt
    81       evaluation_code (ProofContext.theory_of ctxt) "Code" tycos' consts');
    88       else (struct_name, ctxt);
    82   in Code_Antiq_Data.put ((tycos', consts'), (false, acc_code)) ctxt end;
    89     val acc_code = Lazy.lazy
       
    90       (fn () => evaluation_code (ProofContext.theory_of ctxt) eval_struct_name tycos' consts');
       
    91   in CodeAntiqData.put ((tycos', consts'), (false, (struct_name', acc_code))) ctxt' end;
       
    92 
    83 
    93 fun register_const const = register_code [] [const];
    84 fun register_const const = register_code [] [const];
    94 
    85 
    95 fun register_datatype tyco constrs = register_code [tyco] constrs;
    86 fun register_datatype tyco constrs = register_code [tyco] constrs;
    96 
    87 
    97 fun print_const const all_struct_name tycos_map consts_map =
    88 fun print_const const all_struct_name tycos_map consts_map =
    98   (Long_Name.append all_struct_name o the o AList.lookup (op =) consts_map) const;
    89   (Long_Name.append all_struct_name o the o AList.lookup (op =) consts_map) const;
    99 
    90 
   100 fun print_code is_first print_it ctxt =
    91 fun print_code is_first print_it ctxt =
   101   let
    92   let
   102     val (_, (_, (struct_code_name, acc_code))) = CodeAntiqData.get ctxt;
    93     val (_, (_, acc_code)) = Code_Antiq_Data.get ctxt;
   103     val (ml_code, (tycos_map, consts_map)) = Lazy.force acc_code;
    94     val (ml_code, (tycos_map, consts_map)) = Lazy.force acc_code;
   104     val ml_code = if is_first then ml_code
    95     val ml_code = if is_first then ml_code
   105       else "";
    96       else "";
   106     val all_struct_name = "Isabelle." ^ struct_code_name;
    97     val all_struct_name = "Isabelle";
   107   in (ml_code, print_it all_struct_name tycos_map consts_map) end;
    98   in (ml_code, print_it all_struct_name tycos_map consts_map) end;
   108 
    99 
   109 in
   100 in
   110 
   101 
   111 fun ml_code_antiq raw_const background =
   102 fun ml_code_antiq raw_const background =