new structure for code generator modules
authorhaftmann
Fri Aug 10 17:04:34 2007 +0200 (2007-08-10)
changeset 24219e558fe311376
parent 24218 fbf1646b267c
child 24220 a479ac416ac2
new structure for code generator modules
src/HOL/HOL.thy
src/HOL/Lambda/WeakNorm.thy
src/HOL/Library/Eval.thy
src/HOL/Library/ML_Int.thy
src/HOL/Library/ML_String.thy
src/HOL/Library/Pretty_Char.thy
src/HOL/Library/Pretty_Int.thy
src/HOL/List.thy
src/HOL/Tools/datatype_codegen.ML
src/HOL/Tools/inductive_codegen.ML
src/HOL/Tools/inductive_set_package.ML
src/HOL/Tools/recfun_codegen.ML
src/HOL/Tools/record_package.ML
src/HOL/Tools/typecopy_package.ML
src/Pure/IsaMakefile
src/Pure/Isar/ROOT.ML
src/Pure/Isar/code.ML
src/Pure/Isar/code_unit.ML
src/Pure/Isar/constdefs.ML
src/Pure/Isar/isar_syn.ML
src/Pure/Isar/specification.ML
src/Pure/Proof/extraction.ML
src/Pure/Tools/ROOT.ML
src/Pure/Tools/codegen_consts.ML
src/Pure/Tools/codegen_data.ML
src/Pure/Tools/codegen_func.ML
src/Pure/Tools/codegen_funcgr.ML
src/Pure/Tools/codegen_names.ML
src/Pure/Tools/codegen_package.ML
src/Pure/Tools/codegen_serializer.ML
src/Pure/Tools/codegen_thingol.ML
src/Pure/Tools/nbe.ML
src/Pure/Tools/nbe_codegen.ML
src/Pure/Tools/nbe_eval.ML
src/Pure/codegen.ML
src/Tools/code/code_funcgr.ML
src/Tools/code/code_name.ML
src/Tools/code/code_package.ML
src/Tools/code/code_target.ML
src/Tools/code/code_thingol.ML
src/Tools/nbe.ML
     1.1 --- a/src/HOL/HOL.thy	Fri Aug 10 17:04:24 2007 +0200
     1.2 +++ b/src/HOL/HOL.thy	Fri Aug 10 17:04:34 2007 +0200
     1.3 @@ -183,7 +183,7 @@
     1.4    True_or_False:  "(P=True) | (P=False)"
     1.5  
     1.6  defs
     1.7 -  Let_def [code func]: "Let s f == f(s)"
     1.8 +  Let_def:      "Let s f == f(s)"
     1.9    if_def:       "If P x y == THE z::'a. (P=True --> z=x) & (P=False --> z=y)"
    1.10  
    1.11  finalconsts
    1.12 @@ -1701,6 +1701,8 @@
    1.13  
    1.14  subsubsection {* Generic code generator setup *}
    1.15  
    1.16 +setup "CodeName.setup #> CodeTarget.setup"
    1.17 +
    1.18  text {* operational equality for code generation *}
    1.19  
    1.20  class eq (attach "op =") = type
    1.21 @@ -1737,8 +1739,6 @@
    1.22  
    1.23  lemmas [code] = imp_conv_disj
    1.24  
    1.25 -lemmas [code func] = if_True if_False
    1.26 -
    1.27  instance bool :: eq ..
    1.28  
    1.29  lemma [code func]:
    1.30 @@ -1796,15 +1796,18 @@
    1.31  
    1.32  text {* Let and If *}
    1.33  
    1.34 +lemmas [code func] = Let_def if_True if_False
    1.35 +
    1.36  setup {*
    1.37 -  CodegenPackage.add_appconst (@{const_name Let}, CodegenPackage.appgen_let)
    1.38 -  #> CodegenPackage.add_appconst (@{const_name If}, CodegenPackage.appgen_if)
    1.39 +  CodePackage.add_appconst (@{const_name Let}, CodePackage.appgen_let)
    1.40 +  #> CodePackage.add_appconst (@{const_name If}, CodePackage.appgen_if)
    1.41  *}
    1.42  
    1.43 +
    1.44  subsubsection {* Evaluation oracle *}
    1.45  
    1.46  oracle eval_oracle ("term") = {* fn thy => fn t => 
    1.47 -  if CodegenPackage.satisfies thy (HOLogic.dest_Trueprop t) [] 
    1.48 +  if CodePackage.satisfies thy (HOLogic.dest_Trueprop t) [] 
    1.49    then t
    1.50    else HOLogic.Trueprop $ HOLogic.true_const (*dummy*)
    1.51  *}
     2.1 --- a/src/HOL/Lambda/WeakNorm.thy	Fri Aug 10 17:04:24 2007 +0200
     2.2 +++ b/src/HOL/Lambda/WeakNorm.thy	Fri Aug 10 17:04:34 2007 +0200
     2.3 @@ -574,7 +574,7 @@
     2.4  *}
     2.5  
     2.6  setup {*
     2.7 -  CodegenSerializer.add_undefined "SML" "arbitrary" "(raise Fail \"arbitrary\")"
     2.8 +  CodeTarget.add_undefined "SML" "arbitrary" "(raise Fail \"arbitrary\")"
     2.9  *}
    2.10  
    2.11  definition
     3.1 --- a/src/HOL/Library/Eval.thy	Fri Aug 10 17:04:24 2007 +0200
     3.2 +++ b/src/HOL/Library/Eval.thy	Fri Aug 10 17:04:34 2007 +0200
     3.3 @@ -50,7 +50,7 @@
     3.4        (Type (tyco,
     3.5          map TFree (Name.names Name.context "'a" asorts))))]) arities, thy);
     3.6    fun hook specs =
     3.7 -    DatatypeCodegen.prove_codetypes_arities (ClassPackage.intro_classes_tac [])
     3.8 +    DatatypeCodegen.prove_codetypes_arities (Class.intro_classes_tac [])
     3.9        (map (fn (tyco, (is_dt, _)) => (tyco, is_dt)) specs)
    3.10        [TypOf.class_typ_of] mk ((K o K) I)
    3.11  in DatatypeCodegen.add_codetypes_hook_bootstrap hook end
    3.12 @@ -112,7 +112,7 @@
    3.13    fun hook specs =
    3.14      if (fst o hd) specs = (fst o dest_Type) @{typ typ} then I
    3.15      else
    3.16 -      DatatypeCodegen.prove_codetypes_arities (ClassPackage.intro_classes_tac [])
    3.17 +      DatatypeCodegen.prove_codetypes_arities (Class.intro_classes_tac [])
    3.18        (map (fn (tyco, (is_dt, _)) => (tyco, is_dt)) specs)
    3.19        [TermOf.class_term_of] ((K o K o pair) []) mk
    3.20  in DatatypeCodegen.add_codetypes_hook_bootstrap hook end
    3.21 @@ -165,7 +165,7 @@
    3.22  val eval_ref = ref (NONE : term option);
    3.23  
    3.24  fun eval_term thy t =
    3.25 -  CodegenPackage.eval_term
    3.26 +  CodePackage.eval_term
    3.27      thy (("Eval.eval_ref", eval_ref), TermOf.mk_term_of t);
    3.28  
    3.29  fun print eval s = Toplevel.keep (fn state =>
     4.1 --- a/src/HOL/Library/ML_Int.thy	Fri Aug 10 17:04:24 2007 +0200
     4.2 +++ b/src/HOL/Library/ML_Int.thy	Fri Aug 10 17:04:34 2007 +0200
     4.3 @@ -169,7 +169,7 @@
     4.4    (SML "int")
     4.5  
     4.6  setup {*
     4.7 -  CodegenSerializer.add_pretty_numeral "SML" false
     4.8 +  CodeTarget.add_pretty_numeral "SML" false
     4.9      (@{const_name number_of}, @{typ "int \<Rightarrow> ml_int"})
    4.10      @{const_name Numeral.B0} @{const_name Numeral.B1}
    4.11      @{const_name Numeral.Pls} @{const_name Numeral.Min}
     5.1 --- a/src/HOL/Library/ML_String.thy	Fri Aug 10 17:04:24 2007 +0200
     5.2 +++ b/src/HOL/Library/ML_String.thy	Fri Aug 10 17:04:34 2007 +0200
     5.3 @@ -60,7 +60,7 @@
     5.4      @{const_name NibbleC}, @{const_name NibbleD},
     5.5      @{const_name NibbleE}, @{const_name NibbleF}];
     5.6  in
     5.7 -  CodegenSerializer.add_pretty_ml_string "SML"
     5.8 +  CodeTarget.add_pretty_ml_string "SML"
     5.9      charr nibbles @{const_name Nil} @{const_name Cons} @{const_name STR}
    5.10  end
    5.11  *}
     6.1 --- a/src/HOL/Library/Pretty_Char.thy	Fri Aug 10 17:04:24 2007 +0200
     6.2 +++ b/src/HOL/Library/Pretty_Char.thy	Fri Aug 10 17:04:34 2007 +0200
     6.3 @@ -26,9 +26,9 @@
     6.4      @{const_name NibbleC}, @{const_name NibbleD},
     6.5      @{const_name NibbleE}, @{const_name NibbleF}];
     6.6  in
     6.7 -  fold (fn target => CodegenSerializer.add_pretty_char target charr nibbles)
     6.8 +  fold (fn target => CodeTarget.add_pretty_char target charr nibbles)
     6.9      ["SML", "OCaml", "Haskell"]
    6.10 -  #> CodegenSerializer.add_pretty_list_string "Haskell"
    6.11 +  #> CodeTarget.add_pretty_list_string "Haskell"
    6.12      @{const_name Nil} @{const_name Cons} charr nibbles
    6.13  end
    6.14  *}
     7.1 --- a/src/HOL/Library/Pretty_Int.thy	Fri Aug 10 17:04:24 2007 +0200
     7.2 +++ b/src/HOL/Library/Pretty_Int.thy	Fri Aug 10 17:04:34 2007 +0200
     7.3 @@ -24,7 +24,7 @@
     7.4    (Haskell -)
     7.5  
     7.6  setup {*
     7.7 -  fold (fn target => CodegenSerializer.add_pretty_numeral target true
     7.8 +  fold (fn target => CodeTarget.add_pretty_numeral target true
     7.9      (@{const_name number_of}, @{typ "int \<Rightarrow> int"})
    7.10      @{const_name Numeral.B0} @{const_name Numeral.B1}
    7.11      @{const_name Numeral.Pls} @{const_name Numeral.Min}
     8.1 --- a/src/HOL/List.thy	Fri Aug 10 17:04:24 2007 +0200
     8.2 +++ b/src/HOL/List.thy	Fri Aug 10 17:04:34 2007 +0200
     8.3 @@ -2815,7 +2815,7 @@
     8.4    (Haskell "[]")
     8.5  
     8.6  setup {*
     8.7 -  fold (fn target => CodegenSerializer.add_pretty_list target
     8.8 +  fold (fn target => CodeTarget.add_pretty_list target
     8.9      @{const_name Nil} @{const_name Cons}
    8.10    ) ["SML", "OCaml", "Haskell"]
    8.11  *}
     9.1 --- a/src/HOL/Tools/datatype_codegen.ML	Fri Aug 10 17:04:24 2007 +0200
     9.2 +++ b/src/HOL/Tools/datatype_codegen.ML	Fri Aug 10 17:04:34 2007 +0200
     9.3 @@ -538,7 +538,7 @@
     9.4  (* registering code types in code generator *)
     9.5  
     9.6  fun codetype_hook dtspecs =
     9.7 -  fold (fn (dtco, (_, spec)) => CodegenData.add_datatype (dtco, spec)) dtspecs;
     9.8 +  fold (fn (dtco, (_, spec)) => Code.add_datatype (dtco, spec)) dtspecs;
     9.9  
    9.10  
    9.11  (* instrumentalizing the sort algebra *)
    9.12 @@ -553,7 +553,7 @@
    9.13      val algebra' = algebra
    9.14        |> fold (fn (tyco, _) =>
    9.15             Sorts.add_arities pp (tyco, map (fn class => (class, map snd vs)) sort)) css;
    9.16 -    fun typ_sort_inst ty = CodegenConsts.typ_sort_inst algebra' (Logic.varifyT ty, sort);
    9.17 +    fun typ_sort_inst ty = CodeUnit.typ_sort_inst algebra' (Logic.varifyT ty, sort);
    9.18      val venv = Vartab.empty
    9.19        |> fold (fn (v, sort) => Vartab.update_new ((v, 0), sort)) vs
    9.20        |> fold (fn (_, cs) => fold (fn (_, tys) => fold typ_sort_inst tys) cs) css;
    9.21 @@ -585,7 +585,7 @@
    9.22          |> not (null arities) ? (
    9.23              f arities css
    9.24              #-> (fn defs =>
    9.25 -              ClassPackage.prove_instance_arity tac arities defs
    9.26 +              Class.prove_instance_arity tac arities defs
    9.27              #> after_qed arities css))
    9.28        end;
    9.29  
    9.30 @@ -600,10 +600,10 @@
    9.31          val const = ("op =", SOME dtco);
    9.32          val get_thms = (fn () => get_eq (Theory.deref thy_ref) dtco |> rev);
    9.33        in
    9.34 -        CodegenData.add_funcl (const, CodegenData.lazy_thms get_thms) thy
    9.35 +        Code.add_funcl (const, Susp.delay get_thms) thy
    9.36        end;
    9.37    in
    9.38 -    prove_codetypes_arities (ClassPackage.intro_classes_tac [])
    9.39 +    prove_codetypes_arities (Class.intro_classes_tac [])
    9.40        (map (fn (tyco, (is_dt, _)) => (tyco, is_dt)) specs)
    9.41        [HOLogic.class_eq] ((K o K o pair) []) ((K o K) (fold add_eq_thms specs))
    9.42    end;
    9.43 @@ -616,14 +616,14 @@
    9.44    let
    9.45      val {case_name, index, descr, ...} = DatatypePackage.the_datatype thy dtco;
    9.46    in
    9.47 -    CodegenPackage.add_appconst (case_name, CodegenPackage.appgen_case dest_case_expr) thy
    9.48 +    CodePackage.add_appconst (case_name, CodePackage.appgen_case dest_case_expr) thy
    9.49    end;
    9.50  
    9.51  fun add_datatype_case_defs dtco thy =
    9.52    let
    9.53      val {case_rewrites, ...} = DatatypePackage.the_datatype thy dtco
    9.54    in
    9.55 -    fold_rev (CodegenData.add_func true) case_rewrites thy
    9.56 +    fold_rev (Code.add_func true) case_rewrites thy
    9.57    end;
    9.58  
    9.59  val setup = 
    10.1 --- a/src/HOL/Tools/inductive_codegen.ML	Fri Aug 10 17:04:24 2007 +0200
    10.2 +++ b/src/HOL/Tools/inductive_codegen.ML	Fri Aug 10 17:04:34 2007 +0200
    10.3 @@ -697,7 +697,7 @@
    10.4  
    10.5  val setup =
    10.6    add_codegen "inductive" inductive_codegen #>
    10.7 -  add_attribute "ind" (Scan.option (Args.$$$ "target" |-- Args.colon |-- Args.name) --
    10.8 +  Code.add_attribute ("ind", Scan.option (Args.$$$ "target" |-- Args.colon |-- Args.name) --
    10.9      Scan.option (Args.$$$ "params" |-- Args.colon |-- Args.nat) >> uncurry add);
   10.10  
   10.11  end;
    11.1 --- a/src/HOL/Tools/inductive_set_package.ML	Fri Aug 10 17:04:24 2007 +0200
    11.2 +++ b/src/HOL/Tools/inductive_set_package.ML	Fri Aug 10 17:04:34 2007 +0200
    11.3 @@ -531,8 +531,8 @@
    11.4        "convert rule to set notation"),
    11.5       ("to_pred", Attrib.syntax (Attrib.thms >> to_pred_att),
    11.6        "convert rule to predicate notation")] #>
    11.7 -  Codegen.add_attribute "ind_set"
    11.8 -    (Scan.option (Args.$$$ "target" |-- Args.colon |-- Args.name) >> code_ind_att) #>
    11.9 +  Code.add_attribute ("ind_set",
   11.10 +    Scan.option (Args.$$$ "target" |-- Args.colon |-- Args.name) >> code_ind_att) #>
   11.11    Codegen.add_preprocessor codegen_preproc #>
   11.12    Attrib.add_attributes [("mono_set", Attrib.add_del_args mono_add_att mono_del_att,
   11.13      "declaration of monotonicity rule for set operators")] #>
    12.1 --- a/src/HOL/Tools/recfun_codegen.ML	Fri Aug 10 17:04:24 2007 +0200
    12.2 +++ b/src/HOL/Tools/recfun_codegen.ML	Fri Aug 10 17:04:34 2007 +0200
    12.3 @@ -44,7 +44,7 @@
    12.4        handle TERM _ => tap (fn _ => warn thm);
    12.5    in
    12.6      Thm.declaration_attribute (fn thm => Context.mapping
    12.7 -      (add thm #> CodegenData.add_func false thm) I)
    12.8 +      (add thm #> Code.add_func false thm) I)
    12.9    end;
   12.10  
   12.11  fun del_thm thm thy =
   12.12 @@ -58,7 +58,7 @@
   12.13    end handle TERM _ => (warn thm; thy);
   12.14  
   12.15  val del = Thm.declaration_attribute
   12.16 -  (fn thm => Context.mapping (del_thm thm #> CodegenData.del_func thm) I)
   12.17 +  (fn thm => Context.mapping (del_thm thm #> Code.del_func thm) I)
   12.18  
   12.19  fun del_redundant thy eqs [] = eqs
   12.20    | del_redundant thy eqs (eq :: eqs') =
   12.21 @@ -170,9 +170,8 @@
   12.22  
   12.23  
   12.24  val setup =
   12.25 -  add_codegen "recfun" recfun_codegen #>
   12.26 -  add_attribute ""
   12.27 -    (Args.del |-- Scan.succeed del
   12.28 +  add_codegen "recfun" recfun_codegen
   12.29 +  #> Code.add_attribute ("", Args.del |-- Scan.succeed del
   12.30       || Scan.option (Args.$$$ "target" |-- Args.colon |-- Args.name) >> add);
   12.31  
   12.32  end;
    13.1 --- a/src/HOL/Tools/record_package.ML	Fri Aug 10 17:04:24 2007 +0200
    13.2 +++ b/src/HOL/Tools/record_package.ML	Fri Aug 10 17:04:34 2007 +0200
    13.3 @@ -1512,8 +1512,8 @@
    13.4        ||>> PureThy.add_defs_i false (map Thm.no_attributes (ext_spec::dest_specs))
    13.5        ||>> PureThy.add_defs_i false (map Thm.no_attributes upd_specs)
    13.6        |-> (fn args as ((_, dest_defs), upd_defs) =>
    13.7 -          fold (CodegenData.add_func false) dest_defs
    13.8 -          #> fold (CodegenData.add_func false) upd_defs
    13.9 +          fold (Code.add_func false) dest_defs
   13.10 +          #> fold (Code.add_func false) upd_defs
   13.11            #> pair args);
   13.12      val ((([abs_inject, abs_inverse, abs_induct], ext_def :: dest_defs), upd_defs), defs_thy) =
   13.13        timeit_msg "record extension type/selector/update defs:" mk_defs;
   13.14 @@ -1916,9 +1916,9 @@
   13.15        ||>> ((PureThy.add_defs_i false o map Thm.no_attributes)
   13.16               [make_spec, fields_spec, extend_spec, truncate_spec])
   13.17        |-> (fn defs as ((sel_defs, upd_defs), derived_defs) => 
   13.18 -          fold (CodegenData.add_func false) sel_defs
   13.19 -          #> fold (CodegenData.add_func false) upd_defs
   13.20 -          #> fold (CodegenData.add_func false) derived_defs
   13.21 +          fold (Code.add_func false) sel_defs
   13.22 +          #> fold (Code.add_func false) upd_defs
   13.23 +          #> fold (Code.add_func false) derived_defs
   13.24            #> pair defs)
   13.25      val (((sel_defs, upd_defs), derived_defs), defs_thy) =
   13.26        timeit_msg "record trfuns/tyabbrs/selectors/updates/make/fields/extend/truncate defs:"
    14.1 --- a/src/HOL/Tools/typecopy_package.ML	Fri Aug 10 17:04:24 2007 +0200
    14.2 +++ b/src/HOL/Tools/typecopy_package.ML	Fri Aug 10 17:04:34 2007 +0200
    14.3 @@ -141,8 +141,7 @@
    14.4  
    14.5  (* hook for projection function code *)
    14.6  
    14.7 -fun add_project (_ , {proj_def, ...} : info) =
    14.8 -  CodegenData.add_func true proj_def;
    14.9 +fun add_project (_ , {proj_def, ...} : info) = Code.add_func true proj_def;
   14.10  
   14.11  val setup = add_hook add_project;
   14.12  
    15.1 --- a/src/Pure/IsaMakefile	Fri Aug 10 17:04:24 2007 +0200
    15.2 +++ b/src/Pure/IsaMakefile	Fri Aug 10 17:04:34 2007 +0200
    15.3 @@ -31,7 +31,8 @@
    15.4    General/scan.ML General/secure.ML General/seq.ML General/source.ML 		\
    15.5    General/stack.ML General/susp.ML General/symbol.ML General/table.ML 		\
    15.6    General/url.ML Isar/ROOT.ML Isar/antiquote.ML Isar/args.ML Isar/attrib.ML 	\
    15.7 -  Isar/auto_bind.ML Isar/calculation.ML Isar/constdefs.ML Isar/context_rules.ML \
    15.8 +  Isar/auto_bind.ML Isar/calculation.ML Isar/class.ML	\
    15.9 +  Isar/code_unit.ML Isar/code.ML Isar/constdefs.ML Isar/context_rules.ML \
   15.10    Isar/element.ML Isar/find_theorems.ML Isar/induct_attrib.ML Isar/isar_cmd.ML	\
   15.11    Isar/isar_syn.ML Isar/local_defs.ML Isar/local_syntax.ML Isar/local_theory.ML \
   15.12    Isar/locale.ML Isar/method.ML Isar/net_rules.ML Isar/object_logic.ML 		\
   15.13 @@ -40,6 +41,12 @@
   15.14    Isar/proof_display.ML Isar/proof_history.ML Isar/rule_cases.ML		\
   15.15    Isar/rule_insts.ML Isar/session.ML Isar/skip_proof.ML Isar/spec_parse.ML	\
   15.16    Isar/specification.ML Isar/theory_target.ML Isar/toplevel.ML			\
   15.17 +  $(SRC)/Pure/codegen.ML \
   15.18 +  $(SRC)/Tools/code/code_funcgr.ML \
   15.19 +  $(SRC)/Tools/code/code_thingol.ML \
   15.20 +  $(SRC)/Tools/code/code_target.ML \
   15.21 +  $(SRC)/Tools/code/code_name.ML \
   15.22 +  $(SRC)/Tools/code/code_package.ML \
   15.23    ML-Systems/alice.ML ML-Systems/exn.ML ML-Systems/multithreading_dummy.ML	\
   15.24    ML-Systems/multithreading_polyml.ML ML-Systems/overloading_smlnj.ML 		\
   15.25    ML-Systems/polyml-4.1.3.ML		\
   15.26 @@ -59,12 +66,10 @@
   15.27    Syntax/syntax.ML Syntax/type_ext.ML Thy/html.ML Thy/latex.ML			\
   15.28    Thy/ml_context.ML Thy/present.ML Thy/term_style.ML Thy/thm_database.ML	\
   15.29    Thy/thm_deps.ML Thy/thy_edit.ML Thy/thy_header.ML Thy/thy_info.ML		\
   15.30 -  Thy/thy_load.ML Thy/thy_output.ML Tools/ROOT.ML Tools/class_package.ML	\
   15.31 -  Tools/codegen_consts.ML Tools/codegen_data.ML Tools/codegen_func.ML		\
   15.32 -  Tools/codegen_funcgr.ML Tools/codegen_names.ML Tools/codegen_package.ML	\
   15.33 -  Tools/codegen_serializer.ML Tools/codegen_thingol.ML Tools/invoke.ML		\
   15.34 +  Thy/thy_load.ML Thy/thy_output.ML Tools/ROOT.ML  	\
   15.35 +  Tools/invoke.ML		\
   15.36    Tools/named_thms.ML	\
   15.37 -  Tools/xml.ML Tools/xml_syntax.ML assumption.ML axclass.ML codegen.ML		\
   15.38 +  Tools/xml.ML Tools/xml_syntax.ML assumption.ML axclass.ML		\
   15.39    compress.ML config.ML conjunction.ML consts.ML context.ML context_position.ML	\
   15.40    conv.ML defs.ML display.ML drule.ML envir.ML fact_index.ML goal.ML library.ML	\
   15.41    logic.ML meta_simplifier.ML more_thm.ML morphism.ML name.ML net.ML		\
    16.1 --- a/src/Pure/Isar/ROOT.ML	Fri Aug 10 17:04:24 2007 +0200
    16.2 +++ b/src/Pure/Isar/ROOT.ML	Fri Aug 10 17:04:34 2007 +0200
    16.3 @@ -43,10 +43,9 @@
    16.4  use "net_rules.ML";
    16.5  use "induct_attrib.ML";
    16.6  
    16.7 -(*code generator base*)
    16.8 -use "../Tools/codegen_consts.ML";
    16.9 -use "../Tools/codegen_func.ML";
   16.10 -use "../Tools/codegen_data.ML";
   16.11 +(*executable theory content*)
   16.12 +use "code_unit.ML";
   16.13 +use "code.ML";
   16.14  
   16.15  (*derived theory and proof elements*)
   16.16  use "local_theory.ML";
   16.17 @@ -54,7 +53,7 @@
   16.18  use "obtain.ML";
   16.19  use "locale.ML";
   16.20  use "spec_parse.ML";
   16.21 -use "../Tools/class_package.ML";
   16.22 +use "class.ML";
   16.23  use "theory_target.ML";
   16.24  use "specification.ML";
   16.25  use "constdefs.ML";
    17.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    17.2 +++ b/src/Pure/Isar/code.ML	Fri Aug 10 17:04:34 2007 +0200
    17.3 @@ -0,0 +1,925 @@
    17.4 +(*  Title:      Pure/Isar/code.ML
    17.5 +    ID:         $Id$
    17.6 +    Author:     Florian Haftmann, TU Muenchen
    17.7 +
    17.8 +Abstract executable content of theory.  Management of data dependent on
    17.9 +executable content.
   17.10 +*)
   17.11 +
   17.12 +signature CODE =
   17.13 +sig
   17.14 +  val add_func: bool -> thm -> theory -> theory
   17.15 +  val del_func: thm -> theory -> theory
   17.16 +  val add_funcl: CodeUnit.const * thm list Susp.T -> theory -> theory
   17.17 +  val add_func_attr: bool -> Attrib.src
   17.18 +  val add_inline: thm -> theory -> theory
   17.19 +  val del_inline: thm -> theory -> theory
   17.20 +  val add_inline_proc: string * (theory -> cterm list -> thm list) -> theory -> theory
   17.21 +  val del_inline_proc: string -> theory -> theory
   17.22 +  val add_preproc: string * (theory -> thm list -> thm list) -> theory -> theory
   17.23 +  val del_preproc: string -> theory -> theory
   17.24 +  val add_post: thm -> theory -> theory
   17.25 +  val del_post: thm -> theory -> theory
   17.26 +  val add_datatype: string * ((string * sort) list * (string * typ list) list)
   17.27 +    -> theory -> theory
   17.28 +  val add_datatype_consts: CodeUnit.const list -> theory -> theory
   17.29 +  val add_datatype_consts_cmd: string list -> theory -> theory
   17.30 +
   17.31 +  val coregular_algebra: theory -> Sorts.algebra
   17.32 +  val operational_algebra: theory -> (sort -> sort) * Sorts.algebra
   17.33 +  val these_funcs: theory -> CodeUnit.const -> thm list
   17.34 +  val get_datatype: theory -> string -> ((string * sort) list * (string * typ list) list)
   17.35 +  val get_datatype_of_constr: theory -> CodeUnit.const -> string option
   17.36 +  val default_typ: theory -> CodeUnit.const -> typ
   17.37 +
   17.38 +  val preprocess_conv: cterm -> thm
   17.39 +  val postprocess_conv: cterm -> thm
   17.40 +
   17.41 +  val add_attribute: string * (Args.T list -> attribute * Args.T list) -> theory -> theory
   17.42 +
   17.43 +  val print_codesetup: theory -> unit
   17.44 +end;
   17.45 +
   17.46 +signature CODE_DATA_ARGS =
   17.47 +sig
   17.48 +  type T
   17.49 +  val empty: T
   17.50 +  val merge: Pretty.pp -> T * T -> T
   17.51 +  val purge: theory option -> CodeUnit.const list option -> T -> T
   17.52 +end;
   17.53 +
   17.54 +signature CODE_DATA =
   17.55 +sig
   17.56 +  type T
   17.57 +  val get: theory -> T
   17.58 +  val change: theory -> (T -> T) -> T
   17.59 +  val change_yield: theory -> (T -> 'a * T) -> 'a * T
   17.60 +end;
   17.61 +
   17.62 +signature PRIVATE_CODE =
   17.63 +sig
   17.64 +  include CODE
   17.65 +  val declare_data: Object.T -> (Pretty.pp -> Object.T * Object.T -> Object.T)
   17.66 +    -> (theory option -> CodeUnit.const list option -> Object.T -> Object.T) -> serial
   17.67 +  val get_data: serial * ('a -> Object.T) * (Object.T -> 'a)
   17.68 +    -> theory -> 'a
   17.69 +  val change_data: serial * ('a -> Object.T) * (Object.T -> 'a)
   17.70 +    -> theory -> ('a -> 'a) -> 'a
   17.71 +  val change_yield_data: serial * ('a -> Object.T) * (Object.T -> 'a)
   17.72 +    -> theory -> ('a -> 'b * 'a) -> 'b * 'a
   17.73 +end;
   17.74 +
   17.75 +structure Code : PRIVATE_CODE =
   17.76 +struct
   17.77 +
   17.78 +(** preliminaries **)
   17.79 +
   17.80 +structure Consttab = CodeUnit.Consttab;
   17.81 +
   17.82 +
   17.83 +(* certificate theorems *)
   17.84 +
   17.85 +fun string_of_lthms r = case Susp.peek r
   17.86 + of SOME thms => (map string_of_thm o rev) thms
   17.87 +  | NONE => ["[...]"];
   17.88 +
   17.89 +fun pretty_lthms ctxt r = case Susp.peek r
   17.90 + of SOME thms => map (ProofContext.pretty_thm ctxt) thms
   17.91 +  | NONE => [Pretty.str "[...]"];
   17.92 +
   17.93 +fun certificate thy f r =
   17.94 +  case Susp.peek r
   17.95 +   of SOME thms => (Susp.value o f thy) thms
   17.96 +     | NONE => let
   17.97 +          val thy_ref = Theory.check_thy thy;
   17.98 +        in Susp.delay (fn () => (f (Theory.deref thy_ref) o Susp.force) r) end;
   17.99 +
  17.100 +fun merge' _ ([], []) = (false, [])
  17.101 +  | merge' _ ([], ys) = (true, ys)
  17.102 +  | merge' eq (xs, ys) = fold_rev
  17.103 +      (fn y => fn (t, xs) => (t orelse not (member eq xs y), insert eq y xs)) ys (false, xs);
  17.104 +
  17.105 +fun merge_alist eq_key eq (xys as (xs, ys)) =
  17.106 +  if eq_list (eq_pair eq_key eq) (xs, ys)
  17.107 +  then (false, xs)
  17.108 +  else (true, AList.merge eq_key eq xys);
  17.109 +
  17.110 +val merge_thms = merge' Thm.eq_thm_prop;
  17.111 +
  17.112 +fun merge_lthms (r1, r2) =
  17.113 +  if Susp.same (r1, r2)
  17.114 +    then (false, r1)
  17.115 +  else case Susp.peek r1
  17.116 +   of SOME [] => (true, r2)
  17.117 +    | _ => case Susp.peek r2
  17.118 +       of SOME [] => (true, r1)
  17.119 +        | _ => (apsnd (Susp.delay o K)) (merge_thms (Susp.force r1, Susp.force r2));
  17.120 +
  17.121 +
  17.122 +(* pairs of (selected, deleted) defining equations *)
  17.123 +
  17.124 +type sdthms = thm list Susp.T * thm list;
  17.125 +
  17.126 +fun add_drop_redundant thm (sels, dels) =
  17.127 +  let
  17.128 +    val thy = Thm.theory_of_thm thm;
  17.129 +    val args_of = snd o strip_comb o fst o Logic.dest_equals o Thm.plain_prop_of;
  17.130 +    val args = args_of thm;
  17.131 +    fun matches [] _ = true
  17.132 +      | matches (Var _ :: xs) [] = matches xs []
  17.133 +      | matches (_ :: _) [] = false
  17.134 +      | matches (x :: xs) (y :: ys) = Pattern.matches thy (x, y) andalso matches xs ys;
  17.135 +    fun drop thm' = not (matches args (args_of thm'))
  17.136 +      orelse (warning ("code generator: dropping redundant defining equation\n" ^ string_of_thm thm'); false);
  17.137 +    val (keeps, drops) = List.partition drop sels;
  17.138 +  in (thm :: keeps, dels |> remove Thm.eq_thm_prop thm |> fold (insert Thm.eq_thm_prop) drops) end;
  17.139 +
  17.140 +fun add_thm thm (sels, dels) =
  17.141 +  apfst Susp.value (add_drop_redundant thm (Susp.force sels, dels));
  17.142 +
  17.143 +fun add_lthms lthms (sels, []) =
  17.144 +      (Susp.delay (fn () => fold add_drop_redundant
  17.145 +        (Susp.force lthms) (Susp.force sels, []) |> fst), [])
  17.146 +        (*FIXME*)
  17.147 +  | add_lthms lthms (sels, dels) =
  17.148 +      fold add_thm (Susp.force lthms) (sels, dels);
  17.149 +
  17.150 +fun del_thm thm (sels, dels) =
  17.151 +  (Susp.value (remove Thm.eq_thm_prop thm (Susp.force sels)), thm :: dels);
  17.152 +
  17.153 +fun pretty_sdthms ctxt (sels, _) = pretty_lthms ctxt sels;
  17.154 +
  17.155 +fun merge_sdthms ((sels1, dels1), (sels2, dels2)) =
  17.156 +  let
  17.157 +    val (dels_t, dels) = merge_thms (dels1, dels2);
  17.158 +  in if dels_t
  17.159 +    then let
  17.160 +      val (_, sels) = merge_thms
  17.161 +        (subtract Thm.eq_thm_prop dels2 (Susp.force sels1), Susp.force sels2);
  17.162 +      val (_, dels) = merge_thms
  17.163 +        (subtract Thm.eq_thm_prop (Susp.force sels2) dels1, dels2);
  17.164 +    in (true, ((Susp.delay o K) sels, dels)) end
  17.165 +    else let
  17.166 +      val (sels_t, sels) = merge_lthms (sels1, sels2);
  17.167 +    in (sels_t, (sels, dels)) end
  17.168 +  end;
  17.169 +
  17.170 +
  17.171 +(* code attributes *)
  17.172 +
  17.173 +structure CodeAttr = TheoryDataFun (
  17.174 +  type T = (string * (Args.T list -> attribute * Args.T list)) list;
  17.175 +  val empty = [];
  17.176 +  val copy = I;
  17.177 +  val extend = I;
  17.178 +  fun merge _ = AList.merge (op =) (K true);
  17.179 +);
  17.180 +
  17.181 +fun add_attribute (attr as (name, _)) =
  17.182 +  let
  17.183 +    fun add_parser ("", parser) attrs = attrs @ [("", parser)]
  17.184 +      | add_parser (name, parser) attrs = (name, Args.$$$ name |-- parser) :: attrs;
  17.185 +    fun error "" = error ("Code attribute already declared")
  17.186 +      | error name = error ("Code attribute " ^ name ^ " already declared")
  17.187 +  in CodeAttr.map (fn attrs => if AList.defined (op =) attrs name
  17.188 +    then error name else add_parser attr attrs)
  17.189 +  end;
  17.190 +
  17.191 +val _ =
  17.192 +  let
  17.193 +    val code_attr = Attrib.syntax (Scan.peek (fn context =>
  17.194 +      List.foldr op || Scan.fail (map snd (CodeAttr.get (Context.theory_of context)))));
  17.195 +  in
  17.196 +    Context.add_setup (Attrib.add_attributes
  17.197 +      [("code", code_attr, "declare theorems for code generation")])
  17.198 +  end;
  17.199 +
  17.200 +
  17.201 +
  17.202 +(** exeuctable content **)
  17.203 +
  17.204 +datatype thmproc = Preproc of {
  17.205 +  inlines: thm list,
  17.206 +  inline_procs: (string * (serial * (theory -> cterm list -> thm list))) list,
  17.207 +  preprocs: (string * (serial * (theory -> thm list -> thm list))) list,
  17.208 +  posts: thm list
  17.209 +};
  17.210 +
  17.211 +fun mk_thmproc (((inlines, inline_procs), preprocs), posts) =
  17.212 +  Preproc { inlines = inlines, inline_procs = inline_procs, preprocs = preprocs,
  17.213 +    posts = posts };
  17.214 +fun map_thmproc f (Preproc { inlines, inline_procs, preprocs, posts }) =
  17.215 +  mk_thmproc (f (((inlines, inline_procs), preprocs), posts));
  17.216 +fun merge_thmproc (Preproc { inlines = inlines1, inline_procs = inline_procs1,
  17.217 +    preprocs = preprocs1, posts = posts1 },
  17.218 +  Preproc { inlines = inlines2, inline_procs = inline_procs2,
  17.219 +      preprocs = preprocs2, posts= posts2 }) =
  17.220 +    let
  17.221 +      val (touched1, inlines) = merge_thms (inlines1, inlines2);
  17.222 +      val (touched2, inline_procs) = merge_alist (op =) (eq_fst (op =)) (inline_procs1, inline_procs2);
  17.223 +      val (touched3, preprocs) = merge_alist (op =) (eq_fst (op =)) (preprocs1, preprocs2);
  17.224 +      val (_, posts) = merge_thms (posts1, posts2);
  17.225 +    in (touched1 orelse touched2 orelse touched3,
  17.226 +      mk_thmproc (((inlines, inline_procs), preprocs), posts)) end;
  17.227 +
  17.228 +fun join_func_thms (tabs as (tab1, tab2)) =
  17.229 +  let
  17.230 +    val cs1 = Consttab.keys tab1;
  17.231 +    val cs2 = Consttab.keys tab2;
  17.232 +    val cs' = filter (member CodeUnit.eq_const cs2) cs1;
  17.233 +    val cs'' = subtract (op =) cs' cs1 @ subtract (op =) cs' cs2;
  17.234 +    val cs''' = ref [] : CodeUnit.const list ref;
  17.235 +    fun merge c x = let val (touched, thms') = merge_sdthms x in
  17.236 +      (if touched then cs''' := cons c (!cs''') else (); thms') end;
  17.237 +  in (cs'' @ !cs''', Consttab.join merge tabs) end;
  17.238 +fun merge_funcs (thms1, thms2) =
  17.239 +  let
  17.240 +    val (consts, thms) = join_func_thms (thms1, thms2);
  17.241 +  in (SOME consts, thms) end;
  17.242 +
  17.243 +val eq_string = op = : string * string -> bool;
  17.244 +val eq_co = op = : (string * typ list) * (string * typ list) -> bool;
  17.245 +fun eq_dtyp ((vs1, cs1), (vs2, cs2)) = 
  17.246 +  gen_eq_set (eq_pair eq_string (gen_eq_set eq_string)) (vs1, vs2)
  17.247 +    andalso gen_eq_set eq_co (cs1, cs2);
  17.248 +fun merge_dtyps (tabs as (tab1, tab2)) =
  17.249 +  let
  17.250 +    val tycos1 = Symtab.keys tab1;
  17.251 +    val tycos2 = Symtab.keys tab2;
  17.252 +    val tycos' = filter (member eq_string tycos2) tycos1;
  17.253 +    val new_types = not (gen_eq_set (op =) (tycos1, tycos2));
  17.254 +    val diff_types = not (gen_eq_set (eq_pair (op =) eq_dtyp)
  17.255 +      (AList.make (the o Symtab.lookup tab1) tycos',
  17.256 +       AList.make (the o Symtab.lookup tab2) tycos'));
  17.257 +    fun join _ (cos as (_, cos2)) = if eq_dtyp cos
  17.258 +      then raise Symtab.SAME else cos2;
  17.259 +  in ((new_types, diff_types), Symtab.join join tabs) end;
  17.260 +
  17.261 +datatype spec = Spec of {
  17.262 +  funcs: sdthms Consttab.table,
  17.263 +  dtyps: ((string * sort) list * (string * typ list) list) Symtab.table
  17.264 +};
  17.265 +
  17.266 +fun mk_spec (funcs, dtyps) =
  17.267 +  Spec { funcs = funcs, dtyps = dtyps };
  17.268 +fun map_spec f (Spec { funcs = funcs, dtyps = dtyps }) =
  17.269 +  mk_spec (f (funcs, dtyps));
  17.270 +fun merge_spec (Spec { funcs = funcs1, dtyps = dtyps1 },
  17.271 +  Spec { funcs = funcs2, dtyps = dtyps2 }) =
  17.272 +  let
  17.273 +    val (touched_cs, funcs) = merge_funcs (funcs1, funcs2);
  17.274 +    val ((new_types, diff_types), dtyps) = merge_dtyps (dtyps1, dtyps2);
  17.275 +    val touched = if new_types orelse diff_types then NONE else touched_cs;
  17.276 +  in (touched, mk_spec (funcs, dtyps)) end;
  17.277 +
  17.278 +datatype exec = Exec of {
  17.279 +  thmproc: thmproc,
  17.280 +  spec: spec
  17.281 +};
  17.282 +
  17.283 +fun mk_exec (thmproc, spec) =
  17.284 +  Exec { thmproc = thmproc, spec = spec };
  17.285 +fun map_exec f (Exec { thmproc = thmproc, spec = spec }) =
  17.286 +  mk_exec (f (thmproc, spec));
  17.287 +fun merge_exec (Exec { thmproc = thmproc1, spec = spec1 },
  17.288 +  Exec { thmproc = thmproc2, spec = spec2 }) =
  17.289 +  let
  17.290 +    val (touched', thmproc) = merge_thmproc (thmproc1, thmproc2);
  17.291 +    val (touched_cs, spec) = merge_spec (spec1, spec2);
  17.292 +    val touched = if touched' then NONE else touched_cs;
  17.293 +  in (touched, mk_exec (thmproc, spec)) end;
  17.294 +val empty_exec = mk_exec (mk_thmproc ((([], []), []), []),
  17.295 +  mk_spec (Consttab.empty, Symtab.empty));
  17.296 +
  17.297 +fun the_thmproc (Exec { thmproc = Preproc x, ...}) = x;
  17.298 +fun the_spec (Exec { spec = Spec x, ...}) = x;
  17.299 +val the_funcs = #funcs o the_spec;
  17.300 +val the_dtyps = #dtyps o the_spec;
  17.301 +val map_thmproc = map_exec o apfst o map_thmproc;
  17.302 +val map_funcs = map_exec o apsnd o map_spec o apfst;
  17.303 +val map_dtyps = map_exec o apsnd o map_spec o apsnd;
  17.304 +
  17.305 +
  17.306 +(* data slots dependent on executable content *)
  17.307 +
  17.308 +(*private copy avoids potential conflict of table exceptions*)
  17.309 +structure Datatab = TableFun(type key = int val ord = int_ord);
  17.310 +
  17.311 +local
  17.312 +
  17.313 +type kind = {
  17.314 +  empty: Object.T,
  17.315 +  merge: Pretty.pp -> Object.T * Object.T -> Object.T,
  17.316 +  purge: theory option -> CodeUnit.const list option -> Object.T -> Object.T
  17.317 +};
  17.318 +
  17.319 +val kinds = ref (Datatab.empty: kind Datatab.table);
  17.320 +val kind_keys = ref ([]: serial list);
  17.321 +
  17.322 +fun invoke f k = case Datatab.lookup (! kinds) k
  17.323 + of SOME kind => f kind
  17.324 +  | NONE => sys_error "Invalid code data identifier";
  17.325 +
  17.326 +in
  17.327 +
  17.328 +fun declare_data empty merge purge =
  17.329 +  let
  17.330 +    val k = serial ();
  17.331 +    val kind = {empty = empty, merge = merge, purge = purge};
  17.332 +    val _ = change kinds (Datatab.update (k, kind));
  17.333 +    val _ = change kind_keys (cons k);
  17.334 +  in k end;
  17.335 +
  17.336 +fun invoke_empty k = invoke (fn kind => #empty kind) k;
  17.337 +
  17.338 +fun invoke_merge_all pp = Datatab.join
  17.339 +  (invoke (fn kind => #merge kind pp));
  17.340 +
  17.341 +fun invoke_purge_all thy_opt cs =
  17.342 +  fold (fn k => Datatab.map_entry k
  17.343 +    (invoke (fn kind => #purge kind thy_opt cs) k)) (! kind_keys);
  17.344 +
  17.345 +end; (*local*)
  17.346 +
  17.347 +
  17.348 +(* theory store *)
  17.349 +
  17.350 +local
  17.351 +
  17.352 +type data = Object.T Datatab.table;
  17.353 +
  17.354 +structure CodeData = TheoryDataFun
  17.355 +(
  17.356 +  type T = exec * data ref;
  17.357 +  val empty = (empty_exec, ref Datatab.empty : data ref);
  17.358 +  fun copy (exec, data) = (exec, ref (! data));
  17.359 +  val extend = copy;
  17.360 +  fun merge pp ((exec1, data1), (exec2, data2)) =
  17.361 +    let
  17.362 +      val (touched, exec) = merge_exec (exec1, exec2);
  17.363 +      val data1' = invoke_purge_all NONE touched (! data1);
  17.364 +      val data2' = invoke_purge_all NONE touched (! data2);
  17.365 +      val data = invoke_merge_all pp (data1', data2');
  17.366 +    in (exec, ref data) end;
  17.367 +);
  17.368 +
  17.369 +val _ = Context.add_setup CodeData.init;
  17.370 +
  17.371 +fun ch r f = let val x = f (! r) in (r := x; x) end;
  17.372 +fun thy_data f thy = f ((snd o CodeData.get) thy);
  17.373 +
  17.374 +fun get_ensure_init kind data_ref =
  17.375 +  case Datatab.lookup (! data_ref) kind
  17.376 +   of SOME x => x
  17.377 +    | NONE => let val y = invoke_empty kind
  17.378 +        in (change data_ref (Datatab.update (kind, y)); y) end;
  17.379 +
  17.380 +in
  17.381 +
  17.382 +(* access to executable content *)
  17.383 +
  17.384 +val get_exec = fst o CodeData.get;
  17.385 +
  17.386 +fun map_exec_purge touched f thy =
  17.387 +  CodeData.map (fn (exec, data) => 
  17.388 +    (f exec, ref (invoke_purge_all (SOME thy) touched (! data)))) thy;
  17.389 +
  17.390 +
  17.391 +(* access to data dependent on abstract executable content *)
  17.392 +
  17.393 +fun get_data (kind, _, dest) = thy_data (get_ensure_init kind #> dest);
  17.394 +
  17.395 +fun change_data (kind, mk, dest) =
  17.396 +  let
  17.397 +    fun chnge data_ref f =
  17.398 +      let
  17.399 +        val data = get_ensure_init kind data_ref;
  17.400 +        val data' = f (dest data);
  17.401 +      in (change data_ref (Datatab.update (kind, mk data')); data') end;
  17.402 +  in thy_data chnge end;
  17.403 +
  17.404 +fun change_yield_data (kind, mk, dest) =
  17.405 +  let
  17.406 +    fun chnge data_ref f =
  17.407 +      let
  17.408 +        val data = get_ensure_init kind data_ref;
  17.409 +        val (x, data') = f (dest data);
  17.410 +      in (x, (change data_ref (Datatab.update (kind, mk data')); data')) end;
  17.411 +  in thy_data chnge end;
  17.412 +
  17.413 +end; (*local*)
  17.414 +
  17.415 +
  17.416 +(* print executable content *)
  17.417 +
  17.418 +fun print_codesetup thy =
  17.419 +  let
  17.420 +    val ctxt = ProofContext.init thy;
  17.421 +    val exec = get_exec thy;
  17.422 +    fun pretty_func (s, lthms) =
  17.423 +      (Pretty.block o Pretty.fbreaks) (
  17.424 +        Pretty.str s :: pretty_sdthms ctxt lthms
  17.425 +      );
  17.426 +    fun pretty_dtyp (s, []) =
  17.427 +          Pretty.str s
  17.428 +      | pretty_dtyp (s, cos) =
  17.429 +          (Pretty.block o Pretty.breaks) (
  17.430 +            Pretty.str s
  17.431 +            :: Pretty.str "="
  17.432 +            :: separate (Pretty.str "|") (map (fn (c, []) => Pretty.str c
  17.433 +                 | (c, tys) =>
  17.434 +                     (Pretty.block o Pretty.breaks)
  17.435 +                        (Pretty.str c :: Pretty.str "of" :: map (Pretty.quote o Sign.pretty_typ thy) tys)) cos)
  17.436 +          );
  17.437 +    val inlines = (#inlines o the_thmproc) exec;
  17.438 +    val inline_procs = (map fst o #inline_procs o the_thmproc) exec;
  17.439 +    val preprocs = (map fst o #preprocs o the_thmproc) exec;
  17.440 +    val funs = the_funcs exec
  17.441 +      |> Consttab.dest
  17.442 +      |> (map o apfst) (CodeUnit.string_of_const thy)
  17.443 +      |> sort (string_ord o pairself fst);
  17.444 +    val dtyps = the_dtyps exec
  17.445 +      |> Symtab.dest
  17.446 +      |> map (fn (dtco, (vs, cos)) => (Sign.string_of_typ thy (Type (dtco, map TFree vs)), cos))
  17.447 +      |> sort (string_ord o pairself fst)
  17.448 +  in
  17.449 +    (Pretty.writeln o Pretty.chunks) [
  17.450 +      Pretty.block (
  17.451 +        Pretty.str "defining equations:"
  17.452 +        :: Pretty.fbrk
  17.453 +        :: (Pretty.fbreaks o map pretty_func) funs
  17.454 +      ),
  17.455 +      Pretty.block (
  17.456 +        Pretty.str "inlining theorems:"
  17.457 +        :: Pretty.fbrk
  17.458 +        :: (Pretty.fbreaks o map (ProofContext.pretty_thm ctxt)) inlines
  17.459 +      ),
  17.460 +      Pretty.block (
  17.461 +        Pretty.str "inlining procedures:"
  17.462 +        :: Pretty.fbrk
  17.463 +        :: (Pretty.fbreaks o map Pretty.str) inline_procs
  17.464 +      ),
  17.465 +      Pretty.block (
  17.466 +        Pretty.str "preprocessors:"
  17.467 +        :: Pretty.fbrk
  17.468 +        :: (Pretty.fbreaks o map Pretty.str) preprocs
  17.469 +      ),
  17.470 +      Pretty.block (
  17.471 +        Pretty.str "datatypes:"
  17.472 +        :: Pretty.fbrk
  17.473 +        :: (Pretty.fbreaks o map pretty_dtyp) dtyps
  17.474 +      )
  17.475 +    ]
  17.476 +  end;
  17.477 +
  17.478 +
  17.479 +
  17.480 +(** theorem transformation and certification **)
  17.481 +
  17.482 +fun common_typ_funcs [] = []
  17.483 +  | common_typ_funcs [thm] = [thm]
  17.484 +  | common_typ_funcs (thms as thm :: _) =
  17.485 +      let
  17.486 +        val thy = Thm.theory_of_thm thm;
  17.487 +        fun incr_thm thm max =
  17.488 +          let
  17.489 +            val thm' = incr_indexes max thm;
  17.490 +            val max' = Thm.maxidx_of thm' + 1;
  17.491 +          in (thm', max') end;
  17.492 +        val (thms', maxidx) = fold_map incr_thm thms 0;
  17.493 +        val ty1 :: tys = map (snd o CodeUnit.head_func) thms';
  17.494 +        fun unify ty env = Sign.typ_unify thy (ty1, ty) env
  17.495 +          handle Type.TUNIFY =>
  17.496 +            error ("Type unificaton failed, while unifying defining equations\n"
  17.497 +            ^ (cat_lines o map Display.string_of_thm) thms
  17.498 +            ^ "\nwith types\n"
  17.499 +            ^ (cat_lines o map (CodeUnit.string_of_typ thy)) (ty1 :: tys));
  17.500 +        val (env, _) = fold unify tys (Vartab.empty, maxidx)
  17.501 +        val instT = Vartab.fold (fn (x_i, (sort, ty)) =>
  17.502 +          cons (Thm.ctyp_of thy (TVar (x_i, sort)), Thm.ctyp_of thy ty)) env [];
  17.503 +      in map (Thm.instantiate (instT, [])) thms' end;
  17.504 +
  17.505 +fun certify_const thy const thms =
  17.506 +  let
  17.507 +    fun cert thm = if CodeUnit.eq_const (const, fst (CodeUnit.head_func thm))
  17.508 +      then thm else error ("Wrong head of defining equation,\nexpected constant "
  17.509 +        ^ CodeUnit.string_of_const thy const ^ "\n" ^ string_of_thm thm)
  17.510 +  in map cert thms end;
  17.511 +
  17.512 +
  17.513 +
  17.514 +(** operational sort algebra and class discipline **)
  17.515 +
  17.516 +local
  17.517 +
  17.518 +fun aggr_neutr f y [] = y
  17.519 +  | aggr_neutr f y (x::xs) = aggr_neutr f (f y x) xs;
  17.520 +
  17.521 +fun aggregate f [] = NONE
  17.522 +  | aggregate f (x::xs) = SOME (aggr_neutr f x xs);
  17.523 +
  17.524 +fun inter_sorts thy =
  17.525 +  let
  17.526 +    val algebra = Sign.classes_of thy;
  17.527 +    val inters = curry (Sorts.inter_sort algebra);
  17.528 +  in aggregate (map2 inters) end;
  17.529 +
  17.530 +fun specific_constraints thy (class, tyco) =
  17.531 +  let
  17.532 +    val vs = Name.invents Name.context "" (Sign.arity_number thy tyco);
  17.533 +    val clsops = (these o Option.map snd o try (AxClass.params_of_class thy)) class;
  17.534 +    val funcs = clsops
  17.535 +      |> map (fn (clsop, _) => (clsop, SOME tyco))
  17.536 +      |> map (Consttab.lookup ((the_funcs o get_exec) thy))
  17.537 +      |> (map o Option.map) (Susp.force o fst)
  17.538 +      |> maps these
  17.539 +      |> map (Thm.transfer thy);
  17.540 +    val sorts = map (map (snd o dest_TVar) o snd o dest_Type o the_single
  17.541 +      o Sign.const_typargs thy o (fn ((c, _), ty) => (c, ty)) o CodeUnit.head_func) funcs;
  17.542 +  in sorts end;
  17.543 +
  17.544 +fun weakest_constraints thy (class, tyco) =
  17.545 +  let
  17.546 +    val all_superclasses = class :: Graph.all_succs ((#classes o Sorts.rep_algebra o Sign.classes_of) thy) [class];
  17.547 +  in case inter_sorts thy (maps (fn class => specific_constraints thy (class, tyco)) all_superclasses)
  17.548 +   of SOME sorts => sorts
  17.549 +    | NONE => Sign.arity_sorts thy tyco [class]
  17.550 +  end;
  17.551 +
  17.552 +fun strongest_constraints thy (class, tyco) =
  17.553 +  let
  17.554 +    val algebra = Sign.classes_of thy;
  17.555 +    val all_subclasses = class :: Graph.all_preds ((#classes o Sorts.rep_algebra) algebra) [class];
  17.556 +    val inst_subclasses = filter (can (Sorts.mg_domain algebra tyco) o single) all_subclasses;
  17.557 +  in case inter_sorts thy (maps (fn class => specific_constraints thy (class, tyco)) inst_subclasses)
  17.558 +   of SOME sorts => sorts
  17.559 +    | NONE => replicate
  17.560 +        (Sign.arity_number thy tyco) (Sign.certify_sort thy (Sign.all_classes thy))
  17.561 +  end;
  17.562 +
  17.563 +fun gen_classop_typ constr thy class (c, tyco) = 
  17.564 +  let
  17.565 +    val (var, cs) = try (AxClass.params_of_class thy) class |> the_default ("'a", [])
  17.566 +    val ty = (the o AList.lookup (op =) cs) c;
  17.567 +    val sort_args = Name.names (Name.declare var Name.context) "'a"
  17.568 +      (constr thy (class, tyco));
  17.569 +    val ty_inst = Type (tyco, map TFree sort_args);
  17.570 +  in Logic.varifyT (map_type_tfree (K ty_inst) ty) end;
  17.571 +
  17.572 +fun retrieve_algebra thy operational =
  17.573 +  Sorts.subalgebra (Sign.pp thy) operational
  17.574 +    (weakest_constraints thy)
  17.575 +    (Sign.classes_of thy);
  17.576 +
  17.577 +in
  17.578 +
  17.579 +fun coregular_algebra thy = retrieve_algebra thy (K true) |> snd;
  17.580 +fun operational_algebra thy =
  17.581 +  let
  17.582 +    fun add_iff_operational class =
  17.583 +      can (AxClass.get_definition thy) class ? cons class;
  17.584 +    val operational_classes = fold add_iff_operational (Sign.all_classes thy) []
  17.585 +  in retrieve_algebra thy (member (op =) operational_classes) end;
  17.586 +
  17.587 +val classop_weakest_typ = gen_classop_typ weakest_constraints;
  17.588 +val classop_strongest_typ = gen_classop_typ strongest_constraints;
  17.589 +
  17.590 +fun assert_func_typ thm =
  17.591 +  let
  17.592 +    val thy = Thm.theory_of_thm thm;
  17.593 +    fun check_typ_classop class (const as (c, SOME tyco), thm) =
  17.594 +          let
  17.595 +            val (_, ty) = CodeUnit.head_func thm;
  17.596 +            val ty_decl = classop_weakest_typ thy class (c, tyco);
  17.597 +            val ty_strongest = classop_strongest_typ thy class (c, tyco);
  17.598 +            fun constrain thm = 
  17.599 +              let
  17.600 +                val max = Thm.maxidx_of thm + 1;
  17.601 +                val ty_decl' = Logic.incr_tvar max ty_decl;
  17.602 +                val (_, ty') = CodeUnit.head_func thm;
  17.603 +                val (env, _) = Sign.typ_unify thy (ty_decl', ty') (Vartab.empty, max);
  17.604 +                val instT = Vartab.fold (fn (x_i, (sort, ty)) =>
  17.605 +                  cons (Thm.ctyp_of thy (TVar (x_i, sort)), Thm.ctyp_of thy ty)) env [];
  17.606 +              in Thm.instantiate (instT, []) thm end;
  17.607 +          in if Sign.typ_instance thy (ty_strongest, ty)
  17.608 +            then if Sign.typ_instance thy (ty, ty_decl)
  17.609 +            then thm
  17.610 +            else (warning ("Constraining type\n" ^ CodeUnit.string_of_typ thy ty
  17.611 +              ^ "\nof defining equation\n"
  17.612 +              ^ string_of_thm thm
  17.613 +              ^ "\nto permitted most general type\n"
  17.614 +              ^ CodeUnit.string_of_typ thy ty_decl);
  17.615 +              constrain thm)
  17.616 +            else CodeUnit.bad_thm ("Type\n" ^ CodeUnit.string_of_typ thy ty
  17.617 +              ^ "\nof defining equation\n"
  17.618 +              ^ string_of_thm thm
  17.619 +              ^ "\nis incompatible with permitted least general type\n"
  17.620 +              ^ CodeUnit.string_of_typ thy ty_strongest)
  17.621 +          end
  17.622 +      | check_typ_classop class ((c, NONE), thm) =
  17.623 +          CodeUnit.bad_thm ("Illegal type for class operation " ^ quote c
  17.624 +           ^ "\nin defining equation\n"
  17.625 +           ^ string_of_thm thm);
  17.626 +    fun check_typ_fun (const as (c, _), thm) =
  17.627 +      let
  17.628 +        val (_, ty) = CodeUnit.head_func thm;
  17.629 +        val ty_decl = Sign.the_const_type thy c;
  17.630 +      in if Sign.typ_equiv thy (Type.strip_sorts ty_decl, Type.strip_sorts ty)
  17.631 +        then thm
  17.632 +        else CodeUnit.bad_thm ("Type\n" ^ CodeUnit.string_of_typ thy ty
  17.633 +           ^ "\nof defining equation\n"
  17.634 +           ^ string_of_thm thm
  17.635 +           ^ "\nis incompatible with declared function type\n"
  17.636 +           ^ CodeUnit.string_of_typ thy ty_decl)
  17.637 +      end;
  17.638 +    fun check_typ (const as (c, _), thm) =
  17.639 +      case AxClass.class_of_param thy c
  17.640 +       of SOME class => check_typ_classop class (const, thm)
  17.641 +        | NONE => check_typ_fun (const, thm);
  17.642 +  in check_typ (fst (CodeUnit.head_func thm), thm) end;
  17.643 +
  17.644 +val mk_func = CodeUnit.error_thm
  17.645 +  (assert_func_typ o CodeUnit.mk_func);
  17.646 +val mk_func_liberal = CodeUnit.warning_thm
  17.647 +  (assert_func_typ o CodeUnit.mk_func);
  17.648 +
  17.649 +end;
  17.650 +
  17.651 +
  17.652 +
  17.653 +(** interfaces and attributes **)
  17.654 +
  17.655 +fun add_func true thm thy =
  17.656 +      let
  17.657 +        val func = mk_func thm;
  17.658 +        val (const, _) = CodeUnit.head_func func;
  17.659 +      in map_exec_purge (SOME [const]) (map_funcs
  17.660 +        (Consttab.map_default
  17.661 +          (const, (Susp.value [], [])) (add_thm func))) thy
  17.662 +      end
  17.663 +  | add_func false thm thy =
  17.664 +      case mk_func_liberal thm
  17.665 +       of SOME func => let
  17.666 +              val (const, _) = CodeUnit.head_func func
  17.667 +            in map_exec_purge (SOME [const]) (map_funcs
  17.668 +              (Consttab.map_default
  17.669 +                (const, (Susp.value [], [])) (add_thm func))) thy
  17.670 +            end
  17.671 +        | NONE => thy;
  17.672 +
  17.673 +fun delete_force msg key xs =
  17.674 +  if AList.defined (op =) xs key then AList.delete (op =) key xs
  17.675 +  else error ("No such " ^ msg ^ ": " ^ quote key);
  17.676 +
  17.677 +fun del_func thm thy =
  17.678 +  let
  17.679 +    val func = mk_func thm;
  17.680 +    val (const, _) = CodeUnit.head_func func;
  17.681 +  in map_exec_purge (SOME [const]) (map_funcs
  17.682 +    (Consttab.map_entry
  17.683 +      const (del_thm func))) thy
  17.684 +  end;
  17.685 +
  17.686 +fun add_funcl (const, lthms) thy =
  17.687 +  let
  17.688 +    val lthms' = certificate thy (fn thy => certify_const thy const) lthms;
  17.689 +      (*FIXME must check compatibility with sort algebra;
  17.690 +        alas, naive checking results in non-termination!*)
  17.691 +  in
  17.692 +    map_exec_purge (SOME [const]) (map_funcs (Consttab.map_default (const, (Susp.value [], []))
  17.693 +      (add_lthms lthms'))) thy
  17.694 +  end;
  17.695 +
  17.696 +fun add_func_attr strict = Attrib.internal (fn _ => Thm.declaration_attribute
  17.697 +  (fn thm => Context.mapping (add_func strict thm) I));
  17.698 +
  17.699 +local
  17.700 +
  17.701 +fun del_datatype tyco thy =
  17.702 +  case Symtab.lookup ((the_dtyps o get_exec) thy) tyco
  17.703 +   of SOME (vs, cos) => let
  17.704 +        val consts = CodeUnit.consts_of_cos thy tyco vs cos;
  17.705 +      in map_exec_purge (if null consts then NONE else SOME consts)
  17.706 +        (map_dtyps (Symtab.delete tyco)) thy end
  17.707 +    | NONE => thy;
  17.708 +
  17.709 +in
  17.710 +
  17.711 +fun add_datatype (tyco, (vs_cos as (vs, cos))) thy =
  17.712 +  let
  17.713 +    val consts = CodeUnit.consts_of_cos thy tyco vs cos;
  17.714 +  in
  17.715 +    thy
  17.716 +    |> del_datatype tyco
  17.717 +    |> map_exec_purge (SOME consts) (map_dtyps (Symtab.update_new (tyco, vs_cos)))
  17.718 +  end;
  17.719 +
  17.720 +fun add_datatype_consts consts thy =
  17.721 +  add_datatype (CodeUnit.cos_of_consts thy consts) thy;
  17.722 +
  17.723 +fun add_datatype_consts_cmd raw_cs thy =
  17.724 +  add_datatype_consts (map (CodeUnit.read_const thy) raw_cs) thy
  17.725 +
  17.726 +end; (*local*)
  17.727 +
  17.728 +fun add_inline thm thy =
  17.729 +  (map_exec_purge NONE o map_thmproc o apfst o apfst o apfst)
  17.730 +    (insert Thm.eq_thm_prop (CodeUnit.error_thm CodeUnit.mk_rew thm)) thy;
  17.731 +        (*fully applied in order to get right context for mk_rew!*)
  17.732 +
  17.733 +fun del_inline thm thy =
  17.734 +  (map_exec_purge NONE o map_thmproc o apfst o apfst o apfst)
  17.735 +    (remove Thm.eq_thm_prop (CodeUnit.error_thm CodeUnit.mk_rew thm)) thy;
  17.736 +        (*fully applied in order to get right context for mk_rew!*)
  17.737 +
  17.738 +fun add_inline_proc (name, f) =
  17.739 +  (map_exec_purge NONE o map_thmproc o apfst o apfst o apsnd)
  17.740 +    (AList.update (op =) (name, (serial (), f)));
  17.741 +
  17.742 +fun del_inline_proc name =
  17.743 +  (map_exec_purge NONE o map_thmproc o apfst o apfst o apsnd)
  17.744 +    (delete_force "inline procedure" name);
  17.745 +
  17.746 +fun add_preproc (name, f) =
  17.747 +  (map_exec_purge NONE o map_thmproc o apfst o apsnd)
  17.748 +    (AList.update (op =) (name, (serial (), f)));
  17.749 +
  17.750 +fun del_preproc name =
  17.751 +  (map_exec_purge NONE o map_thmproc o apfst o apsnd)
  17.752 +    (delete_force "preprocessor" name);
  17.753 +
  17.754 +fun add_post thm thy =
  17.755 +  (map_exec_purge NONE o map_thmproc o apsnd)
  17.756 +    (insert Thm.eq_thm_prop (CodeUnit.error_thm CodeUnit.mk_rew thm)) thy;
  17.757 +        (*fully applied in order to get right context for mk_rew!*)
  17.758 +
  17.759 +fun del_post thm thy =
  17.760 +  (map_exec_purge NONE o map_thmproc o apsnd)
  17.761 +    (remove Thm.eq_thm_prop (CodeUnit.error_thm CodeUnit.mk_rew thm)) thy;
  17.762 +        (*fully applied in order to get right context for mk_rew!*)
  17.763 +
  17.764 +val _ = Context.add_setup
  17.765 +  (let
  17.766 +    fun mk_attribute f = Thm.declaration_attribute (fn thm => Context.mapping (f thm) I);
  17.767 +    fun add_simple_attribute (name, f) =
  17.768 +      add_attribute (name, Scan.succeed (mk_attribute f));
  17.769 +    fun add_del_attribute (name, (add, del)) =
  17.770 +      add_attribute (name, Args.del |-- Scan.succeed (mk_attribute del)
  17.771 +        || Scan.succeed (mk_attribute add))
  17.772 +  in
  17.773 +    add_del_attribute ("func", (add_func true, del_func))
  17.774 +    #> add_del_attribute ("inline", (add_inline, del_inline))
  17.775 +    #> add_del_attribute ("post", (add_post, del_post))
  17.776 +  end);
  17.777 +
  17.778 +
  17.779 +(** post- and preprocessing **)
  17.780 +
  17.781 +local
  17.782 +
  17.783 +fun gen_apply_inline_proc prep post thy f x =
  17.784 +  let
  17.785 +    val cts = prep x;
  17.786 +    val rews = map CodeUnit.assert_rew (f thy cts);
  17.787 +  in post rews x end;
  17.788 +
  17.789 +val apply_inline_proc = gen_apply_inline_proc (maps
  17.790 +  ((fn [args, rhs] => rhs :: (snd o Drule.strip_comb) args) o snd o Drule.strip_comb o Thm.cprop_of))
  17.791 +  (fn rews => map (CodeUnit.rewrite_func rews));
  17.792 +val apply_inline_proc_cterm = gen_apply_inline_proc single
  17.793 +  (MetaSimplifier.rewrite false);
  17.794 +
  17.795 +fun apply_preproc thy f [] = []
  17.796 +  | apply_preproc thy f (thms as (thm :: _)) =
  17.797 +      let
  17.798 +        val (const, _) = CodeUnit.head_func thm;
  17.799 +        val thms' = f thy thms;
  17.800 +      in certify_const thy const thms' end;
  17.801 +
  17.802 +fun rhs_conv conv thm =
  17.803 +  let
  17.804 +    val thm' = (conv o Thm.rhs_of) thm;
  17.805 +  in Thm.transitive thm thm' end
  17.806 +
  17.807 +in
  17.808 +
  17.809 +fun preprocess thy thms =
  17.810 +  thms
  17.811 +  |> fold (fn (_, (_, f)) => apply_preproc thy f) ((#preprocs o the_thmproc o get_exec) thy)
  17.812 +  |> map (CodeUnit.rewrite_func ((#inlines o the_thmproc o get_exec) thy))
  17.813 +  |> fold (fn (_, (_, f)) => apply_inline_proc thy f) ((#inline_procs o the_thmproc o get_exec) thy)
  17.814 +(*FIXME - must check: rewrite rule, defining equation, proper constant |> map (snd o check_func false thy) *)
  17.815 +  |> common_typ_funcs;
  17.816 +
  17.817 +fun preprocess_conv ct =
  17.818 +  let
  17.819 +    val thy = Thm.theory_of_cterm ct;
  17.820 +  in
  17.821 +    ct
  17.822 +    |> MetaSimplifier.rewrite false ((#inlines o the_thmproc o get_exec) thy)
  17.823 +    |> fold (fn (_, (_, f)) => rhs_conv (apply_inline_proc_cterm thy f))
  17.824 +        ((#inline_procs o the_thmproc o get_exec) thy)
  17.825 +  end;
  17.826 +
  17.827 +fun postprocess_conv ct =
  17.828 +  let
  17.829 +    val thy = Thm.theory_of_cterm ct;
  17.830 +  in
  17.831 +    ct
  17.832 +    |> MetaSimplifier.rewrite false ((#posts o the_thmproc o get_exec) thy)
  17.833 +  end;
  17.834 +
  17.835 +end; (*local*)
  17.836 +
  17.837 +fun get_datatype thy tyco =
  17.838 +  case Symtab.lookup ((the_dtyps o get_exec) thy) tyco
  17.839 +   of SOME spec => spec
  17.840 +    | NONE => Sign.arity_number thy tyco
  17.841 +        |> Name.invents Name.context "'a"
  17.842 +        |> map (rpair [])
  17.843 +        |> rpair [];
  17.844 +
  17.845 +fun get_datatype_of_constr thy const =
  17.846 +  case CodeUnit.co_of_const' thy const
  17.847 +   of SOME (tyco, (_, co)) => if member eq_co
  17.848 +        (Symtab.lookup (((the_dtyps o get_exec) thy)) tyco
  17.849 +          |> Option.map snd
  17.850 +          |> the_default []) co then SOME tyco else NONE
  17.851 +    | NONE => NONE;
  17.852 +
  17.853 +fun get_constr_typ thy const =
  17.854 +  case get_datatype_of_constr thy const
  17.855 +   of SOME tyco => let
  17.856 +        val (vs, cos) = get_datatype thy tyco;
  17.857 +        val (_, (_, (co, tys))) = CodeUnit.co_of_const thy const
  17.858 +      in (tys ---> Type (tyco, map TFree vs))
  17.859 +        |> map_atyps (fn TFree (v, _) => TFree (v, AList.lookup (op =) vs v |> the))
  17.860 +        |> Logic.varifyT
  17.861 +        |> SOME end
  17.862 +    | NONE => NONE;
  17.863 +
  17.864 +fun default_typ_proto thy (const as (c, SOME tyco)) = classop_weakest_typ thy
  17.865 +      ((the o AxClass.class_of_param thy) c) (c, tyco) |> SOME
  17.866 +  | default_typ_proto thy (const as (c, NONE)) = case AxClass.class_of_param thy c
  17.867 +       of SOME class => SOME (Term.map_type_tvar
  17.868 +            (K (TVar (("'a", 0), [class]))) (Sign.the_const_type thy c))
  17.869 +        | NONE => get_constr_typ thy const;
  17.870 +
  17.871 +local
  17.872 +
  17.873 +fun get_funcs thy const =
  17.874 +  Consttab.lookup ((the_funcs o get_exec) thy) const
  17.875 +  |> Option.map (Susp.force o fst)
  17.876 +  |> these
  17.877 +  |> map (Thm.transfer thy);
  17.878 +
  17.879 +in
  17.880 +
  17.881 +fun these_funcs thy const =
  17.882 +  let
  17.883 +    fun drop_refl thy = filter_out (is_equal o Term.fast_term_ord o Logic.dest_equals
  17.884 +      o ObjectLogic.drop_judgment thy o Thm.plain_prop_of);
  17.885 +  in
  17.886 +    get_funcs thy const
  17.887 +    |> preprocess thy
  17.888 +    |> drop_refl thy
  17.889 +  end;
  17.890 +
  17.891 +fun default_typ thy (const as (c, _)) = case default_typ_proto thy const
  17.892 + of SOME ty => ty
  17.893 +  | NONE => (case get_funcs thy const
  17.894 +     of thm :: _ => snd (CodeUnit.head_func thm)
  17.895 +      | [] => Sign.the_const_type thy c);
  17.896 +
  17.897 +end; (*local*)
  17.898 +
  17.899 +end; (*struct*)
  17.900 +
  17.901 +
  17.902 +(** type-safe interfaces for data depedent on executable content **)
  17.903 +
  17.904 +functor CodeDataFun(Data: CODE_DATA_ARGS): CODE_DATA =
  17.905 +struct
  17.906 +
  17.907 +type T = Data.T;
  17.908 +exception Data of T;
  17.909 +fun dest (Data x) = x
  17.910 +
  17.911 +val kind = Code.declare_data (Data Data.empty)
  17.912 +  (fn pp => fn (Data x1, Data x2) => Data (Data.merge pp (x1, x2)))
  17.913 +  (fn thy_opt => fn cs => fn Data x => Data (Data.purge thy_opt cs x));
  17.914 +
  17.915 +val data_op = (kind, Data, dest);
  17.916 +
  17.917 +val get = Code.get_data data_op;
  17.918 +val change = Code.change_data data_op;
  17.919 +fun change_yield thy = Code.change_yield_data data_op thy;
  17.920 +
  17.921 +end;
  17.922 +
  17.923 +structure Code : CODE =
  17.924 +struct
  17.925 +
  17.926 +open Code;
  17.927 +
  17.928 +end;
    18.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
    18.2 +++ b/src/Pure/Isar/code_unit.ML	Fri Aug 10 17:04:34 2007 +0200
    18.3 @@ -0,0 +1,461 @@
    18.4 +(*  Title:      Pure/Isar/code_unit.ML
    18.5 +    ID:         $Id$
    18.6 +    Author:     Florian Haftmann, TU Muenchen
    18.7 +
    18.8 +Basic units of code generation:  Identifying (possibly overloaded) constants
    18.9 +by name plus optional type constructor.  Convenient data structures for constants.
   18.10 +Defining equations ("func"s).  Auxiliary.
   18.11 +*)
   18.12 +
   18.13 +signature CODE_UNIT =
   18.14 +sig
   18.15 +  type const = string * string option (*constant name, possibly instance*)
   18.16 +  val const_ord: const * const -> order
   18.17 +  val eq_const: const * const -> bool
   18.18 +  structure Consttab: TABLE
   18.19 +  val const_of_cexpr: theory -> string * typ -> const
   18.20 +  val string_of_typ: theory -> typ -> string
   18.21 +  val string_of_const: theory -> const -> string
   18.22 +  val read_bare_const: theory -> string -> string * typ
   18.23 +  val read_const: theory -> string -> const
   18.24 +  val read_const_exprs: theory -> (const list -> const list)
   18.25 +    -> string list -> bool * const list
   18.26 +
   18.27 +  val co_of_const: theory -> const
   18.28 +    -> string * ((string * sort) list * (string * typ list))
   18.29 +  val co_of_const': theory -> const
   18.30 +    -> (string * ((string * sort) list * (string * typ list))) option
   18.31 +  val cos_of_consts: theory -> const list
   18.32 +    -> string * ((string * sort) list * (string * typ list) list)
   18.33 +  val const_of_co: theory -> string -> (string * sort) list
   18.34 +    -> string * typ list -> const
   18.35 +  val consts_of_cos: theory -> string -> (string * sort) list
   18.36 +    -> (string * typ list) list -> const list
   18.37 +  val no_args: theory -> const -> int
   18.38 +
   18.39 +  val typargs: theory -> string * typ -> typ list
   18.40 +  val typ_sort_inst: Sorts.algebra -> typ * sort
   18.41 +    -> sort Vartab.table -> sort Vartab.table
   18.42 +
   18.43 +  val assert_rew: thm -> thm
   18.44 +  val mk_rew: thm -> thm
   18.45 +  val mk_func: thm -> thm
   18.46 +  val head_func: thm -> const * typ
   18.47 +  val bad_thm: string -> 'a
   18.48 +  val error_thm: (thm -> thm) -> thm -> thm
   18.49 +  val warning_thm: (thm -> thm) -> thm -> thm option
   18.50 +
   18.51 +  val inst_thm: sort Vartab.table -> thm -> thm
   18.52 +  val expand_eta: int -> thm -> thm
   18.53 +  val rewrite_func: thm list -> thm -> thm
   18.54 +  val norm_args: thm list -> thm list 
   18.55 +  val norm_varnames: (string -> string) -> (string -> string) -> thm list -> thm list 
   18.56 +end;
   18.57 +
   18.58 +structure CodeUnit: CODE_UNIT =
   18.59 +struct
   18.60 +
   18.61 +
   18.62 +(* auxiliary *)
   18.63 +
   18.64 +exception BAD_THM of string;
   18.65 +fun bad_thm msg = raise BAD_THM msg;
   18.66 +fun error_thm f thm = f thm handle BAD_THM msg => error msg;
   18.67 +fun warning_thm f thm = SOME (f thm) handle BAD_THM msg
   18.68 +  => (warning ("code generator: " ^ msg); NONE);
   18.69 +
   18.70 +
   18.71 +(* basic data structures *)
   18.72 +
   18.73 +type const = string * string option;
   18.74 +val const_ord = prod_ord fast_string_ord (option_ord string_ord);
   18.75 +val eq_const = is_equal o const_ord;
   18.76 +
   18.77 +structure Consttab =
   18.78 +  TableFun(
   18.79 +    type key = const;
   18.80 +    val ord = const_ord;
   18.81 +  );
   18.82 +
   18.83 +fun string_of_typ thy = setmp show_sorts true (Sign.string_of_typ thy);
   18.84 +
   18.85 +
   18.86 +(* conversion between constant expressions and constants *)
   18.87 +
   18.88 +fun const_of_cexpr thy (c_ty as (c, _)) =
   18.89 +  case AxClass.class_of_param thy c
   18.90 +   of SOME class => (case Sign.const_typargs thy c_ty
   18.91 +       of [Type (tyco, _)] => if can (Sorts.mg_domain (Sign.classes_of thy) tyco) [class]
   18.92 +              then (c, SOME tyco)
   18.93 +              else (c, NONE)
   18.94 +        | [_] => (c, NONE))
   18.95 +    | NONE => (c, NONE);
   18.96 +
   18.97 +fun string_of_const thy (c, NONE) = Sign.extern_const thy c
   18.98 +  | string_of_const thy (c, SOME tyco) = Sign.extern_const thy c
   18.99 +      ^ " " ^ enclose "[" "]" (Sign.extern_type thy tyco);
  18.100 +
  18.101 +
  18.102 +(* reading constants as terms and wildcards pattern *)
  18.103 +
  18.104 +fun read_bare_const thy raw_t =
  18.105 +  let
  18.106 +    val t = Sign.read_term thy raw_t;
  18.107 +  in case try dest_Const t
  18.108 +   of SOME c_ty => c_ty
  18.109 +    | NONE => error ("Not a constant: " ^ Sign.string_of_term thy t)
  18.110 +  end;
  18.111 +
  18.112 +fun read_const thy = const_of_cexpr thy o read_bare_const thy;
  18.113 +
  18.114 +local
  18.115 +
  18.116 +fun consts_of thy some_thyname =
  18.117 +  let
  18.118 +    val this_thy = Option.map theory some_thyname |> the_default thy;
  18.119 +    val cs = Symtab.fold (fn (c, (_, NONE)) => cons c | _ => I)
  18.120 +      ((snd o #constants o Consts.dest o #consts o Sign.rep_sg) this_thy) [];
  18.121 +    fun classop c = case AxClass.class_of_param thy c
  18.122 +     of NONE => [(c, NONE)]
  18.123 +      | SOME class => Symtab.fold
  18.124 +          (fn (tyco, classes) => if AList.defined (op =) classes class
  18.125 +            then cons (c, SOME tyco) else I)
  18.126 +          ((#arities o Sorts.rep_algebra o Sign.classes_of) this_thy)
  18.127 +          [(c, NONE)];
  18.128 +    val consts = maps classop cs;
  18.129 +    fun test_instance thy (class, tyco) =
  18.130 +      can (Sorts.mg_domain (Sign.classes_of thy) tyco) [class]
  18.131 +    fun belongs_here thyname (c, NONE) =
  18.132 +          not (exists (fn thy' => Sign.declared_const thy' c) (Theory.parents_of this_thy))
  18.133 +      | belongs_here thyname (c, SOME tyco) =
  18.134 +          let
  18.135 +            val SOME class = AxClass.class_of_param thy c
  18.136 +          in not (exists (fn thy' => test_instance thy' (class, tyco))
  18.137 +            (Theory.parents_of this_thy))
  18.138 +          end;
  18.139 +  in case some_thyname
  18.140 +   of NONE => consts
  18.141 +    | SOME thyname => filter (belongs_here thyname) consts
  18.142 +  end;
  18.143 +
  18.144 +fun read_const_expr thy "*" = ([], consts_of thy NONE)
  18.145 +  | read_const_expr thy s = if String.isSuffix ".*" s
  18.146 +      then ([], consts_of thy (SOME (unsuffix ".*" s)))
  18.147 +      else ([read_const thy s], []);
  18.148 +
  18.149 +in
  18.150 +
  18.151 +fun read_const_exprs thy select exprs =
  18.152 +  case (pairself flat o split_list o map (read_const_expr thy)) exprs
  18.153 +   of (consts, []) => (false, consts)
  18.154 +    | (consts, consts') => (true, consts @ select consts');
  18.155 +
  18.156 +end; (*local*)
  18.157 +
  18.158 +(* conversion between constants, constant expressions and datatype constructors *)
  18.159 +
  18.160 +fun const_of_co thy tyco vs (co, tys) =
  18.161 +  const_of_cexpr thy (co, tys ---> Type (tyco, map TFree vs));
  18.162 +
  18.163 +fun consts_of_cos thy tyco vs cos =
  18.164 +  let
  18.165 +    val dty = Type (tyco, map TFree vs);
  18.166 +    fun mk_co (co, tys) = const_of_cexpr thy (co, tys ---> dty);
  18.167 +  in map mk_co cos end;
  18.168 +
  18.169 +local
  18.170 +
  18.171 +exception BAD of string;
  18.172 +
  18.173 +fun mg_typ_of_const thy (c, NONE) = Sign.the_const_type thy c
  18.174 +  | mg_typ_of_const thy (c, SOME tyco) =
  18.175 +      let
  18.176 +        val SOME class = AxClass.class_of_param thy c;
  18.177 +        val ty = Sign.the_const_type thy c;
  18.178 +          (*an approximation*)
  18.179 +        val sorts = Sorts.mg_domain (Sign.classes_of thy) tyco [class]
  18.180 +          handle CLASS_ERROR => raise BAD ("No such instance: " ^ tyco ^ " :: " ^ class
  18.181 +            ^ ",\nrequired for overloaded constant " ^ c);
  18.182 +        val vs = Name.invents Name.context "'a" (length sorts);
  18.183 +      in map_atyps (K (Type (tyco, map (fn v => TVar ((v, 0), [])) vs))) ty end;
  18.184 +
  18.185 +fun gen_co_of_const thy const =
  18.186 +  let
  18.187 +    val (c, _) = const;
  18.188 +    val ty = (Logic.unvarifyT o mg_typ_of_const thy) const;
  18.189 +    fun err () = raise BAD
  18.190 +      ("Illegal type for datatype constructor: " ^ string_of_typ thy ty);
  18.191 +    val (tys, ty') = strip_type ty;
  18.192 +    val (tyco, vs) = ((apsnd o map) dest_TFree o dest_Type) ty'
  18.193 +      handle TYPE _ => err ();
  18.194 +    val sorts = if has_duplicates (eq_fst op =) vs then err ()
  18.195 +      else map snd vs;
  18.196 +    val vs_names = Name.invent_list [] "'a" (length vs);
  18.197 +    val vs_map = map fst vs ~~ vs_names;
  18.198 +    val vs' = vs_names ~~ sorts;
  18.199 +    val tys' = (map o map_type_tfree) (fn (v, sort) =>
  18.200 +      (TFree ((the o AList.lookup (op =) vs_map) v, sort))) tys
  18.201 +      handle Option => err ();
  18.202 +  in (tyco, (vs', (c, tys'))) end;
  18.203 +
  18.204 +in
  18.205 +
  18.206 +fun co_of_const thy const = gen_co_of_const thy const handle BAD msg => error msg;
  18.207 +fun co_of_const' thy const = SOME (gen_co_of_const thy const) handle BAD msg => NONE;
  18.208 +
  18.209 +fun no_args thy = length o fst o strip_type o mg_typ_of_const thy;
  18.210 +
  18.211 +end;
  18.212 +
  18.213 +fun cos_of_consts thy consts =
  18.214 +  let
  18.215 +    val raw_cos  = map (co_of_const thy) consts;
  18.216 +    val (tyco, (vs_names, sorts_cos)) = if (length o distinct (eq_fst op =)) raw_cos = 1
  18.217 +      then ((fst o hd) raw_cos, ((map fst o fst o snd o hd) raw_cos,
  18.218 +        map ((apfst o map) snd o snd) raw_cos))
  18.219 +      else error ("Term constructors not referring to the same type: "
  18.220 +        ^ commas (map (string_of_const thy) consts));
  18.221 +    val sorts = foldr1 ((uncurry o map2 o curry o Sorts.inter_sort) (Sign.classes_of thy))
  18.222 +      (map fst sorts_cos);
  18.223 +    val cos = map snd sorts_cos;
  18.224 +    val vs = vs_names ~~ sorts;
  18.225 +  in (tyco, (vs, cos)) end;
  18.226 +
  18.227 +
  18.228 +(* dictionary values *)
  18.229 +
  18.230 +fun typargs thy (c_ty as (c, ty)) =
  18.231 +  let
  18.232 +    val opt_class = AxClass.class_of_param thy c;
  18.233 +    val tys = Sign.const_typargs thy (c, ty);
  18.234 +  in case (opt_class, tys)
  18.235 +   of (SOME class, ty as [Type (tyco, tys')]) =>
  18.236 +        if can (Sorts.mg_domain (Sign.classes_of thy) tyco) [class]
  18.237 +        then tys' else ty
  18.238 +    | _ => tys
  18.239 +  end;
  18.240 +
  18.241 +fun typ_sort_inst algebra =
  18.242 +  let
  18.243 +    val inters = Sorts.inter_sort algebra;
  18.244 +    fun match _ [] = I
  18.245 +      | match (TVar (v, S)) S' = Vartab.map_default (v, []) (fn S'' => inters (S, inters (S', S'')))
  18.246 +      | match (Type (a, Ts)) S =
  18.247 +          fold2 match Ts (Sorts.mg_domain algebra a S)
  18.248 +  in uncurry match end;
  18.249 +
  18.250 +
  18.251 +(* making rewrite theorems *)
  18.252 +
  18.253 +fun assert_rew thm =
  18.254 +  let
  18.255 +    val (lhs, rhs) = (Logic.dest_equals o Thm.plain_prop_of) thm
  18.256 +      handle TERM _ => bad_thm ("Not an equation: " ^ Display.string_of_thm thm)
  18.257 +          | THM _ => bad_thm ("Not an equation: " ^ Display.string_of_thm thm);
  18.258 +    fun vars_of t = fold_aterms
  18.259 +     (fn Var (v, _) => insert (op =) v
  18.260 +       | Free _ => bad_thm ("Illegal free variable in rewrite theorem\n"
  18.261 +           ^ Display.string_of_thm thm)
  18.262 +       | _ => I) t [];
  18.263 +    fun tvars_of t = fold_term_types
  18.264 +     (fn _ => fold_atyps (fn TVar (v, _) => insert (op =) v
  18.265 +                          | TFree _ => bad_thm 
  18.266 +      ("Illegal free type variable in rewrite theorem\n" ^ Display.string_of_thm thm))) t [];
  18.267 +    val lhs_vs = vars_of lhs;
  18.268 +    val rhs_vs = vars_of rhs;
  18.269 +    val lhs_tvs = tvars_of lhs;
  18.270 +    val rhs_tvs = tvars_of lhs;
  18.271 +    val _ = if null (subtract (op =) lhs_vs rhs_vs)
  18.272 +      then ()
  18.273 +      else bad_thm ("Free variables on right hand side of rewrite theorem\n"
  18.274 +        ^ Display.string_of_thm thm);
  18.275 +    val _ = if null (subtract (op =) lhs_tvs rhs_tvs)
  18.276 +      then ()
  18.277 +      else bad_thm ("Free type variables on right hand side of rewrite theorem\n"
  18.278 +        ^ Display.string_of_thm thm)
  18.279 +  in thm end;
  18.280 +
  18.281 +fun mk_rew thm =
  18.282 +  let
  18.283 +    val thy = Thm.theory_of_thm thm;
  18.284 +    val ctxt = ProofContext.init thy;
  18.285 +  in
  18.286 +    thm
  18.287 +    |> LocalDefs.meta_rewrite_rule ctxt
  18.288 +    |> assert_rew
  18.289 +  end;
  18.290 +
  18.291 +
  18.292 +(* making defining equations *)
  18.293 +
  18.294 +fun assert_func thm =
  18.295 +  let
  18.296 +    val thy = Thm.theory_of_thm thm;
  18.297 +    val (head, args) = (strip_comb o fst o Logic.dest_equals
  18.298 +      o ObjectLogic.drop_judgment thy o Thm.plain_prop_of) thm;
  18.299 +    val _ = case head of Const _ => () | _ =>
  18.300 +      bad_thm ("Equation not headed by constant\n" ^ Display.string_of_thm thm);
  18.301 +    val _ =
  18.302 +      if has_duplicates (op =)
  18.303 +        ((fold o fold_aterms) (fn Var (v, _) => cons v
  18.304 +          | _ => I
  18.305 +        ) args [])
  18.306 +      then bad_thm ("Duplicated variables on left hand side of equation\n"
  18.307 +        ^ Display.string_of_thm thm)
  18.308 +      else ()
  18.309 +    fun check _ (Abs _) = bad_thm
  18.310 +          ("Abstraction on left hand side of equation\n"
  18.311 +            ^ Display.string_of_thm thm)
  18.312 +      | check 0 (Var _) = ()
  18.313 +      | check _ (Var _) = bad_thm
  18.314 +          ("Variable with application on left hand side of defining equation\n"
  18.315 +            ^ Display.string_of_thm thm)
  18.316 +      | check n (t1 $ t2) = (check (n+1) t1; check 0 t2)
  18.317 +      | check n (Const (_, ty)) = if n <> (length o fst o strip_type) ty
  18.318 +          then bad_thm
  18.319 +            ("Partially applied constant on left hand side of equation\n"
  18.320 +               ^ Display.string_of_thm thm)
  18.321 +          else ();
  18.322 +    val _ = map (check 0) args;
  18.323 +  in thm end;
  18.324 +
  18.325 +val mk_func = assert_func o mk_rew;
  18.326 +
  18.327 +fun head_func thm =
  18.328 +  let
  18.329 +    val thy = Thm.theory_of_thm thm;
  18.330 +    val (Const (c_ty as (_, ty))) = (fst o strip_comb o fst o Logic.dest_equals
  18.331 +      o ObjectLogic.drop_judgment thy o Thm.plain_prop_of) thm;
  18.332 +    val const = const_of_cexpr thy c_ty;
  18.333 +  in (const, ty) end;
  18.334 +
  18.335 +
  18.336 +(* utilities *)
  18.337 +
  18.338 +fun inst_thm tvars' thm =
  18.339 +  let
  18.340 +    val thy = Thm.theory_of_thm thm;
  18.341 +    val tvars = (Term.add_tvars o Thm.prop_of) thm [];
  18.342 +    fun mk_inst (tvar as (v, _)) = case Vartab.lookup tvars' v
  18.343 +     of SOME sort => SOME (pairself (Thm.ctyp_of thy o TVar) (tvar, (v, sort)))
  18.344 +      | NONE => NONE;
  18.345 +    val insts = map_filter mk_inst tvars;
  18.346 +  in Thm.instantiate (insts, []) thm end;
  18.347 +
  18.348 +fun expand_eta k thm =
  18.349 +  let
  18.350 +    val thy = Thm.theory_of_thm thm;
  18.351 +    val (lhs, rhs) = (Logic.dest_equals o Thm.plain_prop_of) thm;
  18.352 +    val (head, args) = strip_comb lhs;
  18.353 +    val l = if k = ~1
  18.354 +      then (length o fst o strip_abs) rhs
  18.355 +      else Int.max (0, k - length args);
  18.356 +    val used = Name.make_context (map (fst o fst) (Term.add_vars lhs []));
  18.357 +    fun get_name _ 0 used = ([], used)
  18.358 +      | get_name (Abs (v, ty, t)) k used =
  18.359 +          used
  18.360 +          |> Name.variants [v]
  18.361 +          ||>> get_name t (k - 1)
  18.362 +          |>> (fn ([v'], vs') => (v', ty) :: vs')
  18.363 +      | get_name t k used = 
  18.364 +          let
  18.365 +            val (tys, _) = (strip_type o fastype_of) t
  18.366 +          in case tys
  18.367 +           of [] => raise TERM ("expand_eta", [t])
  18.368 +            | ty :: _ =>
  18.369 +                used
  18.370 +                |> Name.variants [""]
  18.371 +                |-> (fn [v] => get_name (t $ Var ((v, 0), ty)) (k - 1)
  18.372 +                #>> (fn vs' => (v, ty) :: vs'))
  18.373 +          end;
  18.374 +    val (vs, _) = get_name rhs l used;
  18.375 +    val vs_refl = map (fn (v, ty) => Thm.reflexive (Thm.cterm_of thy (Var ((v, 0), ty)))) vs;
  18.376 +  in
  18.377 +    thm
  18.378 +    |> fold (fn refl => fn thm => Thm.combination thm refl) vs_refl
  18.379 +    |> Conv.fconv_rule Drule.beta_eta_conversion
  18.380 +  end;
  18.381 +
  18.382 +fun rewrite_func rewrites thm =
  18.383 +  let
  18.384 +    val rewrite = MetaSimplifier.rewrite false rewrites;
  18.385 +    val (ct_eq, [ct_lhs, ct_rhs]) = (Drule.strip_comb o Thm.cprop_of) thm;
  18.386 +    val Const ("==", _) = Thm.term_of ct_eq;
  18.387 +    val (ct_f, ct_args) = Drule.strip_comb ct_lhs;
  18.388 +    val rhs' = rewrite ct_rhs;
  18.389 +    val args' = map rewrite ct_args;
  18.390 +    val lhs' = Thm.symmetric (fold (fn th1 => fn th2 => Thm.combination th2 th1)
  18.391 +      args' (Thm.reflexive ct_f));
  18.392 +  in Thm.transitive (Thm.transitive lhs' thm) rhs' end;
  18.393 +
  18.394 +fun norm_args thms =
  18.395 +  let
  18.396 +    val num_args_of = length o snd o strip_comb o fst o Logic.dest_equals;
  18.397 +    val k = fold (curry Int.max o num_args_of o Thm.plain_prop_of) thms 0;
  18.398 +  in
  18.399 +    thms
  18.400 +    |> map (expand_eta k)
  18.401 +    |> map (Conv.fconv_rule Drule.beta_eta_conversion)
  18.402 +  end;
  18.403 +
  18.404 +fun canonical_tvars purify_tvar thm =
  18.405 +  let
  18.406 +    val ctyp = Thm.ctyp_of (Thm.theory_of_thm thm);
  18.407 +    fun tvars_subst_for thm = (fold_types o fold_atyps)
  18.408 +      (fn TVar (v_i as (v, _), sort) => let
  18.409 +            val v' = purify_tvar v
  18.410 +          in if v = v' then I
  18.411 +          else insert (op =) (v_i, (v', sort)) end
  18.412 +        | _ => I) (prop_of thm) [];
  18.413 +    fun mk_inst (v_i, (v', sort)) (maxidx, acc) =
  18.414 +      let
  18.415 +        val ty = TVar (v_i, sort)
  18.416 +      in
  18.417 +        (maxidx + 1, (ctyp ty, ctyp (TVar ((v', maxidx), sort))) :: acc)
  18.418 +      end;
  18.419 +    val maxidx = Thm.maxidx_of thm + 1;
  18.420 +    val (_, inst) = fold mk_inst (tvars_subst_for thm) (maxidx + 1, []);
  18.421 +  in Thm.instantiate (inst, []) thm end;
  18.422 +
  18.423 +fun canonical_vars purify_var thm =
  18.424 +  let
  18.425 +    val cterm = Thm.cterm_of (Thm.theory_of_thm thm);
  18.426 +    fun vars_subst_for thm = fold_aterms
  18.427 +      (fn Var (v_i as (v, _), ty) => let
  18.428 +            val v' = purify_var v
  18.429 +          in if v = v' then I
  18.430 +          else insert (op =) (v_i, (v', ty)) end
  18.431 +        | _ => I) (prop_of thm) [];
  18.432 +    fun mk_inst (v_i as (v, i), (v', ty)) (maxidx, acc) =
  18.433 +      let
  18.434 +        val t = Var (v_i, ty)
  18.435 +      in
  18.436 +        (maxidx + 1, (cterm t, cterm (Var ((v', maxidx), ty))) :: acc)
  18.437 +      end;
  18.438 +    val maxidx = Thm.maxidx_of thm + 1;
  18.439 +    val (_, inst) = fold mk_inst (vars_subst_for thm) (maxidx + 1, []);
  18.440 +  in Thm.instantiate ([], inst) thm end;
  18.441 +
  18.442 +fun canonical_absvars purify_var thm =
  18.443 +  let
  18.444 +    val t = Thm.plain_prop_of thm;
  18.445 +    val t' = Term.map_abs_vars purify_var t;
  18.446 +  in Thm.rename_boundvars t t' thm end;
  18.447 +
  18.448 +fun norm_varnames purify_tvar purify_var thms =
  18.449 +  let
  18.450 +    fun burrow_thms f [] = []
  18.451 +      | burrow_thms f thms =
  18.452 +          thms
  18.453 +          |> Conjunction.intr_balanced
  18.454 +          |> f
  18.455 +          |> Conjunction.elim_balanced (length thms)
  18.456 +  in
  18.457 +    thms
  18.458 +    |> burrow_thms (canonical_tvars purify_tvar)
  18.459 +    |> map (canonical_vars purify_var)
  18.460 +    |> map (canonical_absvars purify_var)
  18.461 +    |> map Drule.zero_var_indexes
  18.462 +  end;
  18.463 +
  18.464 +end;
    19.1 --- a/src/Pure/Isar/constdefs.ML	Fri Aug 10 17:04:24 2007 +0200
    19.2 +++ b/src/Pure/Isar/constdefs.ML	Fri Aug 10 17:04:34 2007 +0200
    19.3 @@ -51,7 +51,7 @@
    19.4        thy
    19.5        |> Sign.add_consts_i [(c, T, mx)]
    19.6        |> PureThy.add_defs_i false [((name, def), atts)]
    19.7 -      |-> (fn [thm] => CodegenData.add_func false thm);
    19.8 +      |-> (fn [thm] => Code.add_func false thm);
    19.9    in ((c, T), thy') end;
   19.10  
   19.11  fun gen_constdefs prep_vars prep_prop prep_att (raw_structs, specs) thy =
    20.1 --- a/src/Pure/Isar/isar_syn.ML	Fri Aug 10 17:04:24 2007 +0200
    20.2 +++ b/src/Pure/Isar/isar_syn.ML	Fri Aug 10 17:04:34 2007 +0200
    20.3 @@ -89,7 +89,7 @@
    20.4      (P.name -- Scan.optional ((P.$$$ "\\<subseteq>" || P.$$$ "<") |--
    20.5          P.!!! (P.list1 P.xname)) []
    20.6          -- Scan.repeat (SpecParse.thm_name ":" -- (P.prop >> single))
    20.7 -      >> (fn (x, y) => Toplevel.theory (snd o ClassPackage.axclass_cmd x y)));
    20.8 +      >> (fn (x, y) => Toplevel.theory (snd o Class.axclass_cmd x y)));
    20.9  
   20.10  
   20.11  (* types *)
   20.12 @@ -422,16 +422,16 @@
   20.13      -- P.opt_begin
   20.14      >> (fn (((bname, add_consts), (supclasses, elems)), begin) =>
   20.15          Toplevel.begin_local_theory begin
   20.16 -          (ClassPackage.class_cmd bname supclasses elems add_consts #-> TheoryTarget.begin)));
   20.17 +          (Class.class_cmd bname supclasses elems add_consts #-> TheoryTarget.begin)));
   20.18  
   20.19  val instanceP =
   20.20    OuterSyntax.command "instance" "prove type arity or subclass relation" K.thy_goal ((
   20.21        P.xname -- ((P.$$$ "\\<subseteq>" || P.$$$ "<") |-- P.!!! P.xname)
   20.22 -           >> ClassPackage.instance_class_cmd
   20.23 +           >> Class.instance_class_cmd
   20.24        || P.$$$ "advanced" |-- P.xname -- ((P.$$$ "\\<subseteq>" || P.$$$ "<") |-- P.!!! P.xname)
   20.25 -           >> ClassPackage.instance_sort_cmd
   20.26 +           >> Class.instance_sort_cmd
   20.27        || P.and_list1 P.arity -- Scan.repeat (SpecParse.opt_thm_name ":" -- P.prop)
   20.28 -           >> (fn (arities, defs) => ClassPackage.instance_arity_cmd arities defs)
   20.29 +           >> (fn (arities, defs) => Class.instance_arity_cmd arities defs)
   20.30      ) >> (Toplevel.print oo Toplevel.theory_to_proof));
   20.31  
   20.32  end;
   20.33 @@ -441,7 +441,7 @@
   20.34  
   20.35  val code_datatypeP =
   20.36    OuterSyntax.command "code_datatype" "define set of code datatype constructors" K.thy_decl
   20.37 -    (Scan.repeat1 P.term >> (Toplevel.theory o CodegenData.add_datatype_consts_cmd));
   20.38 +    (Scan.repeat1 P.term >> (Toplevel.theory o Code.add_datatype_consts_cmd));
   20.39  
   20.40  
   20.41  
   20.42 @@ -763,7 +763,7 @@
   20.43  val print_classesP =
   20.44    OuterSyntax.improper_command "print_classes" "print classes of this theory" K.diag
   20.45      (Scan.succeed (Toplevel.no_timing o Toplevel.unknown_theory
   20.46 -      o Toplevel.keep (ClassPackage.print_classes o Toplevel.theory_of)));
   20.47 +      o Toplevel.keep (Class.print_classes o Toplevel.theory_of)));
   20.48  
   20.49  val print_localeP =
   20.50    OuterSyntax.improper_command "print_locale" "print locale expression in this theory" K.diag
   20.51 @@ -884,7 +884,7 @@
   20.52    OuterSyntax.improper_command "print_codesetup" "print code generator setup of this theory" K.diag
   20.53      (Scan.succeed
   20.54        (Toplevel.no_timing o Toplevel.unknown_theory o Toplevel.keep
   20.55 -        (CodegenData.print_codesetup o Toplevel.theory_of)));
   20.56 +        (Code.print_codesetup o Toplevel.theory_of)));
   20.57  
   20.58  
   20.59  (** system commands (for interactive mode only) **)
    21.1 --- a/src/Pure/Isar/specification.ML	Fri Aug 10 17:04:24 2007 +0200
    21.2 +++ b/src/Pure/Isar/specification.ML	Fri Aug 10 17:04:34 2007 +0200
    21.3 @@ -130,7 +130,7 @@
    21.4        |> LocalTheory.def Thm.definitionK ((x, mx), ((name ^ "_raw", []), rhs));
    21.5      val ((b, [th']), lthy3) = lthy2
    21.6        |> LocalTheory.note Thm.definitionK
    21.7 -          ((name, CodegenData.add_func_attr false :: atts), [prove lthy2 th]);
    21.8 +          ((name, Code.add_func_attr false :: atts), [prove lthy2 th]);
    21.9  
   21.10      val lhs' = Morphism.term (LocalTheory.target_morphism lthy3) lhs;
   21.11      val _ = print_consts lthy3 (member (op =) (Term.add_frees lhs' [])) [(x, T)];
    22.1 --- a/src/Pure/Proof/extraction.ML	Fri Aug 10 17:04:24 2007 +0200
    22.2 +++ b/src/Pure/Proof/extraction.ML	Fri Aug 10 17:04:34 2007 +0200
    22.3 @@ -741,7 +741,7 @@
    22.4                        (ProofChecker.thm_of_proof thy'
    22.5                         (fst (Proofterm.freeze_thaw_prf prf)))))), [])
    22.6               |> snd
    22.7 -             |> fold (CodegenData.add_func false) def_thms
    22.8 +             |> fold (Code.add_func false) def_thms
    22.9             end
   22.10         | SOME _ => thy);
   22.11  
    23.1 --- a/src/Pure/Tools/ROOT.ML	Fri Aug 10 17:04:24 2007 +0200
    23.2 +++ b/src/Pure/Tools/ROOT.ML	Fri Aug 10 17:04:34 2007 +0200
    23.3 @@ -13,12 +13,10 @@
    23.4  (*derived theory and proof elements*)
    23.5  use "invoke.ML";
    23.6  
    23.7 -(*code generator, 1st generation*)
    23.8 +(*code generator*)
    23.9  use "../codegen.ML";
   23.10 -
   23.11 -(*code generator, 2nd generation*)
   23.12 -use "codegen_names.ML";
   23.13 -use "codegen_funcgr.ML";
   23.14 -use "codegen_thingol.ML";
   23.15 -use "codegen_serializer.ML";
   23.16 -use "codegen_package.ML";
   23.17 +use "../../Tools/code/code_name.ML";
   23.18 +use "../../Tools/code/code_funcgr.ML";
   23.19 +use "../../Tools/code/code_thingol.ML";
   23.20 +use "../../Tools/code/code_target.ML";
   23.21 +use "../../Tools/code/code_package.ML";
    24.1 --- a/src/Pure/Tools/codegen_consts.ML	Fri Aug 10 17:04:24 2007 +0200
    24.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    24.3 @@ -1,223 +0,0 @@
    24.4 -(*  Title:      Pure/Tools/codegen_consts.ML
    24.5 -    ID:         $Id$
    24.6 -    Author:     Florian Haftmann, TU Muenchen
    24.7 -
    24.8 -Identifying constants by name plus normalized type instantantiation schemes.
    24.9 -Convenient data structures for constants.  Auxiliary.
   24.10 -*)
   24.11 -
   24.12 -signature CODEGEN_CONSTS =
   24.13 -sig
   24.14 -  type const = string * string option (*constant name, possibly instance*)
   24.15 -  val const_ord: const * const -> order
   24.16 -  val eq_const: const * const -> bool
   24.17 -  structure Consttab: TABLE
   24.18 -  val const_of_cexpr: theory -> string * typ -> const
   24.19 -  val string_of_typ: theory -> typ -> string
   24.20 -  val string_of_const: theory -> const -> string
   24.21 -  val read_bare_const: theory -> string -> string * typ
   24.22 -  val read_const: theory -> string -> const
   24.23 -  val read_const_exprs: theory -> (const list -> const list)
   24.24 -    -> string list -> bool * const list
   24.25 -
   24.26 -  val co_of_const: theory -> const
   24.27 -    -> string * ((string * sort) list * (string * typ list))
   24.28 -  val co_of_const': theory -> const
   24.29 -    -> (string * ((string * sort) list * (string * typ list))) option
   24.30 -  val cos_of_consts: theory -> const list
   24.31 -    -> string * ((string * sort) list * (string * typ list) list)
   24.32 -  val const_of_co: theory -> string -> (string * sort) list
   24.33 -    -> string * typ list -> const
   24.34 -  val consts_of_cos: theory -> string -> (string * sort) list
   24.35 -    -> (string * typ list) list -> const list
   24.36 -  val no_args: theory -> const -> int
   24.37 -
   24.38 -  val typargs: theory -> string * typ -> typ list
   24.39 -  val typ_sort_inst: Sorts.algebra -> typ * sort
   24.40 -    -> sort Vartab.table -> sort Vartab.table
   24.41 -end;
   24.42 -
   24.43 -structure CodegenConsts: CODEGEN_CONSTS =
   24.44 -struct
   24.45 -
   24.46 -
   24.47 -(* basic data structures *)
   24.48 -
   24.49 -type const = string * string option;
   24.50 -val const_ord = prod_ord fast_string_ord (option_ord string_ord);
   24.51 -val eq_const = is_equal o const_ord;
   24.52 -
   24.53 -structure Consttab =
   24.54 -  TableFun(
   24.55 -    type key = const;
   24.56 -    val ord = const_ord;
   24.57 -  );
   24.58 -
   24.59 -fun string_of_typ thy = setmp show_sorts true (Sign.string_of_typ thy);
   24.60 -
   24.61 -
   24.62 -(* conversion between constant expressions and constants *)
   24.63 -
   24.64 -fun const_of_cexpr thy (c_ty as (c, _)) =
   24.65 -  case AxClass.class_of_param thy c
   24.66 -   of SOME class => (case Sign.const_typargs thy c_ty
   24.67 -       of [Type (tyco, _)] => if can (Sorts.mg_domain (Sign.classes_of thy) tyco) [class]
   24.68 -              then (c, SOME tyco)
   24.69 -              else (c, NONE)
   24.70 -        | [_] => (c, NONE))
   24.71 -    | NONE => (c, NONE);
   24.72 -
   24.73 -fun string_of_const thy (c, NONE) = Sign.extern_const thy c
   24.74 -  | string_of_const thy (c, SOME tyco) = Sign.extern_const thy c
   24.75 -      ^ " " ^ enclose "[" "]" (Sign.extern_type thy tyco);
   24.76 -
   24.77 -
   24.78 -(* reading constants as terms and wildcards pattern *)
   24.79 -
   24.80 -fun read_bare_const thy raw_t =
   24.81 -  let
   24.82 -    val t = Sign.read_term thy raw_t;
   24.83 -  in case try dest_Const t
   24.84 -   of SOME c_ty => c_ty
   24.85 -    | NONE => error ("Not a constant: " ^ Sign.string_of_term thy t)
   24.86 -  end;
   24.87 -
   24.88 -fun read_const thy = const_of_cexpr thy o read_bare_const thy;
   24.89 -
   24.90 -local
   24.91 -
   24.92 -fun consts_of thy some_thyname =
   24.93 -  let
   24.94 -    val this_thy = Option.map theory some_thyname |> the_default thy;
   24.95 -    val cs = Symtab.fold (fn (c, (_, NONE)) => cons c | _ => I)
   24.96 -      ((snd o #constants o Consts.dest o #consts o Sign.rep_sg) this_thy) [];
   24.97 -    fun classop c = case AxClass.class_of_param thy c
   24.98 -     of NONE => [(c, NONE)]
   24.99 -      | SOME class => Symtab.fold
  24.100 -          (fn (tyco, classes) => if AList.defined (op =) classes class
  24.101 -            then cons (c, SOME tyco) else I)
  24.102 -          ((#arities o Sorts.rep_algebra o Sign.classes_of) this_thy)
  24.103 -          [(c, NONE)];
  24.104 -    val consts = maps classop cs;
  24.105 -    fun test_instance thy (class, tyco) =
  24.106 -      can (Sorts.mg_domain (Sign.classes_of thy) tyco) [class]
  24.107 -    fun belongs_here thyname (c, NONE) =
  24.108 -          not (exists (fn thy' => Sign.declared_const thy' c) (Theory.parents_of this_thy))
  24.109 -      | belongs_here thyname (c, SOME tyco) =
  24.110 -          let
  24.111 -            val SOME class = AxClass.class_of_param thy c
  24.112 -          in not (exists (fn thy' => test_instance thy' (class, tyco))
  24.113 -            (Theory.parents_of this_thy))
  24.114 -          end;
  24.115 -  in case some_thyname
  24.116 -   of NONE => consts
  24.117 -    | SOME thyname => filter (belongs_here thyname) consts
  24.118 -  end;
  24.119 -
  24.120 -fun read_const_expr thy "*" = ([], consts_of thy NONE)
  24.121 -  | read_const_expr thy s = if String.isSuffix ".*" s
  24.122 -      then ([], consts_of thy (SOME (unsuffix ".*" s)))
  24.123 -      else ([read_const thy s], []);
  24.124 -
  24.125 -in
  24.126 -
  24.127 -fun read_const_exprs thy select exprs =
  24.128 -  case (pairself flat o split_list o map (read_const_expr thy)) exprs
  24.129 -   of (consts, []) => (false, consts)
  24.130 -    | (consts, consts') => (true, consts @ select consts');
  24.131 -
  24.132 -end; (*local*)
  24.133 -
  24.134 -(* conversion between constants, constant expressions and datatype constructors *)
  24.135 -
  24.136 -fun const_of_co thy tyco vs (co, tys) =
  24.137 -  const_of_cexpr thy (co, tys ---> Type (tyco, map TFree vs));
  24.138 -
  24.139 -fun consts_of_cos thy tyco vs cos =
  24.140 -  let
  24.141 -    val dty = Type (tyco, map TFree vs);
  24.142 -    fun mk_co (co, tys) = const_of_cexpr thy (co, tys ---> dty);
  24.143 -  in map mk_co cos end;
  24.144 -
  24.145 -local
  24.146 -
  24.147 -exception BAD of string;
  24.148 -
  24.149 -fun mg_typ_of_const thy (c, NONE) = Sign.the_const_type thy c
  24.150 -  | mg_typ_of_const thy (c, SOME tyco) =
  24.151 -      let
  24.152 -        val SOME class = AxClass.class_of_param thy c;
  24.153 -        val ty = Sign.the_const_type thy c;
  24.154 -          (*an approximation*)
  24.155 -        val sorts = Sorts.mg_domain (Sign.classes_of thy) tyco [class]
  24.156 -          handle CLASS_ERROR => raise BAD ("No such instance: " ^ tyco ^ " :: " ^ class
  24.157 -            ^ ",\nrequired for overloaded constant " ^ c);
  24.158 -        val vs = Name.invents Name.context "'a" (length sorts);
  24.159 -      in map_atyps (K (Type (tyco, map (fn v => TVar ((v, 0), [])) vs))) ty end;
  24.160 -
  24.161 -fun gen_co_of_const thy const =
  24.162 -  let
  24.163 -    val (c, _) = const;
  24.164 -    val ty = (Logic.unvarifyT o mg_typ_of_const thy) const;
  24.165 -    fun err () = raise BAD
  24.166 -      ("Illegal type for datatype constructor: " ^ string_of_typ thy ty);
  24.167 -    val (tys, ty') = strip_type ty;
  24.168 -    val (tyco, vs) = ((apsnd o map) dest_TFree o dest_Type) ty'
  24.169 -      handle TYPE _ => err ();
  24.170 -    val sorts = if has_duplicates (eq_fst op =) vs then err ()
  24.171 -      else map snd vs;
  24.172 -    val vs_names = Name.invent_list [] "'a" (length vs);
  24.173 -    val vs_map = map fst vs ~~ vs_names;
  24.174 -    val vs' = vs_names ~~ sorts;
  24.175 -    val tys' = (map o map_type_tfree) (fn (v, sort) =>
  24.176 -      (TFree ((the o AList.lookup (op =) vs_map) v, sort))) tys
  24.177 -      handle Option => err ();
  24.178 -  in (tyco, (vs', (c, tys'))) end;
  24.179 -
  24.180 -in
  24.181 -
  24.182 -fun co_of_const thy const = gen_co_of_const thy const handle BAD msg => error msg;
  24.183 -fun co_of_const' thy const = SOME (gen_co_of_const thy const) handle BAD msg => NONE;
  24.184 -
  24.185 -fun no_args thy = length o fst o strip_type o mg_typ_of_const thy;
  24.186 -
  24.187 -end;
  24.188 -
  24.189 -fun cos_of_consts thy consts =
  24.190 -  let
  24.191 -    val raw_cos  = map (co_of_const thy) consts;
  24.192 -    val (tyco, (vs_names, sorts_cos)) = if (length o distinct (eq_fst op =)) raw_cos = 1
  24.193 -      then ((fst o hd) raw_cos, ((map fst o fst o snd o hd) raw_cos,
  24.194 -        map ((apfst o map) snd o snd) raw_cos))
  24.195 -      else error ("Term constructors not referring to the same type: "
  24.196 -        ^ commas (map (string_of_const thy) consts));
  24.197 -    val sorts = foldr1 ((uncurry o map2 o curry o Sorts.inter_sort) (Sign.classes_of thy))
  24.198 -      (map fst sorts_cos);
  24.199 -    val cos = map snd sorts_cos;
  24.200 -    val vs = vs_names ~~ sorts;
  24.201 -  in (tyco, (vs, cos)) end;
  24.202 -
  24.203 -
  24.204 -(* dictionary values *)
  24.205 -
  24.206 -fun typargs thy (c_ty as (c, ty)) =
  24.207 -  let
  24.208 -    val opt_class = AxClass.class_of_param thy c;
  24.209 -    val tys = Sign.const_typargs thy (c, ty);
  24.210 -  in case (opt_class, tys)
  24.211 -   of (SOME class, ty as [Type (tyco, tys')]) =>
  24.212 -        if can (Sorts.mg_domain (Sign.classes_of thy) tyco) [class]
  24.213 -        then tys' else ty
  24.214 -    | _ => tys
  24.215 -  end;
  24.216 -
  24.217 -fun typ_sort_inst algebra =
  24.218 -  let
  24.219 -    val inters = Sorts.inter_sort algebra;
  24.220 -    fun match _ [] = I
  24.221 -      | match (TVar (v, S)) S' = Vartab.map_default (v, []) (fn S'' => inters (S, inters (S', S'')))
  24.222 -      | match (Type (a, Ts)) S =
  24.223 -          fold2 match Ts (Sorts.mg_domain algebra a S)
  24.224 -  in uncurry match end;
  24.225 -
  24.226 -end;
    25.1 --- a/src/Pure/Tools/codegen_data.ML	Fri Aug 10 17:04:24 2007 +0200
    25.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    25.3 @@ -1,892 +0,0 @@
    25.4 -(*  Title:      Pure/Tools/codegen_data.ML
    25.5 -    ID:         $Id$
    25.6 -    Author:     Florian Haftmann, TU Muenchen
    25.7 -
    25.8 -Abstract executable content of theory.  Management of data dependent on
    25.9 -executable content.
   25.10 -*)
   25.11 -
   25.12 -signature CODEGEN_DATA =
   25.13 -sig
   25.14 -  val lazy_thms: (unit -> thm list) -> thm list Susp.T
   25.15 -  val eval_always: bool ref
   25.16 -
   25.17 -  val add_func: bool -> thm -> theory -> theory
   25.18 -  val del_func: thm -> theory -> theory
   25.19 -  val add_funcl: CodegenConsts.const * thm list Susp.T -> theory -> theory
   25.20 -  val add_func_attr: bool -> Attrib.src
   25.21 -  val add_inline: thm -> theory -> theory
   25.22 -  val del_inline: thm -> theory -> theory
   25.23 -  val add_inline_proc: string * (theory -> cterm list -> thm list) -> theory -> theory
   25.24 -  val del_inline_proc: string -> theory -> theory
   25.25 -  val add_preproc: string * (theory -> thm list -> thm list) -> theory -> theory
   25.26 -  val del_preproc: string -> theory -> theory
   25.27 -  val add_post: thm -> theory -> theory
   25.28 -  val del_post: thm -> theory -> theory
   25.29 -  val add_datatype: string * ((string * sort) list * (string * typ list) list)
   25.30 -    -> theory -> theory
   25.31 -  val add_datatype_consts: CodegenConsts.const list -> theory -> theory
   25.32 -  val add_datatype_consts_cmd: string list -> theory -> theory
   25.33 -
   25.34 -  val coregular_algebra: theory -> Sorts.algebra
   25.35 -  val operational_algebra: theory -> (sort -> sort) * Sorts.algebra
   25.36 -  val these_funcs: theory -> CodegenConsts.const -> thm list
   25.37 -  val get_datatype: theory -> string -> ((string * sort) list * (string * typ list) list)
   25.38 -  val get_datatype_of_constr: theory -> CodegenConsts.const -> string option
   25.39 -  val default_typ: theory -> CodegenConsts.const -> typ
   25.40 -
   25.41 -  val preprocess_conv: cterm -> thm
   25.42 -  val postprocess_conv: cterm -> thm
   25.43 -
   25.44 -  val print_codesetup: theory -> unit
   25.45 -
   25.46 -  val trace: bool ref
   25.47 -end;
   25.48 -
   25.49 -signature CODE_DATA_ARGS =
   25.50 -sig
   25.51 -  type T
   25.52 -  val empty: T
   25.53 -  val merge: Pretty.pp -> T * T -> T
   25.54 -  val purge: theory option -> CodegenConsts.const list option -> T -> T
   25.55 -end;
   25.56 -
   25.57 -signature CODE_DATA =
   25.58 -sig
   25.59 -  type T
   25.60 -  val get: theory -> T
   25.61 -  val change: theory -> (T -> T) -> T
   25.62 -  val change_yield: theory -> (T -> 'a * T) -> 'a * T
   25.63 -end;
   25.64 -
   25.65 -signature PRIVATE_CODEGEN_DATA =
   25.66 -sig
   25.67 -  include CODEGEN_DATA
   25.68 -  val declare_data: Object.T -> (Pretty.pp -> Object.T * Object.T -> Object.T)
   25.69 -    -> (theory option -> CodegenConsts.const list option -> Object.T -> Object.T) -> serial
   25.70 -  val get_data: serial * ('a -> Object.T) * (Object.T -> 'a)
   25.71 -    -> theory -> 'a
   25.72 -  val change_data: serial * ('a -> Object.T) * (Object.T -> 'a)
   25.73 -    -> theory -> ('a -> 'a) -> 'a
   25.74 -  val change_yield_data: serial * ('a -> Object.T) * (Object.T -> 'a)
   25.75 -    -> theory -> ('a -> 'b * 'a) -> 'b * 'a
   25.76 -end;
   25.77 -
   25.78 -structure CodegenData : PRIVATE_CODEGEN_DATA =
   25.79 -struct
   25.80 -
   25.81 -(* auxiliary, diagnostics *)
   25.82 -
   25.83 -structure Consttab = CodegenConsts.Consttab;
   25.84 -
   25.85 -val trace = ref false;
   25.86 -fun tracing f x = (if !trace then Output.tracing (f x) else (); x);
   25.87 -
   25.88 -
   25.89 -(* lazy theorems, certificate theorems *)
   25.90 -
   25.91 -val eval_always = ref false;
   25.92 -
   25.93 -fun lazy_thms f = if !eval_always
   25.94 -  then Susp.value (f ())
   25.95 -  else Susp.delay f;
   25.96 -
   25.97 -fun string_of_lthms r = case Susp.peek r
   25.98 - of SOME thms => (map string_of_thm o rev) thms
   25.99 -  | NONE => ["[...]"];
  25.100 -
  25.101 -fun pretty_lthms ctxt r = case Susp.peek r
  25.102 - of SOME thms => map (ProofContext.pretty_thm ctxt) thms
  25.103 -  | NONE => [Pretty.str "[...]"];
  25.104 -
  25.105 -fun certificate thy f r =
  25.106 -  case Susp.peek r
  25.107 -   of SOME thms => (Susp.value o f thy) thms
  25.108 -     | NONE => let
  25.109 -          val thy_ref = Theory.check_thy thy;
  25.110 -        in lazy_thms (fn () => (f (Theory.deref thy_ref) o Susp.force) r) end;
  25.111 -
  25.112 -fun merge' _ ([], []) = (false, [])
  25.113 -  | merge' _ ([], ys) = (true, ys)
  25.114 -  | merge' eq (xs, ys) = fold_rev
  25.115 -      (fn y => fn (t, xs) => (t orelse not (member eq xs y), insert eq y xs)) ys (false, xs);
  25.116 -
  25.117 -fun merge_alist eq_key eq (xys as (xs, ys)) =
  25.118 -  if eq_list (eq_pair eq_key eq) (xs, ys)
  25.119 -  then (false, xs)
  25.120 -  else (true, AList.merge eq_key eq xys);
  25.121 -
  25.122 -val merge_thms = merge' Thm.eq_thm_prop;
  25.123 -
  25.124 -fun merge_lthms (r1, r2) =
  25.125 -  if Susp.same (r1, r2)
  25.126 -    then (false, r1)
  25.127 -  else case Susp.peek r1
  25.128 -   of SOME [] => (true, r2)
  25.129 -    | _ => case Susp.peek r2
  25.130 -       of SOME [] => (true, r1)
  25.131 -        | _ => (apsnd (lazy_thms o K)) (merge_thms (Susp.force r1, Susp.force r2));
  25.132 -
  25.133 -
  25.134 -(* pairs of (selected, deleted) defining equations *)
  25.135 -
  25.136 -type sdthms = thm list Susp.T * thm list;
  25.137 -
  25.138 -fun add_drop_redundant thm (sels, dels) =
  25.139 -  let
  25.140 -    val thy = Thm.theory_of_thm thm;
  25.141 -    val args_of = snd o strip_comb o fst o Logic.dest_equals o Thm.plain_prop_of;
  25.142 -    val args = args_of thm;
  25.143 -    fun matches [] _ = true
  25.144 -      | matches (Var _ :: xs) [] = matches xs []
  25.145 -      | matches (_ :: _) [] = false
  25.146 -      | matches (x :: xs) (y :: ys) = Pattern.matches thy (x, y) andalso matches xs ys;
  25.147 -    fun drop thm' = not (matches args (args_of thm'))
  25.148 -      orelse (warning ("code generator: dropping redundant defining equation\n" ^ string_of_thm thm'); false);
  25.149 -    val (keeps, drops) = List.partition drop sels;
  25.150 -  in (thm :: keeps, dels |> remove Thm.eq_thm_prop thm |> fold (insert Thm.eq_thm_prop) drops) end;
  25.151 -
  25.152 -fun add_thm thm (sels, dels) =
  25.153 -  apfst Susp.value (add_drop_redundant thm (Susp.force sels, dels));
  25.154 -
  25.155 -fun add_lthms lthms (sels, []) =
  25.156 -      (lazy_thms (fn () => fold add_drop_redundant
  25.157 -        (Susp.force lthms) (Susp.force sels, []) |> fst), [])
  25.158 -        (*FIXME*)
  25.159 -  | add_lthms lthms (sels, dels) =
  25.160 -      fold add_thm (Susp.force lthms) (sels, dels);
  25.161 -
  25.162 -fun del_thm thm (sels, dels) =
  25.163 -  (Susp.value (remove Thm.eq_thm_prop thm (Susp.force sels)), thm :: dels);
  25.164 -
  25.165 -fun pretty_sdthms ctxt (sels, _) = pretty_lthms ctxt sels;
  25.166 -
  25.167 -fun merge_sdthms ((sels1, dels1), (sels2, dels2)) =
  25.168 -  let
  25.169 -    val (dels_t, dels) = merge_thms (dels1, dels2);
  25.170 -  in if dels_t
  25.171 -    then let
  25.172 -      val (_, sels) = merge_thms
  25.173 -        (subtract Thm.eq_thm_prop dels2 (Susp.force sels1), Susp.force sels2);
  25.174 -      val (_, dels) = merge_thms
  25.175 -        (subtract Thm.eq_thm_prop (Susp.force sels2) dels1, dels2);
  25.176 -    in (true, ((lazy_thms o K) sels, dels)) end
  25.177 -    else let
  25.178 -      val (sels_t, sels) = merge_lthms (sels1, sels2);
  25.179 -    in (sels_t, (sels, dels)) end
  25.180 -  end;
  25.181 -
  25.182 -
  25.183 -(** exeuctable content **)
  25.184 -
  25.185 -datatype thmproc = Preproc of {
  25.186 -  inlines: thm list,
  25.187 -  inline_procs: (string * (serial * (theory -> cterm list -> thm list))) list,
  25.188 -  preprocs: (string * (serial * (theory -> thm list -> thm list))) list,
  25.189 -  posts: thm list
  25.190 -};
  25.191 -
  25.192 -fun mk_thmproc (((inlines, inline_procs), preprocs), posts) =
  25.193 -  Preproc { inlines = inlines, inline_procs = inline_procs, preprocs = preprocs,
  25.194 -    posts = posts };
  25.195 -fun map_thmproc f (Preproc { inlines, inline_procs, preprocs, posts }) =
  25.196 -  mk_thmproc (f (((inlines, inline_procs), preprocs), posts));
  25.197 -fun merge_thmproc (Preproc { inlines = inlines1, inline_procs = inline_procs1,
  25.198 -    preprocs = preprocs1, posts = posts1 },
  25.199 -  Preproc { inlines = inlines2, inline_procs = inline_procs2,
  25.200 -      preprocs = preprocs2, posts= posts2 }) =
  25.201 -    let
  25.202 -      val (touched1, inlines) = merge_thms (inlines1, inlines2);
  25.203 -      val (touched2, inline_procs) = merge_alist (op =) (eq_fst (op =)) (inline_procs1, inline_procs2);
  25.204 -      val (touched3, preprocs) = merge_alist (op =) (eq_fst (op =)) (preprocs1, preprocs2);
  25.205 -      val (_, posts) = merge_thms (posts1, posts2);
  25.206 -    in (touched1 orelse touched2 orelse touched3,
  25.207 -      mk_thmproc (((inlines, inline_procs), preprocs), posts)) end;
  25.208 -
  25.209 -fun join_func_thms (tabs as (tab1, tab2)) =
  25.210 -  let
  25.211 -    val cs1 = Consttab.keys tab1;
  25.212 -    val cs2 = Consttab.keys tab2;
  25.213 -    val cs' = filter (member CodegenConsts.eq_const cs2) cs1;
  25.214 -    val cs'' = subtract (op =) cs' cs1 @ subtract (op =) cs' cs2;
  25.215 -    val cs''' = ref [] : CodegenConsts.const list ref;
  25.216 -    fun merge c x = let val (touched, thms') = merge_sdthms x in
  25.217 -      (if touched then cs''' := cons c (!cs''') else (); thms') end;
  25.218 -  in (cs'' @ !cs''', Consttab.join merge tabs) end;
  25.219 -fun merge_funcs (thms1, thms2) =
  25.220 -  let
  25.221 -    val (consts, thms) = join_func_thms (thms1, thms2);
  25.222 -  in (SOME consts, thms) end;
  25.223 -
  25.224 -val eq_string = op = : string * string -> bool;
  25.225 -val eq_co = op = : (string * typ list) * (string * typ list) -> bool;
  25.226 -fun eq_dtyp ((vs1, cs1), (vs2, cs2)) = 
  25.227 -  gen_eq_set (eq_pair eq_string (gen_eq_set eq_string)) (vs1, vs2)
  25.228 -    andalso gen_eq_set eq_co (cs1, cs2);
  25.229 -fun merge_dtyps (tabs as (tab1, tab2)) =
  25.230 -  let
  25.231 -    val tycos1 = Symtab.keys tab1;
  25.232 -    val tycos2 = Symtab.keys tab2;
  25.233 -    val tycos' = filter (member eq_string tycos2) tycos1;
  25.234 -    val new_types = not (gen_eq_set (op =) (tycos1, tycos2));
  25.235 -    val diff_types = not (gen_eq_set (eq_pair (op =) eq_dtyp)
  25.236 -      (AList.make (the o Symtab.lookup tab1) tycos',
  25.237 -       AList.make (the o Symtab.lookup tab2) tycos'));
  25.238 -    fun join _ (cos as (_, cos2)) = if eq_dtyp cos
  25.239 -      then raise Symtab.SAME else cos2;
  25.240 -  in ((new_types, diff_types), Symtab.join join tabs) end;
  25.241 -
  25.242 -datatype spec = Spec of {
  25.243 -  funcs: sdthms Consttab.table,
  25.244 -  dtyps: ((string * sort) list * (string * typ list) list) Symtab.table
  25.245 -};
  25.246 -
  25.247 -fun mk_spec (funcs, dtyps) =
  25.248 -  Spec { funcs = funcs, dtyps = dtyps };
  25.249 -fun map_spec f (Spec { funcs = funcs, dtyps = dtyps }) =
  25.250 -  mk_spec (f (funcs, dtyps));
  25.251 -fun merge_spec (Spec { funcs = funcs1, dtyps = dtyps1 },
  25.252 -  Spec { funcs = funcs2, dtyps = dtyps2 }) =
  25.253 -  let
  25.254 -    val (touched_cs, funcs) = merge_funcs (funcs1, funcs2);
  25.255 -    val ((new_types, diff_types), dtyps) = merge_dtyps (dtyps1, dtyps2);
  25.256 -    val touched = if new_types orelse diff_types then NONE else touched_cs;
  25.257 -  in (touched, mk_spec (funcs, dtyps)) end;
  25.258 -
  25.259 -datatype exec = Exec of {
  25.260 -  thmproc: thmproc,
  25.261 -  spec: spec
  25.262 -};
  25.263 -
  25.264 -fun mk_exec (thmproc, spec) =
  25.265 -  Exec { thmproc = thmproc, spec = spec };
  25.266 -fun map_exec f (Exec { thmproc = thmproc, spec = spec }) =
  25.267 -  mk_exec (f (thmproc, spec));
  25.268 -fun merge_exec (Exec { thmproc = thmproc1, spec = spec1 },
  25.269 -  Exec { thmproc = thmproc2, spec = spec2 }) =
  25.270 -  let
  25.271 -    val (touched', thmproc) = merge_thmproc (thmproc1, thmproc2);
  25.272 -    val (touched_cs, spec) = merge_spec (spec1, spec2);
  25.273 -    val touched = if touched' then NONE else touched_cs;
  25.274 -  in (touched, mk_exec (thmproc, spec)) end;
  25.275 -val empty_exec = mk_exec (mk_thmproc ((([], []), []), []),
  25.276 -  mk_spec (Consttab.empty, Symtab.empty));
  25.277 -
  25.278 -fun the_thmproc (Exec { thmproc = Preproc x, ...}) = x;
  25.279 -fun the_spec (Exec { spec = Spec x, ...}) = x;
  25.280 -val the_funcs = #funcs o the_spec;
  25.281 -val the_dtyps = #dtyps o the_spec;
  25.282 -val map_thmproc = map_exec o apfst o map_thmproc;
  25.283 -val map_funcs = map_exec o apsnd o map_spec o apfst;
  25.284 -val map_dtyps = map_exec o apsnd o map_spec o apsnd;
  25.285 -
  25.286 -
  25.287 -(* data slots dependent on executable content *)
  25.288 -
  25.289 -(*private copy avoids potential conflict of table exceptions*)
  25.290 -structure Datatab = TableFun(type key = int val ord = int_ord);
  25.291 -
  25.292 -local
  25.293 -
  25.294 -type kind = {
  25.295 -  empty: Object.T,
  25.296 -  merge: Pretty.pp -> Object.T * Object.T -> Object.T,
  25.297 -  purge: theory option -> CodegenConsts.const list option -> Object.T -> Object.T
  25.298 -};
  25.299 -
  25.300 -val kinds = ref (Datatab.empty: kind Datatab.table);
  25.301 -val kind_keys = ref ([]: serial list);
  25.302 -
  25.303 -fun invoke f k = case Datatab.lookup (! kinds) k
  25.304 - of SOME kind => f kind
  25.305 -  | NONE => sys_error "Invalid code data identifier";
  25.306 -
  25.307 -in
  25.308 -
  25.309 -fun declare_data empty merge purge =
  25.310 -  let
  25.311 -    val k = serial ();
  25.312 -    val kind = {empty = empty, merge = merge, purge = purge};
  25.313 -    val _ = change kinds (Datatab.update (k, kind));
  25.314 -    val _ = change kind_keys (cons k);
  25.315 -  in k end;
  25.316 -
  25.317 -fun invoke_empty k = invoke (fn kind => #empty kind) k;
  25.318 -
  25.319 -fun invoke_merge_all pp = Datatab.join
  25.320 -  (invoke (fn kind => #merge kind pp));
  25.321 -
  25.322 -fun invoke_purge_all thy_opt cs =
  25.323 -  fold (fn k => Datatab.map_entry k
  25.324 -    (invoke (fn kind => #purge kind thy_opt cs) k)) (! kind_keys);
  25.325 -
  25.326 -end; (*local*)
  25.327 -
  25.328 -
  25.329 -(* theory store *)
  25.330 -
  25.331 -local
  25.332 -
  25.333 -type data = Object.T Datatab.table;
  25.334 -
  25.335 -structure CodeData = TheoryDataFun
  25.336 -(
  25.337 -  type T = exec * data ref;
  25.338 -  val empty = (empty_exec, ref Datatab.empty : data ref);
  25.339 -  fun copy (exec, data) = (exec, ref (! data));
  25.340 -  val extend = copy;
  25.341 -  fun merge pp ((exec1, data1), (exec2, data2)) =
  25.342 -    let
  25.343 -      val (touched, exec) = merge_exec (exec1, exec2);
  25.344 -      val data1' = invoke_purge_all NONE touched (! data1);
  25.345 -      val data2' = invoke_purge_all NONE touched (! data2);
  25.346 -      val data = invoke_merge_all pp (data1', data2');
  25.347 -    in (exec, ref data) end;
  25.348 -);
  25.349 -
  25.350 -val _ = Context.add_setup CodeData.init;
  25.351 -
  25.352 -fun ch r f = let val x = f (! r) in (r := x; x) end;
  25.353 -fun thy_data f thy = f ((snd o CodeData.get) thy);
  25.354 -
  25.355 -fun get_ensure_init kind data_ref =
  25.356 -  case Datatab.lookup (! data_ref) kind
  25.357 -   of SOME x => x
  25.358 -    | NONE => let val y = invoke_empty kind
  25.359 -        in (change data_ref (Datatab.update (kind, y)); y) end;
  25.360 -
  25.361 -in
  25.362 -
  25.363 -(* access to executable content *)
  25.364 -
  25.365 -val get_exec = fst o CodeData.get;
  25.366 -
  25.367 -fun map_exec_purge touched f thy =
  25.368 -  CodeData.map (fn (exec, data) => 
  25.369 -    (f exec, ref (invoke_purge_all (SOME thy) touched (! data)))) thy;
  25.370 -
  25.371 -
  25.372 -(* access to data dependent on abstract executable content *)
  25.373 -
  25.374 -fun get_data (kind, _, dest) = thy_data (get_ensure_init kind #> dest);
  25.375 -
  25.376 -fun change_data (kind, mk, dest) =
  25.377 -  let
  25.378 -    fun chnge data_ref f =
  25.379 -      let
  25.380 -        val data = get_ensure_init kind data_ref;
  25.381 -        val data' = f (dest data);
  25.382 -      in (change data_ref (Datatab.update (kind, mk data')); data') end;
  25.383 -  in thy_data chnge end;
  25.384 -
  25.385 -fun change_yield_data (kind, mk, dest) =
  25.386 -  let
  25.387 -    fun chnge data_ref f =
  25.388 -      let
  25.389 -        val data = get_ensure_init kind data_ref;
  25.390 -        val (x, data') = f (dest data);
  25.391 -      in (x, (change data_ref (Datatab.update (kind, mk data')); data')) end;
  25.392 -  in thy_data chnge end;
  25.393 -
  25.394 -end; (*local*)
  25.395 -
  25.396 -
  25.397 -(* print executable content *)
  25.398 -
  25.399 -fun print_codesetup thy =
  25.400 -  let
  25.401 -    val ctxt = ProofContext.init thy;
  25.402 -    val exec = get_exec thy;
  25.403 -    fun pretty_func (s, lthms) =
  25.404 -      (Pretty.block o Pretty.fbreaks) (
  25.405 -        Pretty.str s :: pretty_sdthms ctxt lthms
  25.406 -      );
  25.407 -    fun pretty_dtyp (s, []) =
  25.408 -          Pretty.str s
  25.409 -      | pretty_dtyp (s, cos) =
  25.410 -          (Pretty.block o Pretty.breaks) (
  25.411 -            Pretty.str s
  25.412 -            :: Pretty.str "="
  25.413 -            :: separate (Pretty.str "|") (map (fn (c, []) => Pretty.str c
  25.414 -                 | (c, tys) =>
  25.415 -                     (Pretty.block o Pretty.breaks)
  25.416 -                        (Pretty.str c :: Pretty.str "of" :: map (Pretty.quote o Sign.pretty_typ thy) tys)) cos)
  25.417 -          );
  25.418 -    val inlines = (#inlines o the_thmproc) exec;
  25.419 -    val inline_procs = (map fst o #inline_procs o the_thmproc) exec;
  25.420 -    val preprocs = (map fst o #preprocs o the_thmproc) exec;
  25.421 -    val funs = the_funcs exec
  25.422 -      |> Consttab.dest
  25.423 -      |> (map o apfst) (CodegenConsts.string_of_const thy)
  25.424 -      |> sort (string_ord o pairself fst);
  25.425 -    val dtyps = the_dtyps exec
  25.426 -      |> Symtab.dest
  25.427 -      |> map (fn (dtco, (vs, cos)) => (Sign.string_of_typ thy (Type (dtco, map TFree vs)), cos))
  25.428 -      |> sort (string_ord o pairself fst)
  25.429 -  in
  25.430 -    (Pretty.writeln o Pretty.chunks) [
  25.431 -      Pretty.block (
  25.432 -        Pretty.str "defining equations:"
  25.433 -        :: Pretty.fbrk
  25.434 -        :: (Pretty.fbreaks o map pretty_func) funs
  25.435 -      ),
  25.436 -      Pretty.block (
  25.437 -        Pretty.str "inlining theorems:"
  25.438 -        :: Pretty.fbrk
  25.439 -        :: (Pretty.fbreaks o map (ProofContext.pretty_thm ctxt)) inlines
  25.440 -      ),
  25.441 -      Pretty.block (
  25.442 -        Pretty.str "inlining procedures:"
  25.443 -        :: Pretty.fbrk
  25.444 -        :: (Pretty.fbreaks o map Pretty.str) inline_procs
  25.445 -      ),
  25.446 -      Pretty.block (
  25.447 -        Pretty.str "preprocessors:"
  25.448 -        :: Pretty.fbrk
  25.449 -        :: (Pretty.fbreaks o map Pretty.str) preprocs
  25.450 -      ),
  25.451 -      Pretty.block (
  25.452 -        Pretty.str "datatypes:"
  25.453 -        :: Pretty.fbrk
  25.454 -        :: (Pretty.fbreaks o map pretty_dtyp) dtyps
  25.455 -      )
  25.456 -    ]
  25.457 -  end;
  25.458 -
  25.459 -
  25.460 -
  25.461 -(** theorem transformation and certification **)
  25.462 -
  25.463 -fun common_typ_funcs [] = []
  25.464 -  | common_typ_funcs [thm] = [thm]
  25.465 -  | common_typ_funcs (thms as thm :: _) =
  25.466 -      let
  25.467 -        val thy = Thm.theory_of_thm thm;
  25.468 -        fun incr_thm thm max =
  25.469 -          let
  25.470 -            val thm' = incr_indexes max thm;
  25.471 -            val max' = Thm.maxidx_of thm' + 1;
  25.472 -          in (thm', max') end;
  25.473 -        val (thms', maxidx) = fold_map incr_thm thms 0;
  25.474 -        val ty1 :: tys = map (snd o CodegenFunc.head_func) thms';
  25.475 -        fun unify ty env = Sign.typ_unify thy (ty1, ty) env
  25.476 -          handle Type.TUNIFY =>
  25.477 -            error ("Type unificaton failed, while unifying defining equations\n"
  25.478 -            ^ (cat_lines o map Display.string_of_thm) thms
  25.479 -            ^ "\nwith types\n"
  25.480 -            ^ (cat_lines o map (CodegenConsts.string_of_typ thy)) (ty1 :: tys));
  25.481 -        val (env, _) = fold unify tys (Vartab.empty, maxidx)
  25.482 -        val instT = Vartab.fold (fn (x_i, (sort, ty)) =>
  25.483 -          cons (Thm.ctyp_of thy (TVar (x_i, sort)), Thm.ctyp_of thy ty)) env [];
  25.484 -      in map (Thm.instantiate (instT, [])) thms' end;
  25.485 -
  25.486 -fun certify_const thy const thms =
  25.487 -  let
  25.488 -    fun cert thm = if CodegenConsts.eq_const (const, fst (CodegenFunc.head_func thm))
  25.489 -      then thm else error ("Wrong head of defining equation,\nexpected constant "
  25.490 -        ^ CodegenConsts.string_of_const thy const ^ "\n" ^ string_of_thm thm)
  25.491 -  in map cert thms end;
  25.492 -
  25.493 -
  25.494 -
  25.495 -(** operational sort algebra and class discipline **)
  25.496 -
  25.497 -local
  25.498 -
  25.499 -fun aggr_neutr f y [] = y
  25.500 -  | aggr_neutr f y (x::xs) = aggr_neutr f (f y x) xs;
  25.501 -
  25.502 -fun aggregate f [] = NONE
  25.503 -  | aggregate f (x::xs) = SOME (aggr_neutr f x xs);
  25.504 -
  25.505 -fun inter_sorts thy =
  25.506 -  let
  25.507 -    val algebra = Sign.classes_of thy;
  25.508 -    val inters = curry (Sorts.inter_sort algebra);
  25.509 -  in aggregate (map2 inters) end;
  25.510 -
  25.511 -fun specific_constraints thy (class, tyco) =
  25.512 -  let
  25.513 -    val vs = Name.invents Name.context "" (Sign.arity_number thy tyco);
  25.514 -    val clsops = (these o Option.map snd o try (AxClass.params_of_class thy)) class;
  25.515 -    val funcs = clsops
  25.516 -      |> map (fn (clsop, _) => (clsop, SOME tyco))
  25.517 -      |> map (Consttab.lookup ((the_funcs o get_exec) thy))
  25.518 -      |> (map o Option.map) (Susp.force o fst)
  25.519 -      |> maps these
  25.520 -      |> map (Thm.transfer thy);
  25.521 -    val sorts = map (map (snd o dest_TVar) o snd o dest_Type o the_single
  25.522 -      o Sign.const_typargs thy o (fn ((c, _), ty) => (c, ty)) o CodegenFunc.head_func) funcs;
  25.523 -  in sorts end;
  25.524 -
  25.525 -fun weakest_constraints thy (class, tyco) =
  25.526 -  let
  25.527 -    val all_superclasses = class :: Graph.all_succs ((#classes o Sorts.rep_algebra o Sign.classes_of) thy) [class];
  25.528 -  in case inter_sorts thy (maps (fn class => specific_constraints thy (class, tyco)) all_superclasses)
  25.529 -   of SOME sorts => sorts
  25.530 -    | NONE => Sign.arity_sorts thy tyco [class]
  25.531 -  end;
  25.532 -
  25.533 -fun strongest_constraints thy (class, tyco) =
  25.534 -  let
  25.535 -    val algebra = Sign.classes_of thy;
  25.536 -    val all_subclasses = class :: Graph.all_preds ((#classes o Sorts.rep_algebra) algebra) [class];
  25.537 -    val inst_subclasses = filter (can (Sorts.mg_domain algebra tyco) o single) all_subclasses;
  25.538 -  in case inter_sorts thy (maps (fn class => specific_constraints thy (class, tyco)) inst_subclasses)
  25.539 -   of SOME sorts => sorts
  25.540 -    | NONE => replicate
  25.541 -        (Sign.arity_number thy tyco) (Sign.certify_sort thy (Sign.all_classes thy))
  25.542 -  end;
  25.543 -
  25.544 -fun gen_classop_typ constr thy class (c, tyco) = 
  25.545 -  let
  25.546 -    val (var, cs) = try (AxClass.params_of_class thy) class |> the_default ("'a", [])
  25.547 -    val ty = (the o AList.lookup (op =) cs) c;
  25.548 -    val sort_args = Name.names (Name.declare var Name.context) "'a"
  25.549 -      (constr thy (class, tyco));
  25.550 -    val ty_inst = Type (tyco, map TFree sort_args);
  25.551 -  in Logic.varifyT (map_type_tfree (K ty_inst) ty) end;
  25.552 -
  25.553 -fun retrieve_algebra thy operational =
  25.554 -  Sorts.subalgebra (Sign.pp thy) operational
  25.555 -    (weakest_constraints thy)
  25.556 -    (Sign.classes_of thy);
  25.557 -
  25.558 -in
  25.559 -
  25.560 -fun coregular_algebra thy = retrieve_algebra thy (K true) |> snd;
  25.561 -fun operational_algebra thy =
  25.562 -  let
  25.563 -    fun add_iff_operational class =
  25.564 -      can (AxClass.get_definition thy) class ? cons class;
  25.565 -    val operational_classes = fold add_iff_operational (Sign.all_classes thy) []
  25.566 -  in retrieve_algebra thy (member (op =) operational_classes) end;
  25.567 -
  25.568 -val classop_weakest_typ = gen_classop_typ weakest_constraints;
  25.569 -val classop_strongest_typ = gen_classop_typ strongest_constraints;
  25.570 -
  25.571 -fun assert_func_typ thm =
  25.572 -  let
  25.573 -    val thy = Thm.theory_of_thm thm;
  25.574 -    fun check_typ_classop class (const as (c, SOME tyco), thm) =
  25.575 -          let
  25.576 -            val (_, ty) = CodegenFunc.head_func thm;
  25.577 -            val ty_decl = classop_weakest_typ thy class (c, tyco);
  25.578 -            val ty_strongest = classop_strongest_typ thy class (c, tyco);
  25.579 -            fun constrain thm = 
  25.580 -              let
  25.581 -                val max = Thm.maxidx_of thm + 1;
  25.582 -                val ty_decl' = Logic.incr_tvar max ty_decl;
  25.583 -                val (_, ty') = CodegenFunc.head_func thm;
  25.584 -                val (env, _) = Sign.typ_unify thy (ty_decl', ty') (Vartab.empty, max);
  25.585 -                val instT = Vartab.fold (fn (x_i, (sort, ty)) =>
  25.586 -                  cons (Thm.ctyp_of thy (TVar (x_i, sort)), Thm.ctyp_of thy ty)) env [];
  25.587 -              in Thm.instantiate (instT, []) thm end;
  25.588 -          in if Sign.typ_instance thy (ty_strongest, ty)
  25.589 -            then if Sign.typ_instance thy (ty, ty_decl)
  25.590 -            then thm
  25.591 -            else (warning ("Constraining type\n" ^ CodegenConsts.string_of_typ thy ty
  25.592 -              ^ "\nof defining equation\n"
  25.593 -              ^ string_of_thm thm
  25.594 -              ^ "\nto permitted most general type\n"
  25.595 -              ^ CodegenConsts.string_of_typ thy ty_decl);
  25.596 -              constrain thm)
  25.597 -            else CodegenFunc.bad_thm ("Type\n" ^ CodegenConsts.string_of_typ thy ty
  25.598 -              ^ "\nof defining equation\n"
  25.599 -              ^ string_of_thm thm
  25.600 -              ^ "\nis incompatible with permitted least general type\n"
  25.601 -              ^ CodegenConsts.string_of_typ thy ty_strongest)
  25.602 -          end
  25.603 -      | check_typ_classop class ((c, NONE), thm) =
  25.604 -          CodegenFunc.bad_thm ("Illegal type for class operation " ^ quote c
  25.605 -           ^ "\nin defining equation\n"
  25.606 -           ^ string_of_thm thm);
  25.607 -    fun check_typ_fun (const as (c, _), thm) =
  25.608 -      let
  25.609 -        val (_, ty) = CodegenFunc.head_func thm;
  25.610 -        val ty_decl = Sign.the_const_type thy c;
  25.611 -      in if Sign.typ_equiv thy (Type.strip_sorts ty_decl, Type.strip_sorts ty)
  25.612 -        then thm
  25.613 -        else CodegenFunc.bad_thm ("Type\n" ^ CodegenConsts.string_of_typ thy ty
  25.614 -           ^ "\nof defining equation\n"
  25.615 -           ^ string_of_thm thm
  25.616 -           ^ "\nis incompatible with declared function type\n"
  25.617 -           ^ CodegenConsts.string_of_typ thy ty_decl)
  25.618 -      end;
  25.619 -    fun check_typ (const as (c, _), thm) =
  25.620 -      case AxClass.class_of_param thy c
  25.621 -       of SOME class => check_typ_classop class (const, thm)
  25.622 -        | NONE => check_typ_fun (const, thm);
  25.623 -  in check_typ (fst (CodegenFunc.head_func thm), thm) end;
  25.624 -
  25.625 -val mk_func = CodegenFunc.error_thm
  25.626 -  (assert_func_typ o CodegenFunc.mk_func);
  25.627 -val mk_func_liberal = CodegenFunc.warning_thm
  25.628 -  (assert_func_typ o CodegenFunc.mk_func);
  25.629 -
  25.630 -end;
  25.631 -
  25.632 -
  25.633 -
  25.634 -(** interfaces **)
  25.635 -
  25.636 -fun add_func true thm thy =
  25.637 -      let
  25.638 -        val func = mk_func thm;
  25.639 -        val (const, _) = CodegenFunc.head_func func;
  25.640 -      in map_exec_purge (SOME [const]) (map_funcs
  25.641 -        (Consttab.map_default
  25.642 -          (const, (Susp.value [], [])) (add_thm func))) thy
  25.643 -      end
  25.644 -  | add_func false thm thy =
  25.645 -      case mk_func_liberal thm
  25.646 -       of SOME func => let
  25.647 -              val (const, _) = CodegenFunc.head_func func
  25.648 -            in map_exec_purge (SOME [const]) (map_funcs
  25.649 -              (Consttab.map_default
  25.650 -                (const, (Susp.value [], [])) (add_thm func))) thy
  25.651 -            end
  25.652 -        | NONE => thy;
  25.653 -
  25.654 -fun delete_force msg key xs =
  25.655 -  if AList.defined (op =) xs key then AList.delete (op =) key xs
  25.656 -  else error ("No such " ^ msg ^ ": " ^ quote key);
  25.657 -
  25.658 -fun del_func thm thy =
  25.659 -  let
  25.660 -    val func = mk_func thm;
  25.661 -    val (const, _) = CodegenFunc.head_func func;
  25.662 -  in map_exec_purge (SOME [const]) (map_funcs
  25.663 -    (Consttab.map_entry
  25.664 -      const (del_thm func))) thy
  25.665 -  end;
  25.666 -
  25.667 -fun add_funcl (const, lthms) thy =
  25.668 -  let
  25.669 -    val lthms' = certificate thy (fn thy => certify_const thy const) lthms;
  25.670 -      (*FIXME must check compatibility with sort algebra;
  25.671 -        alas, naive checking results in non-termination!*)
  25.672 -  in
  25.673 -    map_exec_purge (SOME [const]) (map_funcs (Consttab.map_default (const, (Susp.value [], []))
  25.674 -      (add_lthms lthms'))) thy
  25.675 -  end;
  25.676 -
  25.677 -fun add_func_attr strict = Attrib.internal (fn _ => Thm.declaration_attribute
  25.678 -  (fn thm => Context.mapping (add_func strict thm) I));
  25.679 -
  25.680 -local
  25.681 -
  25.682 -fun del_datatype tyco thy =
  25.683 -  case Symtab.lookup ((the_dtyps o get_exec) thy) tyco
  25.684 -   of SOME (vs, cos) => let
  25.685 -        val consts = CodegenConsts.consts_of_cos thy tyco vs cos;
  25.686 -      in map_exec_purge (if null consts then NONE else SOME consts)
  25.687 -        (map_dtyps (Symtab.delete tyco)) thy end
  25.688 -    | NONE => thy;
  25.689 -
  25.690 -in
  25.691 -
  25.692 -fun add_datatype (tyco, (vs_cos as (vs, cos))) thy =
  25.693 -  let
  25.694 -    val consts = CodegenConsts.consts_of_cos thy tyco vs cos;
  25.695 -  in
  25.696 -    thy
  25.697 -    |> del_datatype tyco
  25.698 -    |> map_exec_purge (SOME consts) (map_dtyps (Symtab.update_new (tyco, vs_cos)))
  25.699 -  end;
  25.700 -
  25.701 -fun add_datatype_consts consts thy =
  25.702 -  add_datatype (CodegenConsts.cos_of_consts thy consts) thy;
  25.703 -
  25.704 -fun add_datatype_consts_cmd raw_cs thy =
  25.705 -  add_datatype_consts (map (CodegenConsts.read_const thy) raw_cs) thy
  25.706 -
  25.707 -end; (*local*)
  25.708 -
  25.709 -fun add_inline thm thy =
  25.710 -  (map_exec_purge NONE o map_thmproc o apfst o apfst o apfst)
  25.711 -    (insert Thm.eq_thm_prop (CodegenFunc.error_thm CodegenFunc.mk_rew thm)) thy;
  25.712 -        (*fully applied in order to get right context for mk_rew!*)
  25.713 -
  25.714 -fun del_inline thm thy =
  25.715 -  (map_exec_purge NONE o map_thmproc o apfst o apfst o apfst)
  25.716 -    (remove Thm.eq_thm_prop (CodegenFunc.error_thm CodegenFunc.mk_rew thm)) thy;
  25.717 -        (*fully applied in order to get right context for mk_rew!*)
  25.718 -
  25.719 -fun add_inline_proc (name, f) =
  25.720 -  (map_exec_purge NONE o map_thmproc o apfst o apfst o apsnd)
  25.721 -    (AList.update (op =) (name, (serial (), f)));
  25.722 -
  25.723 -fun del_inline_proc name =
  25.724 -  (map_exec_purge NONE o map_thmproc o apfst o apfst o apsnd)
  25.725 -    (delete_force "inline procedure" name);
  25.726 -
  25.727 -fun add_preproc (name, f) =
  25.728 -  (map_exec_purge NONE o map_thmproc o apfst o apsnd)
  25.729 -    (AList.update (op =) (name, (serial (), f)));
  25.730 -
  25.731 -fun del_preproc name =
  25.732 -  (map_exec_purge NONE o map_thmproc o apfst o apsnd)
  25.733 -    (delete_force "preprocessor" name);
  25.734 -
  25.735 -fun add_post thm thy =
  25.736 -  (map_exec_purge NONE o map_thmproc o apsnd)
  25.737 -    (insert Thm.eq_thm_prop (CodegenFunc.error_thm CodegenFunc.mk_rew thm)) thy;
  25.738 -        (*fully applied in order to get right context for mk_rew!*)
  25.739 -
  25.740 -fun del_post thm thy =
  25.741 -  (map_exec_purge NONE o map_thmproc o apsnd)
  25.742 -    (remove Thm.eq_thm_prop (CodegenFunc.error_thm CodegenFunc.mk_rew thm)) thy;
  25.743 -        (*fully applied in order to get right context for mk_rew!*)
  25.744 -
  25.745 -
  25.746 -(** , post- and preprocessing **)
  25.747 -
  25.748 -local
  25.749 -
  25.750 -fun gen_apply_inline_proc prep post thy f x =
  25.751 -  let
  25.752 -    val cts = prep x;
  25.753 -    val rews = map CodegenFunc.assert_rew (f thy cts);
  25.754 -  in post rews x end;
  25.755 -
  25.756 -val apply_inline_proc = gen_apply_inline_proc (maps
  25.757 -  ((fn [args, rhs] => rhs :: (snd o Drule.strip_comb) args) o snd o Drule.strip_comb o Thm.cprop_of))
  25.758 -  (fn rews => map (CodegenFunc.rewrite_func rews));
  25.759 -val apply_inline_proc_cterm = gen_apply_inline_proc single
  25.760 -  (MetaSimplifier.rewrite false);
  25.761 -
  25.762 -fun apply_preproc thy f [] = []
  25.763 -  | apply_preproc thy f (thms as (thm :: _)) =
  25.764 -      let
  25.765 -        val (const, _) = CodegenFunc.head_func thm;
  25.766 -        val thms' = f thy thms;
  25.767 -      in certify_const thy const thms' end;
  25.768 -
  25.769 -fun rhs_conv conv thm =
  25.770 -  let
  25.771 -    val thm' = (conv o Thm.rhs_of) thm;
  25.772 -  in Thm.transitive thm thm' end
  25.773 -
  25.774 -in
  25.775 -
  25.776 -fun preprocess thy thms =
  25.777 -  thms
  25.778 -  |> fold (fn (_, (_, f)) => apply_preproc thy f) ((#preprocs o the_thmproc o get_exec) thy)
  25.779 -  |> map (CodegenFunc.rewrite_func ((#inlines o the_thmproc o get_exec) thy))
  25.780 -  |> fold (fn (_, (_, f)) => apply_inline_proc thy f) ((#inline_procs o the_thmproc o get_exec) thy)
  25.781 -(*FIXME - must check: rewrite rule, defining equation, proper constant |> map (snd o check_func false thy) *)
  25.782 -  |> common_typ_funcs;
  25.783 -
  25.784 -fun preprocess_conv ct =
  25.785 -  let
  25.786 -    val thy = Thm.theory_of_cterm ct;
  25.787 -  in
  25.788 -    ct
  25.789 -    |> MetaSimplifier.rewrite false ((#inlines o the_thmproc o get_exec) thy)
  25.790 -    |> fold (fn (_, (_, f)) => rhs_conv (apply_inline_proc_cterm thy f))
  25.791 -        ((#inline_procs o the_thmproc o get_exec) thy)
  25.792 -  end;
  25.793 -
  25.794 -fun postprocess_conv ct =
  25.795 -  let
  25.796 -    val thy = Thm.theory_of_cterm ct;
  25.797 -  in
  25.798 -    ct
  25.799 -    |> MetaSimplifier.rewrite false ((#posts o the_thmproc o get_exec) thy)
  25.800 -  end;
  25.801 -
  25.802 -end; (*local*)
  25.803 -
  25.804 -fun get_datatype thy tyco =
  25.805 -  case Symtab.lookup ((the_dtyps o get_exec) thy) tyco
  25.806 -   of SOME spec => spec
  25.807 -    | NONE => Sign.arity_number thy tyco
  25.808 -        |> Name.invents Name.context "'a"
  25.809 -        |> map (rpair [])
  25.810 -        |> rpair [];
  25.811 -
  25.812 -fun get_datatype_of_constr thy const =
  25.813 -  case CodegenConsts.co_of_const' thy const
  25.814 -   of SOME (tyco, (_, co)) => if member eq_co
  25.815 -        (Symtab.lookup (((the_dtyps o get_exec) thy)) tyco
  25.816 -          |> Option.map snd
  25.817 -          |> the_default []) co then SOME tyco else NONE
  25.818 -    | NONE => NONE;
  25.819 -
  25.820 -fun get_constr_typ thy const =
  25.821 -  case get_datatype_of_constr thy const
  25.822 -   of SOME tyco => let
  25.823 -        val (vs, cos) = get_datatype thy tyco;
  25.824 -        val (_, (_, (co, tys))) = CodegenConsts.co_of_const thy const
  25.825 -      in (tys ---> Type (tyco, map TFree vs))
  25.826 -        |> map_atyps (fn TFree (v, _) => TFree (v, AList.lookup (op =) vs v |> the))
  25.827 -        |> Logic.varifyT
  25.828 -        |> SOME end
  25.829 -    | NONE => NONE;
  25.830 -
  25.831 -fun default_typ_proto thy (const as (c, SOME tyco)) = classop_weakest_typ thy
  25.832 -      ((the o AxClass.class_of_param thy) c) (c, tyco) |> SOME
  25.833 -  | default_typ_proto thy (const as (c, NONE)) = case AxClass.class_of_param thy c
  25.834 -       of SOME class => SOME (Term.map_type_tvar
  25.835 -            (K (TVar (("'a", 0), [class]))) (Sign.the_const_type thy c))
  25.836 -        | NONE => get_constr_typ thy const;
  25.837 -
  25.838 -local
  25.839 -
  25.840 -fun get_funcs thy const =
  25.841 -  Consttab.lookup ((the_funcs o get_exec) thy) const
  25.842 -  |> Option.map (Susp.force o fst)
  25.843 -  |> these
  25.844 -  |> map (Thm.transfer thy);
  25.845 -
  25.846 -in
  25.847 -
  25.848 -fun these_funcs thy const =
  25.849 -  let
  25.850 -    fun drop_refl thy = filter_out (is_equal o Term.fast_term_ord o Logic.dest_equals
  25.851 -      o ObjectLogic.drop_judgment thy o Thm.plain_prop_of);
  25.852 -  in
  25.853 -    get_funcs thy const
  25.854 -    |> preprocess thy
  25.855 -    |> drop_refl thy
  25.856 -  end;
  25.857 -
  25.858 -fun default_typ thy (const as (c, _)) = case default_typ_proto thy const
  25.859 - of SOME ty => ty
  25.860 -  | NONE => (case get_funcs thy const
  25.861 -     of thm :: _ => snd (CodegenFunc.head_func thm)
  25.862 -      | [] => Sign.the_const_type thy c);
  25.863 -
  25.864 -end; (*local*)
  25.865 -
  25.866 -end; (*struct*)
  25.867 -
  25.868 -
  25.869 -(** type-safe interfaces for data depedent on executable content **)
  25.870 -
  25.871 -functor CodeDataFun(Data: CODE_DATA_ARGS): CODE_DATA =
  25.872 -struct
  25.873 -
  25.874 -type T = Data.T;
  25.875 -exception Data of T;
  25.876 -fun dest (Data x) = x
  25.877 -
  25.878 -val kind = CodegenData.declare_data (Data Data.empty)
  25.879 -  (fn pp => fn (Data x1, Data x2) => Data (Data.merge pp (x1, x2)))
  25.880 -  (fn thy_opt => fn cs => fn Data x => Data (Data.purge thy_opt cs x));
  25.881 -
  25.882 -val data_op = (kind, Data, dest);
  25.883 -
  25.884 -val get = CodegenData.get_data data_op;
  25.885 -val change = CodegenData.change_data data_op;
  25.886 -fun change_yield thy = CodegenData.change_yield_data data_op thy;
  25.887 -
  25.888 -end;
  25.889 -
  25.890 -structure CodegenData : CODEGEN_DATA =
  25.891 -struct
  25.892 -
  25.893 -open CodegenData;
  25.894 -
  25.895 -end;
    26.1 --- a/src/Pure/Tools/codegen_func.ML	Fri Aug 10 17:04:24 2007 +0200
    26.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    26.3 @@ -1,252 +0,0 @@
    26.4 -(*  Title:      Pure/Tools/codegen_func.ML
    26.5 -    ID:         $Id$
    26.6 -    Author:     Florian Haftmann, TU Muenchen
    26.7 -
    26.8 -Basic handling of defining equations ("func"s) for code generator framework.
    26.9 -*)
   26.10 -
   26.11 -signature CODEGEN_FUNC =
   26.12 -sig
   26.13 -  val assert_rew: thm -> thm
   26.14 -  val mk_rew: thm -> thm
   26.15 -  val mk_func: thm -> thm
   26.16 -  val head_func: thm -> CodegenConsts.const * typ
   26.17 -  val bad_thm: string -> 'a
   26.18 -  val error_thm: (thm -> thm) -> thm -> thm
   26.19 -  val warning_thm: (thm -> thm) -> thm -> thm option
   26.20 -
   26.21 -  val inst_thm: sort Vartab.table -> thm -> thm
   26.22 -  val expand_eta: int -> thm -> thm
   26.23 -  val rewrite_func: thm list -> thm -> thm
   26.24 -  val norm_args: thm list -> thm list 
   26.25 -  val norm_varnames: (string -> string) -> (string -> string) -> thm list -> thm list 
   26.26 -end;
   26.27 -
   26.28 -structure CodegenFunc : CODEGEN_FUNC =
   26.29 -struct
   26.30 -
   26.31 -
   26.32 -(* auxiliary *)
   26.33 -
   26.34 -exception BAD_THM of string;
   26.35 -fun bad_thm msg = raise BAD_THM msg;
   26.36 -fun error_thm f thm = f thm handle BAD_THM msg => error msg;
   26.37 -fun warning_thm f thm = SOME (f thm) handle BAD_THM msg
   26.38 -  => (warning ("code generator: " ^ msg); NONE);
   26.39 -
   26.40 -
   26.41 -(* making rewrite theorems *)
   26.42 -
   26.43 -fun assert_rew thm =
   26.44 -  let
   26.45 -    val thy = Thm.theory_of_thm thm;
   26.46 -    val (lhs, rhs) = (Logic.dest_equals o Thm.plain_prop_of) thm
   26.47 -      handle TERM _ => bad_thm ("Not an equation: " ^ Display.string_of_thm thm)
   26.48 -          | THM _ => bad_thm ("Not an equation: " ^ Display.string_of_thm thm);
   26.49 -    fun vars_of t = fold_aterms
   26.50 -     (fn Var (v, _) => insert (op =) v
   26.51 -       | Free _ => bad_thm ("Illegal free variable in rewrite theorem\n"
   26.52 -           ^ Display.string_of_thm thm)
   26.53 -       | _ => I) t [];
   26.54 -    fun tvars_of t = fold_term_types
   26.55 -     (fn _ => fold_atyps (fn TVar (v, _) => insert (op =) v
   26.56 -                          | TFree _ => bad_thm 
   26.57 -      ("Illegal free type variable in rewrite theorem\n" ^ Display.string_of_thm thm))) t [];
   26.58 -    val lhs_vs = vars_of lhs;
   26.59 -    val rhs_vs = vars_of rhs;
   26.60 -    val lhs_tvs = tvars_of lhs;
   26.61 -    val rhs_tvs = tvars_of lhs;
   26.62 -    val _ = if null (subtract (op =) lhs_vs rhs_vs)
   26.63 -      then ()
   26.64 -      else bad_thm ("Free variables on right hand side of rewrite theorem\n"
   26.65 -        ^ Display.string_of_thm thm);
   26.66 -    val _ = if null (subtract (op =) lhs_tvs rhs_tvs)
   26.67 -      then ()
   26.68 -      else bad_thm ("Free type variables on right hand side of rewrite theorem\n"
   26.69 -        ^ Display.string_of_thm thm)
   26.70 -  in thm end;
   26.71 -
   26.72 -fun mk_rew thm =
   26.73 -  let
   26.74 -    val thy = Thm.theory_of_thm thm;
   26.75 -    val ctxt = ProofContext.init thy;
   26.76 -  in
   26.77 -    thm
   26.78 -    |> LocalDefs.meta_rewrite_rule ctxt
   26.79 -    |> assert_rew
   26.80 -  end;
   26.81 -
   26.82 -
   26.83 -(* making defining equations *)
   26.84 -
   26.85 -fun assert_func thm =
   26.86 -  let
   26.87 -    val thy = Thm.theory_of_thm thm;
   26.88 -    val (head, args) = (strip_comb o fst o Logic.dest_equals
   26.89 -      o ObjectLogic.drop_judgment thy o Thm.plain_prop_of) thm;
   26.90 -    val _ = case head of Const _ => () | _ =>
   26.91 -      bad_thm ("Equation not headed by constant\n" ^ Display.string_of_thm thm);
   26.92 -    val _ =
   26.93 -      if has_duplicates (op =)
   26.94 -        ((fold o fold_aterms) (fn Var (v, _) => cons v
   26.95 -          | _ => I
   26.96 -        ) args [])
   26.97 -      then bad_thm ("Duplicated variables on left hand side of equation\n"
   26.98 -        ^ Display.string_of_thm thm)
   26.99 -      else ()
  26.100 -    fun check _ (Abs _) = bad_thm
  26.101 -          ("Abstraction on left hand side of equation\n"
  26.102 -            ^ Display.string_of_thm thm)
  26.103 -      | check 0 (Var _) = ()
  26.104 -      | check _ (Var _) = bad_thm
  26.105 -          ("Variable with application on left hand side of defining equation\n"
  26.106 -            ^ Display.string_of_thm thm)
  26.107 -      | check n (t1 $ t2) = (check (n+1) t1; check 0 t2)
  26.108 -      | check n (Const (_, ty)) = if n <> (length o fst o strip_type) ty
  26.109 -          then bad_thm
  26.110 -            ("Partially applied constant on left hand side of equation\n"
  26.111 -               ^ Display.string_of_thm thm)
  26.112 -          else ();
  26.113 -    val _ = map (check 0) args;
  26.114 -  in thm end;
  26.115 -
  26.116 -val mk_func = assert_func o mk_rew;
  26.117 -
  26.118 -fun head_func thm =
  26.119 -  let
  26.120 -    val thy = Thm.theory_of_thm thm;
  26.121 -    val (Const (c_ty as (_, ty))) = (fst o strip_comb o fst o Logic.dest_equals
  26.122 -      o ObjectLogic.drop_judgment thy o Thm.plain_prop_of) thm;
  26.123 -    val const = CodegenConsts.const_of_cexpr thy c_ty;
  26.124 -  in (const, ty) end;
  26.125 -
  26.126 -
  26.127 -(* utilities *)
  26.128 -
  26.129 -fun inst_thm tvars' thm =
  26.130 -  let
  26.131 -    val thy = Thm.theory_of_thm thm;
  26.132 -    val tvars = (Term.add_tvars o Thm.prop_of) thm [];
  26.133 -    fun mk_inst (tvar as (v, _)) = case Vartab.lookup tvars' v
  26.134 -     of SOME sort => SOME (pairself (Thm.ctyp_of thy o TVar) (tvar, (v, sort)))
  26.135 -      | NONE => NONE;
  26.136 -    val insts = map_filter mk_inst tvars;
  26.137 -  in Thm.instantiate (insts, []) thm end;
  26.138 -
  26.139 -fun expand_eta k thm =
  26.140 -  let
  26.141 -    val thy = Thm.theory_of_thm thm;
  26.142 -    val (lhs, rhs) = (Logic.dest_equals o Thm.plain_prop_of) thm;
  26.143 -    val (head, args) = strip_comb lhs;
  26.144 -    val l = if k = ~1
  26.145 -      then (length o fst o strip_abs) rhs
  26.146 -      else Int.max (0, k - length args);
  26.147 -    val used = Name.make_context (map (fst o fst) (Term.add_vars lhs []));
  26.148 -    fun get_name _ 0 used = ([], used)
  26.149 -      | get_name (Abs (v, ty, t)) k used =
  26.150 -          used
  26.151 -          |> Name.variants [v]
  26.152 -          ||>> get_name t (k - 1)
  26.153 -          |>> (fn ([v'], vs') => (v', ty) :: vs')
  26.154 -      | get_name t k used = 
  26.155 -          let
  26.156 -            val (tys, _) = (strip_type o fastype_of) t
  26.157 -          in case tys
  26.158 -           of [] => raise TERM ("expand_eta", [t])
  26.159 -            | ty :: _ =>
  26.160 -                used
  26.161 -                |> Name.variants [""]
  26.162 -                |-> (fn [v] => get_name (t $ Var ((v, 0), ty)) (k - 1)
  26.163 -                #>> (fn vs' => (v, ty) :: vs'))
  26.164 -          end;
  26.165 -    val (vs, _) = get_name rhs l used;
  26.166 -    val vs_refl = map (fn (v, ty) => Thm.reflexive (Thm.cterm_of thy (Var ((v, 0), ty)))) vs;
  26.167 -  in
  26.168 -    thm
  26.169 -    |> fold (fn refl => fn thm => Thm.combination thm refl) vs_refl
  26.170 -    |> Conv.fconv_rule Drule.beta_eta_conversion
  26.171 -  end;
  26.172 -
  26.173 -fun rewrite_func rewrites thm =
  26.174 -  let
  26.175 -    val rewrite = MetaSimplifier.rewrite false rewrites;
  26.176 -    val (ct_eq, [ct_lhs, ct_rhs]) = (Drule.strip_comb o Thm.cprop_of) thm;
  26.177 -    val Const ("==", _) = Thm.term_of ct_eq;
  26.178 -    val (ct_f, ct_args) = Drule.strip_comb ct_lhs;
  26.179 -    val rhs' = rewrite ct_rhs;
  26.180 -    val args' = map rewrite ct_args;
  26.181 -    val lhs' = Thm.symmetric (fold (fn th1 => fn th2 => Thm.combination th2 th1)
  26.182 -      args' (Thm.reflexive ct_f));
  26.183 -  in Thm.transitive (Thm.transitive lhs' thm) rhs' end;
  26.184 -
  26.185 -fun norm_args thms =
  26.186 -  let
  26.187 -    val num_args_of = length o snd o strip_comb o fst o Logic.dest_equals;
  26.188 -    val k = fold (curry Int.max o num_args_of o Thm.plain_prop_of) thms 0;
  26.189 -  in
  26.190 -    thms
  26.191 -    |> map (expand_eta k)
  26.192 -    |> map (Conv.fconv_rule Drule.beta_eta_conversion)
  26.193 -  end;
  26.194 -
  26.195 -fun canonical_tvars purify_tvar thm =
  26.196 -  let
  26.197 -    val ctyp = Thm.ctyp_of (Thm.theory_of_thm thm);
  26.198 -    fun tvars_subst_for thm = (fold_types o fold_atyps)
  26.199 -      (fn TVar (v_i as (v, _), sort) => let
  26.200 -            val v' = purify_tvar v
  26.201 -          in if v = v' then I
  26.202 -          else insert (op =) (v_i, (v', sort)) end
  26.203 -        | _ => I) (prop_of thm) [];
  26.204 -    fun mk_inst (v_i, (v', sort)) (maxidx, acc) =
  26.205 -      let
  26.206 -        val ty = TVar (v_i, sort)
  26.207 -      in
  26.208 -        (maxidx + 1, (ctyp ty, ctyp (TVar ((v', maxidx), sort))) :: acc)
  26.209 -      end;
  26.210 -    val maxidx = Thm.maxidx_of thm + 1;
  26.211 -    val (_, inst) = fold mk_inst (tvars_subst_for thm) (maxidx + 1, []);
  26.212 -  in Thm.instantiate (inst, []) thm end;
  26.213 -
  26.214 -fun canonical_vars purify_var thm =
  26.215 -  let
  26.216 -    val cterm = Thm.cterm_of (Thm.theory_of_thm thm);
  26.217 -    fun vars_subst_for thm = fold_aterms
  26.218 -      (fn Var (v_i as (v, _), ty) => let
  26.219 -            val v' = purify_var v
  26.220 -          in if v = v' then I
  26.221 -          else insert (op =) (v_i, (v', ty)) end
  26.222 -        | _ => I) (prop_of thm) [];
  26.223 -    fun mk_inst (v_i as (v, i), (v', ty)) (maxidx, acc) =
  26.224 -      let
  26.225 -        val t = Var (v_i, ty)
  26.226 -      in
  26.227 -        (maxidx + 1, (cterm t, cterm (Var ((v', maxidx), ty))) :: acc)
  26.228 -      end;
  26.229 -    val maxidx = Thm.maxidx_of thm + 1;
  26.230 -    val (_, inst) = fold mk_inst (vars_subst_for thm) (maxidx + 1, []);
  26.231 -  in Thm.instantiate ([], inst) thm end;
  26.232 -
  26.233 -fun canonical_absvars purify_var thm =
  26.234 -  let
  26.235 -    val t = Thm.plain_prop_of thm;
  26.236 -    val t' = Term.map_abs_vars purify_var t;
  26.237 -  in Thm.rename_boundvars t t' thm end;
  26.238 -
  26.239 -fun norm_varnames purify_tvar purify_var thms =
  26.240 -  let
  26.241 -    fun burrow_thms f [] = []
  26.242 -      | burrow_thms f thms =
  26.243 -          thms
  26.244 -          |> Conjunction.intr_balanced
  26.245 -          |> f
  26.246 -          |> Conjunction.elim_balanced (length thms)
  26.247 -  in
  26.248 -    thms
  26.249 -    |> burrow_thms (canonical_tvars purify_tvar)
  26.250 -    |> map (canonical_vars purify_var)
  26.251 -    |> map (canonical_absvars purify_var)
  26.252 -    |> map Drule.zero_var_indexes
  26.253 -  end;
  26.254 -
  26.255 -end;
    27.1 --- a/src/Pure/Tools/codegen_funcgr.ML	Fri Aug 10 17:04:24 2007 +0200
    27.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    27.3 @@ -1,409 +0,0 @@
    27.4 -(*  Title:      Pure/Tools/codegen_funcgr.ML
    27.5 -    ID:         $Id$
    27.6 -    Author:     Florian Haftmann, TU Muenchen
    27.7 -
    27.8 -Retrieving, normalizing and structuring defining equations
    27.9 -in graph with explicit dependencies.
   27.10 -*)
   27.11 -
   27.12 -signature CODEGEN_FUNCGR =
   27.13 -sig
   27.14 -  type T
   27.15 -  val timing: bool ref
   27.16 -  val funcs: T -> CodegenConsts.const -> thm list
   27.17 -  val typ: T -> CodegenConsts.const -> typ
   27.18 -  val deps: T -> CodegenConsts.const list -> CodegenConsts.const list list
   27.19 -  val all: T -> CodegenConsts.const list
   27.20 -  val pretty: theory -> T -> Pretty.T
   27.21 -  structure Constgraph : GRAPH
   27.22 -end
   27.23 -
   27.24 -signature CODEGEN_FUNCGR_RETRIEVAL =
   27.25 -sig
   27.26 -  type T (* = CODEGEN_FUNCGR.T *)
   27.27 -  val make: theory -> CodegenConsts.const list -> T
   27.28 -  val make_consts: theory -> CodegenConsts.const list -> CodegenConsts.const list * T
   27.29 -  val make_term: theory -> (T -> (thm -> thm) -> cterm -> thm -> 'a) -> cterm -> 'a * T
   27.30 -    (*FIXME drop make_term as soon as possible*)
   27.31 -  val eval_conv: theory -> (T -> cterm -> thm) -> cterm -> thm
   27.32 -  val intervene: theory -> T -> T
   27.33 -    (*FIXME drop intervene as soon as possible*)
   27.34 -end;
   27.35 -
   27.36 -structure CodegenFuncgr = (*signature is added later*)
   27.37 -struct
   27.38 -
   27.39 -(** the graph type **)
   27.40 -
   27.41 -structure Constgraph = GraphFun (
   27.42 -  type key = CodegenConsts.const;
   27.43 -  val ord = CodegenConsts.const_ord;
   27.44 -);
   27.45 -
   27.46 -type T = (typ * thm list) Constgraph.T;
   27.47 -
   27.48 -fun funcs funcgr =
   27.49 -  these o Option.map snd o try (Constgraph.get_node funcgr);
   27.50 -
   27.51 -fun typ funcgr =
   27.52 -  fst o Constgraph.get_node funcgr;
   27.53 -
   27.54 -fun deps funcgr cs =
   27.55 -  let
   27.56 -    val conn = Constgraph.strong_conn funcgr;
   27.57 -    val order = rev conn;
   27.58 -  in
   27.59 -    (map o filter) (member (op =) (Constgraph.all_succs funcgr cs)) order
   27.60 -    |> filter_out null
   27.61 -  end;
   27.62 -
   27.63 -fun all funcgr = Constgraph.keys funcgr;
   27.64 -
   27.65 -fun pretty thy funcgr =
   27.66 -  AList.make (snd o Constgraph.get_node funcgr) (Constgraph.keys funcgr)
   27.67 -  |> (map o apfst) (CodegenConsts.string_of_const thy)
   27.68 -  |> sort (string_ord o pairself fst)
   27.69 -  |> map (fn (s, thms) =>
   27.70 -       (Pretty.block o Pretty.fbreaks) (
   27.71 -         Pretty.str s
   27.72 -         :: map Display.pretty_thm thms
   27.73 -       ))
   27.74 -  |> Pretty.chunks;
   27.75 -
   27.76 -
   27.77 -(** generic combinators **)
   27.78 -
   27.79 -fun fold_consts f thms =
   27.80 -  thms
   27.81 -  |> maps (op :: o swap o apfst (snd o strip_comb) o Logic.dest_equals o Thm.plain_prop_of)
   27.82 -  |> (fold o fold_aterms) (fn Const c => f c | _ => I);
   27.83 -
   27.84 -fun consts_of (const, []) = []
   27.85 -  | consts_of (const, thms as thm :: _) = 
   27.86 -      let
   27.87 -        val thy = Thm.theory_of_thm thm;
   27.88 -        val is_refl = curry CodegenConsts.eq_const const;
   27.89 -        fun the_const c = case try (CodegenConsts.const_of_cexpr thy) c
   27.90 -         of SOME const => if is_refl const then I else insert CodegenConsts.eq_const const
   27.91 -          | NONE => I
   27.92 -      in fold_consts the_const thms [] end;
   27.93 -
   27.94 -fun insts_of thy algebra c ty_decl ty =
   27.95 -  let
   27.96 -    val tys_decl = Sign.const_typargs thy (c, ty_decl);
   27.97 -    val tys = Sign.const_typargs thy (c, ty);
   27.98 -    fun class_relation (x, _) _ = x;
   27.99 -    fun type_constructor tyco xs class =
  27.100 -      (tyco, class) :: maps (maps fst) xs;
  27.101 -    fun type_variable (TVar (_, sort)) = map (pair []) sort
  27.102 -      | type_variable (TFree (_, sort)) = map (pair []) sort;
  27.103 -    fun mk_inst ty (TVar (_, sort)) = cons (ty, sort)
  27.104 -      | mk_inst ty (TFree (_, sort)) = cons (ty, sort)
  27.105 -      | mk_inst (Type (_, tys1)) (Type (_, tys2)) = fold2 mk_inst tys1 tys2;
  27.106 -    fun of_sort_deriv (ty, sort) =
  27.107 -      Sorts.of_sort_derivation (Sign.pp thy) algebra
  27.108 -        { class_relation = class_relation, type_constructor = type_constructor,
  27.109 -          type_variable = type_variable }
  27.110 -        (ty, sort)
  27.111 -  in
  27.112 -    flat (maps of_sort_deriv (fold2 mk_inst tys tys_decl []))
  27.113 -  end;
  27.114 -
  27.115 -fun drop_classes thy tfrees thm =
  27.116 -  let
  27.117 -    val (_, thm') = Thm.varifyT' [] thm;
  27.118 -    val tvars = Term.add_tvars (Thm.prop_of thm') [];
  27.119 -    val unconstr = map (Thm.ctyp_of thy o TVar) tvars;
  27.120 -    val instmap = map2 (fn (v_i, _) => fn (v, sort) => pairself (Thm.ctyp_of thy)
  27.121 -      (TVar (v_i, []), TFree (v, sort))) tvars tfrees;
  27.122 -  in
  27.123 -    thm'
  27.124 -    |> fold Thm.unconstrainT unconstr
  27.125 -    |> Thm.instantiate (instmap, [])
  27.126 -    |> Tactic.rule_by_tactic ((REPEAT o CHANGED o ALLGOALS o Tactic.resolve_tac) (AxClass.class_intros thy))
  27.127 -  end;
  27.128 -
  27.129 -
  27.130 -(** graph algorithm **)
  27.131 -
  27.132 -val timing = ref false;
  27.133 -
  27.134 -local
  27.135 -
  27.136 -exception INVALID of CodegenConsts.const list * string;
  27.137 -
  27.138 -fun resort_thms algebra tap_typ [] = []
  27.139 -  | resort_thms algebra tap_typ (thms as thm :: _) =
  27.140 -      let
  27.141 -        val thy = Thm.theory_of_thm thm;
  27.142 -        val cs = fold_consts (insert (op =)) thms [];
  27.143 -        fun match_const c (ty, ty_decl) =
  27.144 -          let
  27.145 -            val tys = CodegenConsts.typargs thy (c, ty);
  27.146 -            val sorts = map (snd o dest_TVar) (CodegenConsts.typargs thy (c, ty_decl));
  27.147 -          in fold2 (curry (CodegenConsts.typ_sort_inst algebra)) tys sorts end;
  27.148 -        fun match (c_ty as (c, ty)) =
  27.149 -          case tap_typ c_ty
  27.150 -           of SOME ty_decl => match_const c (ty, ty_decl)
  27.151 -            | NONE => I;
  27.152 -        val tvars = fold match cs Vartab.empty;
  27.153 -      in map (CodegenFunc.inst_thm tvars) thms end;
  27.154 -
  27.155 -fun resort_funcss thy algebra funcgr =
  27.156 -  let
  27.157 -    val typ_funcgr = try (fst o Constgraph.get_node funcgr o CodegenConsts.const_of_cexpr thy);
  27.158 -    fun resort_dep (const, thms) = (const, resort_thms algebra typ_funcgr thms)
  27.159 -      handle Sorts.CLASS_ERROR e => raise INVALID ([const], Sorts.msg_class_error (Sign.pp thy) e
  27.160 -                    ^ ",\nfor constant " ^ CodegenConsts.string_of_const thy const
  27.161 -                    ^ "\nin defining equations\n"
  27.162 -                    ^ (cat_lines o map string_of_thm) thms)
  27.163 -    fun resort_rec tap_typ (const, []) = (true, (const, []))
  27.164 -      | resort_rec tap_typ (const, thms as thm :: _) =
  27.165 -          let
  27.166 -            val (_, ty) = CodegenFunc.head_func thm;
  27.167 -            val thms' as thm' :: _ = resort_thms algebra tap_typ thms
  27.168 -            val (_, ty') = CodegenFunc.head_func thm';
  27.169 -          in (Sign.typ_equiv thy (ty, ty'), (const, thms')) end;
  27.170 -    fun resort_recs funcss =
  27.171 -      let
  27.172 -        fun tap_typ c_ty = case try (CodegenConsts.const_of_cexpr thy) c_ty
  27.173 -         of SOME const => AList.lookup (CodegenConsts.eq_const) funcss const
  27.174 -              |> these
  27.175 -              |> try hd
  27.176 -              |> Option.map (snd o CodegenFunc.head_func)
  27.177 -          | NONE => NONE;
  27.178 -        val (unchangeds, funcss') = split_list (map (resort_rec tap_typ) funcss);
  27.179 -        val unchanged = fold (fn x => fn y => x andalso y) unchangeds true;
  27.180 -      in (unchanged, funcss') end;
  27.181 -    fun resort_rec_until funcss =
  27.182 -      let
  27.183 -        val (unchanged, funcss') = resort_recs funcss;
  27.184 -      in if unchanged then funcss' else resort_rec_until funcss' end;
  27.185 -  in map resort_dep #> resort_rec_until end;
  27.186 -
  27.187 -fun instances_of thy algebra insts =
  27.188 -  let
  27.189 -    val thy_classes = (#classes o Sorts.rep_algebra o Sign.classes_of) thy;
  27.190 -    fun all_classops tyco class =
  27.191 -      try (AxClass.params_of_class thy) class
  27.192 -      |> Option.map snd
  27.193 -      |> these
  27.194 -      |> map (fn (c, _) => (c, SOME tyco))
  27.195 -  in
  27.196 -    Symtab.empty
  27.197 -    |> fold (fn (tyco, class) =>
  27.198 -        Symtab.map_default (tyco, []) (insert (op =) class)) insts
  27.199 -    |> (fn tab => Symtab.fold (fn (tyco, classes) => append (maps (all_classops tyco)
  27.200 -         (Graph.all_succs thy_classes classes))) tab [])
  27.201 -  end;
  27.202 -
  27.203 -fun instances_of_consts thy algebra funcgr consts =
  27.204 -  let
  27.205 -    fun inst (cexpr as (c, ty)) = insts_of thy algebra c
  27.206 -      ((fst o Constgraph.get_node funcgr o CodegenConsts.const_of_cexpr thy) cexpr)
  27.207 -      ty handle CLASS_ERROR => [];
  27.208 -  in
  27.209 -    []
  27.210 -    |> fold (fold (insert (op =)) o inst) consts
  27.211 -    |> instances_of thy algebra
  27.212 -  end;
  27.213 -
  27.214 -fun ensure_const' rewrites thy algebra funcgr const auxgr =
  27.215 -  if can (Constgraph.get_node funcgr) const
  27.216 -    then (NONE, auxgr)
  27.217 -  else if can (Constgraph.get_node auxgr) const
  27.218 -    then (SOME const, auxgr)
  27.219 -  else if is_some (CodegenData.get_datatype_of_constr thy const) then
  27.220 -    auxgr
  27.221 -    |> Constgraph.new_node (const, [])
  27.222 -    |> pair (SOME const)
  27.223 -  else let
  27.224 -    val thms = CodegenData.these_funcs thy const
  27.225 -      |> map (CodegenFunc.rewrite_func (rewrites thy))
  27.226 -      |> CodegenFunc.norm_args
  27.227 -      |> CodegenFunc.norm_varnames CodegenNames.purify_tvar CodegenNames.purify_var;
  27.228 -    val rhs = consts_of (const, thms);
  27.229 -  in
  27.230 -    auxgr
  27.231 -    |> Constgraph.new_node (const, thms)
  27.232 -    |> fold_map (ensure_const rewrites thy algebra funcgr) rhs
  27.233 -    |-> (fn rhs' => fold (fn SOME const' => Constgraph.add_edge (const, const')
  27.234 -                           | NONE => I) rhs')
  27.235 -    |> pair (SOME const)
  27.236 -  end
  27.237 -and ensure_const rewrites thy algebra funcgr const =
  27.238 -  let
  27.239 -    val timeap = if !timing
  27.240 -      then Output.timeap_msg ("time for " ^ CodegenConsts.string_of_const thy const)
  27.241 -      else I;
  27.242 -  in timeap (ensure_const' rewrites thy algebra funcgr const) end;
  27.243 -
  27.244 -fun merge_funcss rewrites thy algebra raw_funcss funcgr =
  27.245 -  let
  27.246 -    val funcss = raw_funcss
  27.247 -      |> resort_funcss thy algebra funcgr
  27.248 -      |> filter_out (can (Constgraph.get_node funcgr) o fst);
  27.249 -    fun typ_func const [] = CodegenData.default_typ thy const
  27.250 -      | typ_func (_, NONE) (thm :: _) = (snd o CodegenFunc.head_func) thm
  27.251 -      | typ_func (const as (c, SOME tyco)) (thms as (thm :: _)) =
  27.252 -          let
  27.253 -            val (_, ty) = CodegenFunc.head_func thm;
  27.254 -            val SOME class = AxClass.class_of_param thy c;
  27.255 -            val sorts_decl = Sorts.mg_domain algebra tyco [class];
  27.256 -            val tys = CodegenConsts.typargs thy (c, ty);
  27.257 -            val sorts = map (snd o dest_TVar) tys;
  27.258 -          in if sorts = sorts_decl then ty
  27.259 -            else raise INVALID ([const], "Illegal instantation for class operation "
  27.260 -              ^ CodegenConsts.string_of_const thy const
  27.261 -              ^ "\nin defining equations\n"
  27.262 -              ^ (cat_lines o map string_of_thm) thms)
  27.263 -          end;
  27.264 -    fun add_funcs (const, thms) =
  27.265 -      Constgraph.new_node (const, (typ_func const thms, thms));
  27.266 -    fun add_deps (funcs as (const, thms)) funcgr =
  27.267 -      let
  27.268 -        val deps = consts_of funcs;
  27.269 -        val insts = instances_of_consts thy algebra funcgr
  27.270 -          (fold_consts (insert (op =)) thms []);
  27.271 -      in
  27.272 -        funcgr
  27.273 -        |> ensure_consts' rewrites thy algebra insts
  27.274 -        |> fold (curry Constgraph.add_edge const) deps
  27.275 -        |> fold (curry Constgraph.add_edge const) insts
  27.276 -       end;
  27.277 -  in
  27.278 -    funcgr
  27.279 -    |> fold add_funcs funcss
  27.280 -    |> fold add_deps funcss
  27.281 -  end
  27.282 -and ensure_consts' rewrites thy algebra cs funcgr =
  27.283 -  let
  27.284 -    val auxgr = Constgraph.empty
  27.285 -      |> fold (snd oo ensure_const rewrites thy algebra funcgr) cs;
  27.286 -  in
  27.287 -    funcgr
  27.288 -    |> fold (merge_funcss rewrites thy algebra)
  27.289 -         (map (AList.make (Constgraph.get_node auxgr))
  27.290 -         (rev (Constgraph.strong_conn auxgr)))
  27.291 -  end handle INVALID (cs', msg)
  27.292 -    => raise INVALID (fold (insert CodegenConsts.eq_const) cs' cs, msg);
  27.293 -
  27.294 -fun ensure_consts rewrites thy consts funcgr =
  27.295 -  let
  27.296 -    val algebra = CodegenData.coregular_algebra thy
  27.297 -  in ensure_consts' rewrites thy algebra consts funcgr
  27.298 -    handle INVALID (cs', msg) => error (msg ^ ",\nwhile preprocessing equations for constant(s) "
  27.299 -    ^ commas (map (CodegenConsts.string_of_const thy) cs'))
  27.300 -  end;
  27.301 -
  27.302 -in
  27.303 -
  27.304 -(** retrieval interfaces **)
  27.305 -
  27.306 -val ensure_consts = ensure_consts;
  27.307 -
  27.308 -fun check_consts rewrites thy consts funcgr =
  27.309 -  let
  27.310 -    val algebra = CodegenData.coregular_algebra thy;
  27.311 -    fun try_const const funcgr =
  27.312 -      (SOME const, ensure_consts' rewrites thy algebra [const] funcgr)
  27.313 -      handle INVALID (cs', msg) => (NONE, funcgr);
  27.314 -    val (consts', funcgr') = fold_map try_const consts funcgr;
  27.315 -  in (map_filter I consts', funcgr') end;
  27.316 -
  27.317 -fun ensure_consts_term rewrites thy f ct funcgr =
  27.318 -  let
  27.319 -    fun consts_of thy t =
  27.320 -      fold_aterms (fn Const c => cons (CodegenConsts.const_of_cexpr thy c) | _ => I) t []
  27.321 -    fun rhs_conv conv thm =
  27.322 -      let
  27.323 -        val thm' = (conv o Thm.rhs_of) thm;
  27.324 -      in Thm.transitive thm thm' end
  27.325 -    val _ = Sign.no_vars (Sign.pp thy) (Thm.term_of ct);
  27.326 -    val _ = Term.fold_types (Type.no_tvars #> K I) (Thm.term_of ct) ();
  27.327 -    val thm1 = CodegenData.preprocess_conv ct
  27.328 -      |> fold (rhs_conv o MetaSimplifier.rewrite false o single) (rewrites thy);
  27.329 -    val ct' = Thm.rhs_of thm1;
  27.330 -    val consts = consts_of thy (Thm.term_of ct');
  27.331 -    val funcgr' = ensure_consts rewrites thy consts funcgr;
  27.332 -    val algebra = CodegenData.coregular_algebra thy;
  27.333 -    val (_, thm2) = Thm.varifyT' [] thm1;
  27.334 -    val thm3 = Thm.reflexive (Thm.rhs_of thm2);
  27.335 -    val typ_funcgr = try (fst o Constgraph.get_node funcgr' o CodegenConsts.const_of_cexpr thy);
  27.336 -    val [thm4] = resort_thms algebra typ_funcgr [thm3];
  27.337 -    val tfrees = Term.add_tfrees (Thm.prop_of thm1) [];
  27.338 -    fun inst thm =
  27.339 -      let
  27.340 -        val tvars = Term.add_tvars (Thm.prop_of thm) [];
  27.341 -        val instmap = map2 (fn (v_i, sort) => fn (v, _) => pairself (Thm.ctyp_of thy)
  27.342 -          (TVar (v_i, sort), TFree (v, sort))) tvars tfrees;
  27.343 -      in Thm.instantiate (instmap, []) thm end;
  27.344 -    val thm5 = inst thm2;
  27.345 -    val thm6 = inst thm4;
  27.346 -    val ct'' = Thm.rhs_of thm6;
  27.347 -    val cs = fold_aterms (fn Const c => cons c | _ => I) (Thm.term_of ct'') [];
  27.348 -    val drop = drop_classes thy tfrees;
  27.349 -    val instdefs = instances_of_consts thy algebra funcgr' cs;
  27.350 -    val funcgr'' = ensure_consts rewrites thy instdefs funcgr';
  27.351 -  in (f funcgr'' drop ct'' thm5, funcgr'') end;
  27.352 -
  27.353 -fun ensure_consts_eval rewrites thy conv =
  27.354 -  let
  27.355 -    fun conv' funcgr drop_classes ct thm1 =
  27.356 -      let
  27.357 -        val thm2 = conv funcgr ct;
  27.358 -        val thm3 = CodegenData.postprocess_conv (Thm.rhs_of thm2);
  27.359 -        val thm23 = drop_classes (Thm.transitive thm2 thm3);
  27.360 -      in
  27.361 -        Thm.transitive thm1 thm23 handle THM _ =>
  27.362 -          error ("eval_conv - could not construct proof:\n"
  27.363 -          ^ (cat_lines o map string_of_thm) [thm1, thm2, thm3])
  27.364 -      end;
  27.365 -  in ensure_consts_term rewrites thy conv' end;
  27.366 -
  27.367 -end; (*local*)
  27.368 -
  27.369 -end; (*struct*)
  27.370 -
  27.371 -functor CodegenFuncgrRetrieval (val rewrites: theory -> thm list) : CODEGEN_FUNCGR_RETRIEVAL =
  27.372 -struct
  27.373 -
  27.374 -(** code data **)
  27.375 -
  27.376 -type T = CodegenFuncgr.T;
  27.377 -
  27.378 -structure Funcgr = CodeDataFun
  27.379 -(struct
  27.380 -  type T = T;
  27.381 -  val empty = CodegenFuncgr.Constgraph.empty;
  27.382 -  fun merge _ _ = CodegenFuncgr.Constgraph.empty;
  27.383 -  fun purge _ NONE _ = CodegenFuncgr.Constgraph.empty
  27.384 -    | purge _ (SOME cs) funcgr =
  27.385 -        CodegenFuncgr.Constgraph.del_nodes ((CodegenFuncgr.Constgraph.all_preds funcgr 
  27.386 -          o filter (can (CodegenFuncgr.Constgraph.get_node funcgr))) cs) funcgr;
  27.387 -end);
  27.388 -
  27.389 -fun make thy =
  27.390 -  Funcgr.change thy o CodegenFuncgr.ensure_consts rewrites thy;
  27.391 -
  27.392 -fun make_consts thy =
  27.393 -  Funcgr.change_yield thy o CodegenFuncgr.check_consts rewrites thy;
  27.394 -
  27.395 -fun make_term thy f =
  27.396 -  Funcgr.change_yield thy o CodegenFuncgr.ensure_consts_term rewrites thy f;
  27.397 -
  27.398 -fun eval_conv thy f =
  27.399 -  fst o Funcgr.change_yield thy o CodegenFuncgr.ensure_consts_eval rewrites thy f;
  27.400 -
  27.401 -(*FIXME*)
  27.402 -fun intervene thy funcgr =
  27.403 -  Funcgr.change thy (K funcgr);
  27.404 -
  27.405 -end; (*functor*)
  27.406 -
  27.407 -structure CodegenFuncgr : CODEGEN_FUNCGR =
  27.408 -struct
  27.409 -
  27.410 -open CodegenFuncgr;
  27.411 -
  27.412 -end; (*struct*)
    28.1 --- a/src/Pure/Tools/codegen_names.ML	Fri Aug 10 17:04:24 2007 +0200
    28.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    28.3 @@ -1,426 +0,0 @@
    28.4 -(*  Title:      Pure/Tools/codegen_names.ML
    28.5 -    ID:         $Id$
    28.6 -    Author:     Florian Haftmann, TU Muenchen
    28.7 -
    28.8 -Naming policies for code generation: prefixing any name by corresponding theory name,
    28.9 -conversion to alphanumeric representation.
   28.10 -Mappings are incrementally cached.
   28.11 -*)
   28.12 -
   28.13 -signature CODEGEN_NAMES =
   28.14 -sig
   28.15 -  val purify_var: string -> string
   28.16 -  val purify_tvar: string -> string
   28.17 -  val check_modulename: string -> string
   28.18 -  type var_ctxt;
   28.19 -  val make_vars: string list -> var_ctxt;
   28.20 -  val intro_vars: string list -> var_ctxt -> var_ctxt;
   28.21 -  val lookup_var: var_ctxt -> string -> string;
   28.22 -
   28.23 -  type tyco = string
   28.24 -  type const = string
   28.25 -  val class: theory -> class -> class
   28.26 -  val class_rev: theory -> class -> class option
   28.27 -  val classrel: theory -> class * class -> string
   28.28 -  val classrel_rev: theory -> string -> (class * class) option
   28.29 -  val tyco: theory -> tyco -> tyco
   28.30 -  val tyco_rev: theory -> tyco -> tyco option
   28.31 -  val instance: theory -> class * tyco -> string
   28.32 -  val instance_rev: theory -> string -> (class * tyco) option
   28.33 -  val const: theory -> CodegenConsts.const -> const
   28.34 -  val const_rev: theory -> const -> CodegenConsts.const option
   28.35 -  val labelled_name: theory -> string -> string
   28.36 -end;
   28.37 -
   28.38 -structure CodegenNames: CODEGEN_NAMES =
   28.39 -struct
   28.40 -
   28.41 -(** purification **)
   28.42 -
   28.43 -fun purify_name upper_else_lower =
   28.44 -  let
   28.45 -    fun is_valid s = Symbol.is_ascii_letter s orelse Symbol.is_ascii_digit s orelse s = "'";
   28.46 -    val is_junk = not o is_valid andf Symbol.is_regular;
   28.47 -    val junk = Scan.many is_junk;
   28.48 -    val scan_valids = Symbol.scanner "Malformed input"
   28.49 -      ((junk |--
   28.50 -        (Scan.optional (Scan.one Symbol.is_ascii_letter) "x" ^^ (Scan.many is_valid >> implode)
   28.51 -        --| junk))
   28.52 -      -- Scan.repeat ((Scan.many1 is_valid >> implode) --| junk) >> op ::);
   28.53 -    fun upper_lower cs = if upper_else_lower then nth_map 0 Symbol.to_ascii_upper cs
   28.54 -      else (if forall Symbol.is_ascii_upper cs
   28.55 -        then map else nth_map 0) Symbol.to_ascii_lower cs;
   28.56 -  in
   28.57 -    explode
   28.58 -    #> scan_valids
   28.59 -    #> space_implode "_"
   28.60 -    #> explode
   28.61 -    #> upper_lower
   28.62 -    #> implode
   28.63 -  end;
   28.64 -
   28.65 -fun purify_var "" = "x"
   28.66 -  | purify_var v = purify_name false v;
   28.67 -
   28.68 -fun purify_tvar "" = "'a"
   28.69 -  | purify_tvar v =
   28.70 -      (unprefix "'" #> explode #> filter Symbol.is_ascii_letter #> cons "'" #> implode) v;
   28.71 -
   28.72 -fun check_modulename mn =
   28.73 -  let
   28.74 -    val mns = NameSpace.explode mn;
   28.75 -    val mns' = map (purify_name true) mns;
   28.76 -  in
   28.77 -    if mns' = mns then mn else error ("Invalid module name: " ^ quote mn ^ "\n"
   28.78 -      ^ "perhaps try " ^ quote (NameSpace.implode mns'))
   28.79 -  end;
   28.80 -
   28.81 -
   28.82 -(** variable name contexts **)
   28.83 -
   28.84 -type var_ctxt = string Symtab.table * Name.context;
   28.85 -
   28.86 -fun make_vars names = (fold (fn name => Symtab.update_new (name, name)) names Symtab.empty,
   28.87 -  Name.make_context names);
   28.88 -
   28.89 -fun intro_vars names (namemap, namectxt) =
   28.90 -  let
   28.91 -    val (names', namectxt') = Name.variants names namectxt;
   28.92 -    val namemap' = fold2 (curry Symtab.update) names names' namemap;
   28.93 -  in (namemap', namectxt') end;
   28.94 -
   28.95 -fun lookup_var (namemap, _) name = case Symtab.lookup namemap name
   28.96 - of SOME name' => name'
   28.97 -  | NONE => error ("Invalid name in context: " ^ quote name);
   28.98 -
   28.99 -
  28.100 -
  28.101 -(** global names (identifiers) **)
  28.102 -
  28.103 -(* identifier categories *)
  28.104 -
  28.105 -val idf_class = "class";
  28.106 -val idf_classrel = "clsrel"
  28.107 -val idf_tyco = "tyco";
  28.108 -val idf_instance = "inst";
  28.109 -val idf_const = "const";
  28.110 -
  28.111 -fun string_of_classrel (class, superclass) = class ^ " < " ^ superclass;
  28.112 -fun string_of_instance (class, tyco) = tyco ^ " :: " ^ class;
  28.113 -
  28.114 -fun add_idf nsp name =
  28.115 -  NameSpace.append name nsp;
  28.116 -
  28.117 -fun dest_idf nsp name =
  28.118 -  if NameSpace.base name = nsp
  28.119 -  then SOME (NameSpace.qualifier name)
  28.120 -  else NONE;
  28.121 -
  28.122 -local
  28.123 -
  28.124 -val name_mapping  = [
  28.125 -  (idf_class,       "class"),
  28.126 -  (idf_classrel,    "subclass relation"),
  28.127 -  (idf_tyco,        "type constructor"),
  28.128 -  (idf_instance,    "instance"),
  28.129 -  (idf_const,       "constant")
  28.130 -]
  28.131 -
  28.132 -in
  28.133 -
  28.134 -val category_of = the o AList.lookup (op =) name_mapping o NameSpace.base;
  28.135 -
  28.136 -end;
  28.137 -
  28.138 -
  28.139 -(* theory name lookup *)
  28.140 -
  28.141 -fun thyname_of thy f errmsg x =
  28.142 -  let
  28.143 -    fun thy_of thy =
  28.144 -      if f thy x then case get_first thy_of (Theory.parents_of thy)
  28.145 -        of NONE => SOME thy
  28.146 -         | thy => thy
  28.147 -      else NONE;
  28.148 -  in case thy_of thy
  28.149 -   of SOME thy => Context.theory_name thy
  28.150 -    | NONE => error (errmsg x) end;
  28.151 -
  28.152 -fun thyname_of_class thy =
  28.153 -  thyname_of thy (fn thy => member (op =) (Sign.all_classes thy))
  28.154 -    (fn class => "thyname_of_class: no such class: " ^ quote class);
  28.155 -
  28.156 -fun thyname_of_classrel thy =
  28.157 -  thyname_of thy (fn thy => fn (class1, class2) => Sign.subsort thy ([class1], [class2]))
  28.158 -    (fn (class1, class2) => "thyname_of_classrel: no such subclass relation: "
  28.159 -      ^ (quote o string_of_classrel) (class1, class2));
  28.160 -
  28.161 -fun thyname_of_tyco thy =
  28.162 -  thyname_of thy Sign.declared_tyname
  28.163 -    (fn tyco => "thyname_of_tyco: no such type constructor: " ^ quote tyco);
  28.164 -
  28.165 -fun thyname_of_instance thy =
  28.166 -  let
  28.167 -    fun test_instance thy (class, tyco) =
  28.168 -      can (Sorts.mg_domain (Sign.classes_of thy) tyco) [class]
  28.169 -  in thyname_of thy test_instance
  28.170 -    (fn (class, tyco) => "thyname_of_instance: no such instance: "
  28.171 -      ^ (quote o string_of_instance) (class, tyco))
  28.172 -  end;
  28.173 -
  28.174 -fun thyname_of_const thy =
  28.175 -  thyname_of thy Sign.declared_const
  28.176 -    (fn c => "thyname_of_const: no such constant: " ^ quote c);
  28.177 -
  28.178 -
  28.179 -(* naming policies *)
  28.180 -
  28.181 -val purify_prefix =
  28.182 -  explode
  28.183 -  (*should disappear as soon as hierarchical theory name spaces are available*)
  28.184 -  #> Symbol.scanner "Malformed name"
  28.185 -      (Scan.repeat ($$ "_" |-- $$ "_" >> (fn _ => ".") || Scan.one Symbol.is_regular))
  28.186 -  #> implode
  28.187 -  #> NameSpace.explode
  28.188 -  #> map (purify_name true);
  28.189 -
  28.190 -fun purify_base "op =" = "eq"
  28.191 -  | purify_base "op &" = "and"
  28.192 -  | purify_base "op |" = "or"
  28.193 -  | purify_base "op -->" = "implies"
  28.194 -  | purify_base "{}" = "empty"
  28.195 -  | purify_base "op :" = "member"
  28.196 -  | purify_base "op Int" = "intersect"
  28.197 -  | purify_base "op Un" = "union"
  28.198 -  | purify_base "*" = "product"
  28.199 -  | purify_base "+" = "sum"
  28.200 -  | purify_base s = purify_name false s;
  28.201 -
  28.202 -fun default_policy thy get_basename get_thyname name =
  28.203 -  let
  28.204 -    val prefix = (purify_prefix o get_thyname thy) name;
  28.205 -    val base = (purify_base o get_basename) name;
  28.206 -  in NameSpace.implode (prefix @ [base]) end;
  28.207 -
  28.208 -fun class_policy thy = default_policy thy NameSpace.base thyname_of_class;
  28.209 -fun classrel_policy thy = default_policy thy (fn (class1, class2) => 
  28.210 -  NameSpace.base class2 ^ "_" ^ NameSpace.base class1) thyname_of_classrel;
  28.211 -  (*order fits nicely with composed projections*)
  28.212 -fun tyco_policy thy = default_policy thy NameSpace.base thyname_of_tyco;
  28.213 -fun instance_policy thy = default_policy thy (fn (class, tyco) => 
  28.214 -  NameSpace.base class ^ "_" ^ NameSpace.base tyco) thyname_of_instance;
  28.215 -
  28.216 -fun force_thyname thy (const as (c, opt_tyco)) =
  28.217 -  case CodegenData.get_datatype_of_constr thy const
  28.218 -   of SOME dtco => SOME (thyname_of_tyco thy dtco)
  28.219 -    | NONE => (case AxClass.class_of_param thy c
  28.220 -       of SOME class => (case opt_tyco
  28.221 -           of SOME tyco => SOME (thyname_of_instance thy (class, tyco))
  28.222 -            | NONE => SOME (thyname_of_class thy class))
  28.223 -        | NONE => NONE);
  28.224 -
  28.225 -fun const_policy thy (const as (c, opt_tyco)) =
  28.226 -  case force_thyname thy const
  28.227 -   of NONE => default_policy thy NameSpace.base thyname_of_const c
  28.228 -    | SOME thyname => let
  28.229 -        val prefix = purify_prefix thyname;
  28.230 -        val tycos = the_list opt_tyco;
  28.231 -        val base = map (purify_base o NameSpace.base) (c :: tycos);
  28.232 -      in NameSpace.implode (prefix @ [space_implode "_" base]) end;
  28.233 -
  28.234 -
  28.235 -(* theory and code data *)
  28.236 -
  28.237 -type tyco = string;
  28.238 -type const = string;
  28.239 -structure Consttab = CodegenConsts.Consttab;
  28.240 -
  28.241 -structure StringPairTab =
  28.242 -  TableFun(
  28.243 -    type key = string * string;
  28.244 -    val ord = prod_ord fast_string_ord fast_string_ord;
  28.245 -  );
  28.246 -
  28.247 -datatype names = Names of {
  28.248 -  class: class Symtab.table * class Symtab.table,
  28.249 -  classrel: string StringPairTab.table * (class * class) Symtab.table,
  28.250 -  tyco: tyco Symtab.table * tyco Symtab.table,
  28.251 -  instance: string StringPairTab.table * (class * tyco) Symtab.table
  28.252 -}
  28.253 -
  28.254 -val empty_names = Names {
  28.255 -  class = (Symtab.empty, Symtab.empty),
  28.256 -  classrel = (StringPairTab.empty, Symtab.empty),
  28.257 -  tyco = (Symtab.empty, Symtab.empty),
  28.258 -  instance = (StringPairTab.empty, Symtab.empty)
  28.259 -};
  28.260 -
  28.261 -local
  28.262 -  fun mk_names (class, classrel, tyco, instance) =
  28.263 -    Names { class = class, classrel = classrel, tyco = tyco, instance = instance };
  28.264 -  fun map_names f (Names { class, classrel, tyco, instance }) =
  28.265 -    mk_names (f (class, classrel, tyco, instance));
  28.266 -in
  28.267 -  fun merge_names (Names { class = (class1, classrev1),
  28.268 -      classrel = (classrel1, classrelrev1), tyco = (tyco1, tycorev1),
  28.269 -      instance = (instance1, instancerev1) },
  28.270 -    Names { class = (class2, classrev2),
  28.271 -      classrel = (classrel2, classrelrev2), tyco = (tyco2, tycorev2),
  28.272 -      instance = (instance2, instancerev2) }) =
  28.273 -    mk_names ((Symtab.merge (op =) (class1, class2), Symtab.merge (op =) (classrev1, classrev2)),
  28.274 -      (StringPairTab.merge (op =) (classrel1, classrel2), Symtab.merge (op =) (classrelrev1, classrelrev2)),
  28.275 -      (Symtab.merge (op =) (tyco1, tyco2), Symtab.merge (op =) (tycorev1, tycorev2)),
  28.276 -      (StringPairTab.merge (op =) (instance1, instance2), Symtab.merge (op =) (instancerev1, instancerev2)));
  28.277 -  fun map_class f = map_names
  28.278 -    (fn (class, classrel, tyco, inst) => (f class, classrel, tyco, inst));
  28.279 -  fun map_classrel f = map_names
  28.280 -    (fn (class, classrel, tyco, inst) => (class, f classrel, tyco, inst));
  28.281 -  fun map_tyco f = map_names
  28.282 -    (fn (class, classrel, tyco, inst) => (class, classrel, f tyco, inst));
  28.283 -  fun map_instance f = map_names
  28.284 -    (fn (class, classrel, tyco, inst) => (class, classrel, tyco, f inst));
  28.285 -end; (*local*)
  28.286 -
  28.287 -structure CodeName = TheoryDataFun
  28.288 -(
  28.289 -  type T = names ref;
  28.290 -  val empty = ref empty_names;
  28.291 -  fun copy (ref names) = ref names;
  28.292 -  val extend = copy;
  28.293 -  fun merge _ (ref names1, ref names2) = ref (merge_names (names1, names2));
  28.294 -);
  28.295 -
  28.296 -structure ConstName = CodeDataFun
  28.297 -(
  28.298 -  type T = const Consttab.table * (string * string option) Symtab.table;
  28.299 -  val empty = (Consttab.empty, Symtab.empty);
  28.300 -  fun merge _ ((const1, constrev1), (const2, constrev2)) : T =
  28.301 -    (Consttab.merge (op =) (const1, const2),
  28.302 -      Symtab.merge CodegenConsts.eq_const (constrev1, constrev2));
  28.303 -  fun purge _ NONE _ = empty
  28.304 -    | purge _ (SOME cs) (const, constrev) = (fold Consttab.delete_safe cs const,
  28.305 -        fold Symtab.delete (map_filter (Consttab.lookup const) cs) constrev);
  28.306 -);
  28.307 -
  28.308 -val _ = Context.add_setup (CodeName.init);
  28.309 -
  28.310 -
  28.311 -(* forward lookup with cache update *)
  28.312 -
  28.313 -fun get thy get_tabs get upd_names upd policy x =
  28.314 -  let
  28.315 -    val names_ref = CodeName.get thy;
  28.316 -    val (Names names) = ! names_ref;
  28.317 -    val tabs = get_tabs names;
  28.318 -    fun declare name =
  28.319 -      let
  28.320 -        val names' = upd_names (K (upd (x, name) (fst tabs),
  28.321 -          Symtab.update_new (name, x) (snd tabs))) (Names names)
  28.322 -      in (names_ref := names'; name) end;
  28.323 -  in case get (fst tabs) x
  28.324 -   of SOME name => name
  28.325 -    | NONE => 
  28.326 -        x
  28.327 -        |> policy thy
  28.328 -        |> Name.variant (Symtab.keys (snd tabs))
  28.329 -        |> declare
  28.330 -  end;
  28.331 -
  28.332 -fun get_const thy const =
  28.333 -  let
  28.334 -    val tabs = ConstName.get thy;
  28.335 -    fun declare name =
  28.336 -      let
  28.337 -        val names' = (Consttab.update (const, name) (fst tabs),
  28.338 -          Symtab.update_new (name, const) (snd tabs))
  28.339 -      in (ConstName.change thy (K names'); name) end;
  28.340 -  in case Consttab.lookup (fst tabs) const
  28.341 -   of SOME name => name
  28.342 -    | NONE => 
  28.343 -        const
  28.344 -        |> const_policy thy
  28.345 -        |> Name.variant (Symtab.keys (snd tabs))
  28.346 -        |> declare
  28.347 -  end;
  28.348 -
  28.349 -
  28.350 -(* backward lookup *)
  28.351 -
  28.352 -fun rev thy get_tabs name =
  28.353 -  let
  28.354 -    val names_ref = CodeName.get thy
  28.355 -    val (Names names) = ! names_ref;
  28.356 -    val tab = (snd o get_tabs) names;
  28.357 -  in case Symtab.lookup tab name
  28.358 -   of SOME x => x
  28.359 -    | NONE => error ("No such " ^ category_of name ^ ": " ^ quote name)
  28.360 -  end;
  28.361 -
  28.362 -fun rev_const thy name =
  28.363 -  let
  28.364 -    val tab = snd (ConstName.get thy);
  28.365 -  in case Symtab.lookup tab name
  28.366 -   of SOME const => const
  28.367 -    | NONE => error ("No such " ^ category_of name ^ ": " ^ quote name)
  28.368 -  end;
  28.369 -
  28.370 -
  28.371 -(* external interfaces *)
  28.372 -
  28.373 -fun class thy =
  28.374 -  get thy #class Symtab.lookup map_class Symtab.update class_policy
  28.375 -  #> add_idf idf_class;
  28.376 -fun classrel thy =
  28.377 -  get thy #classrel StringPairTab.lookup map_classrel StringPairTab.update classrel_policy
  28.378 -  #> add_idf idf_classrel;
  28.379 -fun tyco thy =
  28.380 -  get thy #tyco Symtab.lookup map_tyco Symtab.update tyco_policy
  28.381 -  #> add_idf idf_tyco;
  28.382 -fun instance thy =
  28.383 -  get thy #instance StringPairTab.lookup map_instance StringPairTab.update instance_policy
  28.384 -  #> add_idf idf_instance;
  28.385 -fun const thy =
  28.386 -  get_const thy
  28.387 -  #> add_idf idf_const;
  28.388 -
  28.389 -fun class_rev thy =
  28.390 -  dest_idf idf_class
  28.391 -  #> Option.map (rev thy #class);
  28.392 -fun classrel_rev thy =
  28.393 -  dest_idf idf_classrel
  28.394 -  #> Option.map (rev thy #classrel);
  28.395 -fun tyco_rev thy =
  28.396 -  dest_idf idf_tyco
  28.397 -  #> Option.map (rev thy #tyco);
  28.398 -fun instance_rev thy =
  28.399 -  dest_idf idf_instance
  28.400 -  #> Option.map (rev thy #instance);
  28.401 -fun const_rev thy =
  28.402 -  dest_idf idf_const
  28.403 -  #> Option.map (rev_const thy);
  28.404 -
  28.405 -local
  28.406 -
  28.407 -val f_mapping = [
  28.408 -  (idf_class,       class_rev),
  28.409 -  (idf_classrel,    Option.map string_of_classrel oo classrel_rev),
  28.410 -  (idf_tyco,        tyco_rev),
  28.411 -  (idf_instance,    Option.map string_of_instance oo instance_rev),
  28.412 -  (idf_const,       fn thy => Option.map (CodegenConsts.string_of_const thy) o const_rev thy)
  28.413 -];
  28.414 -
  28.415 -in
  28.416 -
  28.417 -fun labelled_name thy idf =
  28.418 -  let
  28.419 -    val category = category_of idf;
  28.420 -    val name = NameSpace.qualifier idf;
  28.421 -    val f = (the o AList.lookup (op =) f_mapping o NameSpace.base) idf
  28.422 -  in case f thy idf
  28.423 -   of SOME thing => category ^ " " ^ quote thing
  28.424 -    | NONE => error ("Unknown name: " ^ quote name)
  28.425 -  end;
  28.426 -
  28.427 -end;
  28.428 -
  28.429 -end;
    29.1 --- a/src/Pure/Tools/codegen_package.ML	Fri Aug 10 17:04:24 2007 +0200
    29.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    29.3 @@ -1,673 +0,0 @@
    29.4 -(*  Title:      Pure/Tools/codegen_package.ML
    29.5 -    ID:         $Id$
    29.6 -    Author:     Florian Haftmann, TU Muenchen
    29.7 -
    29.8 -Code generator translation kernel.  Code generator Isar setup.
    29.9 -*)
   29.10 -
   29.11 -signature CODEGEN_PACKAGE =
   29.12 -sig
   29.13 -  (* interfaces *)
   29.14 -  val eval_conv: theory
   29.15 -    -> (CodegenThingol.code -> CodegenThingol.iterm -> cterm -> thm) -> cterm -> thm;
   29.16 -  val codegen_command: theory -> string -> unit;
   29.17 -
   29.18 -  (* primitive interfaces *)
   29.19 -  val eval_term: theory -> (string (*reference name!*) * 'a option ref) * term -> 'a;
   29.20 -  val satisfies_ref: bool option ref;
   29.21 -  val satisfies: theory -> term -> string list -> bool;
   29.22 -
   29.23 -  (* axiomatic interfaces *)
   29.24 -  type appgen;
   29.25 -  val add_appconst: string * appgen -> theory -> theory;
   29.26 -  val appgen_let: appgen;
   29.27 -  val appgen_if: appgen;
   29.28 -  val appgen_case: (theory -> term
   29.29 -    -> ((string * typ) list * ((term * typ) * (term * term) list)) option)
   29.30 -    -> appgen;
   29.31 -
   29.32 -  val timing: bool ref;
   29.33 -end;
   29.34 -
   29.35 -structure CodegenPackage : CODEGEN_PACKAGE =
   29.36 -struct
   29.37 -
   29.38 -open BasicCodegenThingol;
   29.39 -val tracing = CodegenThingol.tracing;
   29.40 -val succeed = CodegenThingol.succeed;
   29.41 -val fail = CodegenThingol.fail;
   29.42 -
   29.43 -(** code translation **)
   29.44 -
   29.45 -(* theory data *)
   29.46 -
   29.47 -type appgen = theory -> ((sort -> sort) * Sorts.algebra) * Consts.T
   29.48 -  -> CodegenFuncgr.T
   29.49 -  -> (string * typ) * term list -> CodegenThingol.transact -> iterm * CodegenThingol.transact;
   29.50 -
   29.51 -type appgens = (int * (appgen * stamp)) Symtab.table;
   29.52 -val merge_appgens : appgens * appgens -> appgens =
   29.53 -  Symtab.merge (fn ((bounds1, (_, stamp1)), (bounds2, (_, stamp2))) =>
   29.54 -    bounds1 = bounds2 andalso stamp1 = stamp2);
   29.55 -
   29.56 -structure Consttab = CodegenConsts.Consttab;
   29.57 -type abstypes = typ Symtab.table * CodegenConsts.const Consttab.table;
   29.58 -fun merge_abstypes ((typs1, consts1) : abstypes, (typs2, consts2) : abstypes) =
   29.59 -  (Symtab.merge (Type.eq_type Vartab.empty) (typs1, typs2),
   29.60 -    Consttab.merge CodegenConsts.eq_const (consts1, consts2));
   29.61 -
   29.62 -structure Translation = TheoryDataFun
   29.63 -(
   29.64 -  type T = appgens * abstypes;
   29.65 -  val empty = (Symtab.empty, (Symtab.empty, Consttab.empty));
   29.66 -  val copy = I;
   29.67 -  val extend = I;
   29.68 -  fun merge _ ((appgens1, abstypes1), (appgens2, abstypes2)) =
   29.69 -    (merge_appgens (appgens1, appgens2), merge_abstypes (abstypes1, abstypes2));
   29.70 -);
   29.71 -
   29.72 -structure Funcgr = CodegenFuncgrRetrieval (fun rewrites thy = []);
   29.73 -
   29.74 -fun code_depgr thy [] = Funcgr.make thy []
   29.75 -  | code_depgr thy consts =
   29.76 -      let
   29.77 -        val gr = Funcgr.make thy consts;
   29.78 -        val select = CodegenFuncgr.Constgraph.all_succs gr consts;
   29.79 -      in
   29.80 -        CodegenFuncgr.Constgraph.subgraph
   29.81 -          (member CodegenConsts.eq_const select) gr
   29.82 -      end;
   29.83 -
   29.84 -fun code_thms thy =
   29.85 -  Pretty.writeln o CodegenFuncgr.pretty thy o code_depgr thy;
   29.86 -
   29.87 -fun code_deps thy consts =
   29.88 -  let
   29.89 -    val gr = code_depgr thy consts;
   29.90 -    fun mk_entry (const, (_, (_, parents))) =
   29.91 -      let
   29.92 -        val name = CodegenConsts.string_of_const thy const;
   29.93 -        val nameparents = map (CodegenConsts.string_of_const thy) parents;
   29.94 -      in { name = name, ID = name, dir = "", unfold = true,
   29.95 -        path = "", parents = nameparents }
   29.96 -      end;
   29.97 -    val prgr = CodegenFuncgr.Constgraph.fold ((fn x => fn xs => xs @ [x]) o mk_entry) gr [];
   29.98 -  in Present.display_graph prgr end;
   29.99 -
  29.100 -structure Code = CodeDataFun
  29.101 -(
  29.102 -  type T = CodegenThingol.code;
  29.103 -  val empty = CodegenThingol.empty_code;
  29.104 -  fun merge _ = CodegenThingol.merge_code;
  29.105 -  fun purge _ NONE _ = CodegenThingol.empty_code
  29.106 -    | purge NONE _ _ = CodegenThingol.empty_code
  29.107 -    | purge (SOME thy) (SOME cs) code =
  29.108 -        let
  29.109 -          val cs_exisiting =
  29.110 -            map_filter (CodegenNames.const_rev thy) (Graph.keys code);
  29.111 -          val dels = (Graph.all_preds code
  29.112 -              o map (CodegenNames.const thy)
  29.113 -              o filter (member CodegenConsts.eq_const cs_exisiting)
  29.114 -            ) cs;
  29.115 -        in Graph.del_nodes dels code end;
  29.116 -);
  29.117 -
  29.118 -
  29.119 -(* translation kernel *)
  29.120 -
  29.121 -fun get_abstype thy (tyco, tys) = case Symtab.lookup ((fst o snd o Translation.get) thy) tyco
  29.122 - of SOME ty => SOME ((map_atyps (fn TFree (n, _) => nth tys (the (Int.fromString n)))) ty)
  29.123 -  | NONE => NONE;
  29.124 -
  29.125 -fun ensure_def thy = CodegenThingol.ensure_def (CodegenNames.labelled_name thy);
  29.126 -
  29.127 -fun ensure_def_class thy (algbr as ((_, algebra), _)) funcgr class =
  29.128 -  let
  29.129 -    val superclasses = (Sorts.certify_sort algebra o Sorts.super_classes algebra) class;
  29.130 -    val (v, cs) = AxClass.params_of_class thy class;
  29.131 -    val class' = CodegenNames.class thy class;
  29.132 -    val classrels' = map (curry (CodegenNames.classrel thy) class) superclasses;
  29.133 -    val classops' = map (CodegenNames.const thy o CodegenConsts.const_of_cexpr thy) cs;
  29.134 -    val defgen_class =
  29.135 -      fold_map (ensure_def_class thy algbr funcgr) superclasses
  29.136 -      ##>> (fold_map (exprgen_typ thy algbr funcgr) o map snd) cs
  29.137 -      #-> (fn (superclasses, classoptyps) => succeed
  29.138 -        (CodegenThingol.Class (superclasses ~~ classrels', (unprefix "'" v, classops' ~~ classoptyps))))
  29.139 -  in
  29.140 -    tracing (fn _ => "generating class " ^ quote class)
  29.141 -    #> ensure_def thy defgen_class ("generating class " ^ quote class) class'
  29.142 -    #> pair class'
  29.143 -  end
  29.144 -and ensure_def_classrel thy algbr funcgr (subclass, superclass) =
  29.145 -  ensure_def_class thy algbr funcgr subclass
  29.146 -  #>> (fn _ => CodegenNames.classrel thy (subclass, superclass))
  29.147 -and ensure_def_tyco thy algbr funcgr "fun" trns =
  29.148 -      trns
  29.149 -      |> pair "fun"
  29.150 -  | ensure_def_tyco thy algbr funcgr tyco trns =
  29.151 -      let
  29.152 -        fun defgen_datatype trns =
  29.153 -          let
  29.154 -            val (vs, cos) = CodegenData.get_datatype thy tyco;
  29.155 -          in
  29.156 -            trns
  29.157 -            |> fold_map (exprgen_tyvar_sort thy algbr funcgr) vs
  29.158 -            ||>> fold_map (fn (c, tys) =>
  29.159 -              fold_map (exprgen_typ thy algbr funcgr) tys
  29.160 -              #-> (fn tys' =>
  29.161 -                pair ((CodegenNames.const thy o CodegenConsts.const_of_cexpr thy)
  29.162 -                  (c, tys ---> Type (tyco, map TFree vs)), tys'))) cos
  29.163 -            |-> (fn (vs, cos) => succeed (CodegenThingol.Datatype (vs, cos)))
  29.164 -          end;
  29.165 -        val tyco' = CodegenNames.tyco thy tyco;
  29.166 -      in
  29.167 -        trns
  29.168 -        |> tracing (fn _ => "generating type constructor " ^ quote tyco)
  29.169 -        |> ensure_def thy defgen_datatype ("generating type constructor " ^ quote tyco) tyco'
  29.170 -        |> pair tyco'
  29.171 -      end
  29.172 -and exprgen_tyvar_sort thy (algbr as ((proj_sort, _), _)) funcgr (v, sort) trns =
  29.173 -  trns
  29.174 -  |> fold_map (ensure_def_class thy algbr funcgr) (proj_sort sort)
  29.175 -  |>> (fn sort => (unprefix "'" v, sort))
  29.176 -and exprgen_typ thy algbr funcgr (TFree vs) trns =
  29.177 -      trns
  29.178 -      |> exprgen_tyvar_sort thy algbr funcgr vs
  29.179 -      |>> (fn (v, sort) => ITyVar v)
  29.180 -  | exprgen_typ thy algbr funcgr (Type (tyco, tys)) trns =
  29.181 -      case get_abstype thy (tyco, tys)
  29.182 -       of SOME ty =>
  29.183 -            trns
  29.184 -            |> exprgen_typ thy algbr funcgr ty
  29.185 -        | NONE =>
  29.186 -            trns
  29.187 -            |> ensure_def_tyco thy algbr funcgr tyco
  29.188 -            ||>> fold_map (exprgen_typ thy algbr funcgr) tys
  29.189 -            |>> (fn (tyco, tys) => tyco `%% tys);
  29.190 -
  29.191 -exception CONSTRAIN of (string * typ) * typ;
  29.192 -val timing = ref false;
  29.193 -
  29.194 -fun exprgen_dicts thy (algbr as ((proj_sort, algebra), consts)) funcgr (ty_ctxt, sort_decl) =
  29.195 -  let
  29.196 -    val pp = Sign.pp thy;
  29.197 -    datatype typarg =
  29.198 -        Global of (class * string) * typarg list list
  29.199 -      | Local of (class * class) list * (string * (int * sort));
  29.200 -    fun class_relation (Global ((_, tyco), yss), _) class =
  29.201 -          Global ((class, tyco), yss)
  29.202 -      | class_relation (Local (classrels, v), subclass) superclass =
  29.203 -          Local ((subclass, superclass) :: classrels, v);
  29.204 -    fun type_constructor tyco yss class =
  29.205 -      Global ((class, tyco), (map o map) fst yss);
  29.206 -    fun type_variable (TFree (v, sort)) =
  29.207 -      let
  29.208 -        val sort' = proj_sort sort;
  29.209 -      in map_index (fn (n, class) => (Local ([], (v, (n, sort'))), class)) sort' end;
  29.210 -    val typargs = Sorts.of_sort_derivation pp algebra
  29.211 -      {class_relation = class_relation, type_constructor = type_constructor,
  29.212 -       type_variable = type_variable}
  29.213 -      (ty_ctxt, proj_sort sort_decl);
  29.214 -    fun mk_dict (Global (inst, yss)) =
  29.215 -          ensure_def_inst thy algbr funcgr inst
  29.216 -          ##>> (fold_map o fold_map) mk_dict yss
  29.217 -          #>> (fn (inst, dss) => DictConst (inst, dss))
  29.218 -      | mk_dict (Local (classrels, (v, (k, sort)))) =
  29.219 -          fold_map (ensure_def_classrel thy algbr funcgr) classrels
  29.220 -          #>> (fn classrels => DictVar (classrels, (unprefix "'" v, (k, length sort))))
  29.221 -  in
  29.222 -    fold_map mk_dict typargs
  29.223 -  end
  29.224 -and exprgen_dict_parms thy (algbr as (_, consts)) funcgr (c, ty_ctxt) =
  29.225 -  let
  29.226 -    val c' = CodegenConsts.const_of_cexpr thy (c, ty_ctxt)
  29.227 -    val idf = CodegenNames.const thy c';
  29.228 -    val ty_decl = Consts.the_declaration consts idf;
  29.229 -    val (tys, tys_decl) = pairself (curry (Consts.typargs consts) idf) (ty_ctxt, ty_decl);
  29.230 -    val sorts = map (snd o dest_TVar) tys_decl;
  29.231 -  in
  29.232 -    fold_map (exprgen_dicts thy algbr funcgr) (tys ~~ sorts)
  29.233 -  end
  29.234 -and ensure_def_inst thy (algbr as ((_, algebra), _)) funcgr (class, tyco) trns =
  29.235 -  let
  29.236 -    val superclasses = (Sorts.certify_sort algebra o Sorts.super_classes algebra) class;
  29.237 -    val (var, classops) = try (AxClass.params_of_class thy) class |> the_default ("'a", [])
  29.238 -    val vs = Name.names (Name.declare var Name.context) "'a" (Sorts.mg_domain algebra tyco [class]);
  29.239 -    val arity_typ = Type (tyco, map TFree vs);
  29.240 -    fun gen_superarity superclass trns =
  29.241 -      trns
  29.242 -      |> ensure_def_class thy algbr funcgr superclass
  29.243 -      ||>> ensure_def_classrel thy algbr funcgr (class, superclass)
  29.244 -      ||>> exprgen_dicts thy algbr funcgr (arity_typ, [superclass])
  29.245 -      |>> (fn ((superclass, classrel), [DictConst (inst, dss)]) =>
  29.246 -            (superclass, (classrel, (inst, dss))));
  29.247 -    fun gen_classop_def (classop as (c, ty)) trns =
  29.248 -      trns
  29.249 -      |> ensure_def_const thy algbr funcgr (CodegenConsts.const_of_cexpr thy classop)
  29.250 -      ||>> exprgen_term thy algbr funcgr (Const (c, map_type_tfree (K arity_typ) ty));
  29.251 -    fun defgen_inst trns =
  29.252 -      trns
  29.253 -      |> ensure_def_class thy algbr funcgr class
  29.254 -      ||>> ensure_def_tyco thy algbr funcgr tyco
  29.255 -      ||>> fold_map (exprgen_tyvar_sort thy algbr funcgr) vs
  29.256 -      ||>> fold_map gen_superarity superclasses
  29.257 -      ||>> fold_map gen_classop_def classops
  29.258 -      |-> (fn ((((class, tyco), arity), superarities), classops) =>
  29.259 -             succeed (CodegenThingol.Classinst ((class, (tyco, arity)), (superarities, classops))));
  29.260 -    val inst = CodegenNames.instance thy (class, tyco);
  29.261 -  in
  29.262 -    trns
  29.263 -    |> tracing (fn _ => "generating instance " ^ quote class ^ " / " ^ quote tyco)
  29.264 -    |> ensure_def thy defgen_inst ("generating instance " ^ quote class ^ " / " ^ quote tyco) inst
  29.265 -    |> pair inst
  29.266 -  end
  29.267 -and ensure_def_const thy (algbr as (_, consts)) funcgr (const as (c, opt_tyco)) trns =
  29.268 -  let
  29.269 -    val c' = CodegenNames.const thy const;
  29.270 -    fun defgen_datatypecons trns =
  29.271 -      trns
  29.272 -      |> ensure_def_tyco thy algbr funcgr
  29.273 -          ((the o CodegenData.get_datatype_of_constr thy) const)
  29.274 -      |-> (fn _ => succeed CodegenThingol.Bot);
  29.275 -    fun defgen_classop trns =
  29.276 -      trns
  29.277 -      |> ensure_def_class thy algbr funcgr ((the o AxClass.class_of_param thy) c)
  29.278 -      |-> (fn _ => succeed CodegenThingol.Bot);
  29.279 -    fun defgen_fun trns =
  29.280 -      let
  29.281 -        val const' = perhaps (Consttab.lookup ((snd o snd o Translation.get) thy)) const;
  29.282 -        val raw_thms = CodegenFuncgr.funcs funcgr const';
  29.283 -        val ty = (Logic.unvarifyT o CodegenFuncgr.typ funcgr) const';
  29.284 -        val thms = if (null o Term.typ_tfrees) ty orelse (null o fst o strip_type) ty
  29.285 -          then raw_thms
  29.286 -          else map (CodegenFunc.expand_eta 1) raw_thms;
  29.287 -        val timeap = if !timing then Output.timeap_msg ("time for " ^ c')
  29.288 -          else I;
  29.289 -        val msg = cat_lines ("generating code for theorems " :: map string_of_thm thms);
  29.290 -        val vs = (map dest_TFree o Consts.typargs consts) (c', ty);
  29.291 -        val dest_eqthm =
  29.292 -          apfst (snd o strip_comb) o Logic.dest_equals o Logic.unvarify o prop_of;
  29.293 -        fun exprgen_eq (args, rhs) trns =
  29.294 -          trns
  29.295 -          |> fold_map (exprgen_term thy algbr funcgr) args
  29.296 -          ||>> exprgen_term thy algbr funcgr rhs;
  29.297 -      in
  29.298 -        trns
  29.299 -        |> CodegenThingol.message msg (fn trns => trns
  29.300 -        |> timeap (fold_map (exprgen_eq o dest_eqthm) thms)
  29.301 -        ||>> fold_map (exprgen_tyvar_sort thy algbr funcgr) vs
  29.302 -        ||>> exprgen_typ thy algbr funcgr ty
  29.303 -        |-> (fn ((eqs, vs), ty) => succeed (CodegenThingol.Fun (eqs, (vs, ty)))))
  29.304 -      end;
  29.305 -    val defgen = if (is_some o CodegenData.get_datatype_of_constr thy) const
  29.306 -      then defgen_datatypecons
  29.307 -      else if is_some opt_tyco
  29.308 -        orelse (not o is_some o AxClass.class_of_param thy) c
  29.309 -      then defgen_fun
  29.310 -      else defgen_classop
  29.311 -  in
  29.312 -    trns
  29.313 -    |> tracing (fn _ => "generating constant "
  29.314 -        ^ (quote o CodegenConsts.string_of_const thy) const)
  29.315 -    |> ensure_def thy defgen ("generating constant " ^ CodegenConsts.string_of_const thy const) c'
  29.316 -    |> pair c'
  29.317 -  end
  29.318 -and exprgen_term thy algbr funcgr (Const (c, ty)) trns =
  29.319 -      trns
  29.320 -      |> select_appgen thy algbr funcgr ((c, ty), [])
  29.321 -  | exprgen_term thy algbr funcgr (Free (v, ty)) trns =
  29.322 -      trns
  29.323 -      |> exprgen_typ thy algbr funcgr ty
  29.324 -      |>> (fn _ => IVar v)
  29.325 -  | exprgen_term thy algbr funcgr (Abs (raw_v, ty, raw_t)) trns =
  29.326 -      let
  29.327 -        val (v, t) = Syntax.variant_abs (raw_v, ty, raw_t);
  29.328 -      in
  29.329 -        trns
  29.330 -        |> exprgen_typ thy algbr funcgr ty
  29.331 -        ||>> exprgen_term thy algbr funcgr t
  29.332 -        |>> (fn (ty, t) => (v, ty) `|-> t)
  29.333 -      end
  29.334 -  | exprgen_term thy algbr funcgr (t as _ $ _) trns =
  29.335 -      case strip_comb t
  29.336 -       of (Const (c, ty), ts) =>
  29.337 -            trns
  29.338 -            |> select_appgen thy algbr funcgr ((c, ty), ts)
  29.339 -        | (t', ts) =>
  29.340 -            trns
  29.341 -            |> exprgen_term thy algbr funcgr t'
  29.342 -            ||>> fold_map (exprgen_term thy algbr funcgr) ts
  29.343 -            |>> (fn (t, ts) => t `$$ ts)
  29.344 -and appgen_default thy algbr funcgr ((c, ty), ts) trns =
  29.345 -  trns
  29.346 -  |> ensure_def_const thy algbr funcgr (CodegenConsts.const_of_cexpr thy (c, ty))
  29.347 -  ||>> fold_map (exprgen_typ thy algbr funcgr) ((fst o Term.strip_type) ty)
  29.348 -  ||>> exprgen_typ thy algbr funcgr ((snd o Term.strip_type) ty)
  29.349 -  ||>> exprgen_dict_parms thy algbr funcgr (c, ty)
  29.350 -  ||>> fold_map (exprgen_term thy algbr funcgr) ts
  29.351 -  |>> (fn ((((c, tys), ty), iss), ts) => IConst (c, (iss, tys)) `$$ ts)
  29.352 -and select_appgen thy algbr funcgr ((c, ty), ts) trns =
  29.353 -  case Symtab.lookup (fst (Translation.get thy)) c
  29.354 -   of SOME (i, (appgen, _)) =>
  29.355 -        if length ts < i then
  29.356 -          let
  29.357 -            val k = length ts;
  29.358 -            val tys = (curry Library.take (i - k) o curry Library.drop k o fst o strip_type) ty;
  29.359 -            val ctxt = (fold o fold_aterms)
  29.360 -              (fn Free (v, _) => Name.declare v | _ => I) ts Name.context;
  29.361 -            val vs = Name.names ctxt "a" tys;
  29.362 -          in
  29.363 -            trns
  29.364 -            |> fold_map (exprgen_typ thy algbr funcgr) tys
  29.365 -            ||>> appgen thy algbr funcgr ((c, ty), ts @ map Free vs)
  29.366 -            |>> (fn (tys, t) => map2 (fn (v, _) => pair v) vs tys `|--> t)
  29.367 -          end
  29.368 -        else if length ts > i then
  29.369 -          trns
  29.370 -          |> appgen thy algbr funcgr ((c, ty), Library.take (i, ts))
  29.371 -          ||>> fold_map (exprgen_term thy algbr funcgr) (Library.drop (i, ts))
  29.372 -          |>> (fn (t, ts) => t `$$ ts)
  29.373 -        else
  29.374 -          trns
  29.375 -          |> appgen thy algbr funcgr ((c, ty), ts)
  29.376 -    | NONE =>
  29.377 -        trns
  29.378 -        |> appgen_default thy algbr funcgr ((c, ty), ts);
  29.379 -
  29.380 -
  29.381 -(* entrance points into translation kernel *)
  29.382 -
  29.383 -fun ensure_def_const' thy algbr funcgr c trns =
  29.384 -  ensure_def_const thy algbr funcgr c trns
  29.385 -  handle CONSTRAIN ((c, ty), ty_decl) => error (
  29.386 -    "Constant " ^ c ^ " with most general type\n"
  29.387 -    ^ CodegenConsts.string_of_typ thy ty
  29.388 -    ^ "\noccurs with type\n"
  29.389 -    ^ CodegenConsts.string_of_typ thy ty_decl);
  29.390 -
  29.391 -fun perhaps_def_const thy algbr funcgr c trns =
  29.392 -  case try (ensure_def_const thy algbr funcgr c) trns
  29.393 -   of SOME (c, trns) => (SOME c, trns)
  29.394 -    | NONE => (NONE, trns);
  29.395 -
  29.396 -fun exprgen_term' thy algbr funcgr t trns =
  29.397 -  exprgen_term thy algbr funcgr t trns
  29.398 -  handle CONSTRAIN ((c, ty), ty_decl) => error ("In term " ^ (quote o Sign.string_of_term thy) t
  29.399 -    ^ ",\nconstant " ^ c ^ " with most general type\n"
  29.400 -    ^ CodegenConsts.string_of_typ thy ty
  29.401 -    ^ "\noccurs with type\n"
  29.402 -    ^ CodegenConsts.string_of_typ thy ty_decl);
  29.403 -
  29.404 -
  29.405 -(* parametrized application generators, for instantiation in object logic *)
  29.406 -(* (axiomatic extensions of translation kernel) *)
  29.407 -
  29.408 -fun appgen_case dest_case_expr thy algbr funcgr (app as (c_ty, ts)) =
  29.409 -  let
  29.410 -    val SOME ([], ((st, sty), ds)) = dest_case_expr thy (list_comb (Const c_ty, ts));
  29.411 -    fun clause_gen (dt, bt) =
  29.412 -      exprgen_term thy algbr funcgr dt
  29.413 -      ##>> exprgen_term thy algbr funcgr bt;
  29.414 -  in
  29.415 -    exprgen_term thy algbr funcgr st
  29.416 -    ##>> exprgen_typ thy algbr funcgr sty
  29.417 -    ##>> fold_map clause_gen ds
  29.418 -    ##>> appgen_default thy algbr funcgr app
  29.419 -    #>> (fn (((se, sty), ds), t0) => ICase (((se, sty), ds), t0))
  29.420 -  end;
  29.421 -
  29.422 -fun appgen_let thy algbr funcgr (app as (_, [st, ct])) =
  29.423 -  exprgen_term thy algbr funcgr ct
  29.424 -  ##>> exprgen_term thy algbr funcgr st
  29.425 -  ##>> appgen_default thy algbr funcgr app
  29.426 -  #>> (fn (((v, ty) `|-> be, se), t0) =>
  29.427 -            ICase (CodegenThingol.collapse_let (((v, ty), se), be), t0)
  29.428 -        | (_, t0) => t0);
  29.429 -
  29.430 -fun appgen_if thy algbr funcgr (app as (_, [tb, tt, tf])) =
  29.431 -  exprgen_term thy algbr funcgr tb
  29.432 -  ##>> exprgen_typ thy algbr funcgr (Type ("bool", []))
  29.433 -  ##>> exprgen_term thy algbr funcgr (Const ("True", Type ("bool", [])))
  29.434 -  ##>> exprgen_term thy algbr funcgr tt
  29.435 -  ##>> exprgen_term thy algbr funcgr (Const ("False", Type ("bool", [])))
  29.436 -  ##>> exprgen_term thy algbr funcgr tf
  29.437 -  ##>> appgen_default thy algbr funcgr app
  29.438 -  #>> (fn ((((((tb, B), T), tt), F), tf), t0) => ICase (((tb, B), [(T, tt), (F, tf)]), t0));
  29.439 -
  29.440 -fun add_appconst (c, appgen) thy =
  29.441 -  let
  29.442 -    val i = (length o fst o strip_type o Sign.the_const_type thy) c;
  29.443 -    val _ = Code.change thy (K CodegenThingol.empty_code);
  29.444 -  in
  29.445 -    (Translation.map o apfst)
  29.446 -      (Symtab.update (c, (i, (appgen, stamp ())))) thy
  29.447 -  end;
  29.448 -
  29.449 -
  29.450 -
  29.451 -(** abstype and constsubst interface **)
  29.452 -
  29.453 -local
  29.454 -
  29.455 -fun add_consts thy f (c1, c2 as (c, opt_tyco)) =
  29.456 -  let
  29.457 -    val _ = if
  29.458 -        is_some (AxClass.class_of_param thy c) andalso is_none opt_tyco
  29.459 -        orelse is_some (CodegenData.get_datatype_of_constr thy c2)
  29.460 -      then error ("Not a function: " ^ CodegenConsts.string_of_const thy c2)
  29.461 -      else ();
  29.462 -    val funcgr = Funcgr.make thy [c1, c2];
  29.463 -    val ty1 = (f o CodegenFuncgr.typ funcgr) c1;
  29.464 -    val ty2 = CodegenFuncgr.typ funcgr c2;
  29.465 -    val _ = if Sign.typ_equiv thy (ty1, ty2) then () else
  29.466 -      error ("Incompatiable type signatures of " ^ CodegenConsts.string_of_const thy c1
  29.467 -        ^ " and " ^ CodegenConsts.string_of_const thy c2 ^ ":\n"
  29.468 -        ^ CodegenConsts.string_of_typ thy ty1 ^ "\n" ^ CodegenConsts.string_of_typ thy ty2);
  29.469 -  in Consttab.update (c1, c2) end;
  29.470 -
  29.471 -fun gen_abstyp prep_const prep_typ (raw_abstyp, raw_substtyp) raw_absconsts thy =
  29.472 -  let
  29.473 -    val abstyp = Type.no_tvars (prep_typ thy raw_abstyp);
  29.474 -    val substtyp = Type.no_tvars (prep_typ thy raw_substtyp);
  29.475 -    val absconsts = (map o pairself) (prep_const thy) raw_absconsts;
  29.476 -    val Type (abstyco, tys) = abstyp handle BIND => error ("Bad type: " ^ Sign.string_of_typ thy abstyp);
  29.477 -    val typarms = map (fst o dest_TFree) tys handle MATCH => error ("Bad type: " ^ Sign.string_of_typ thy abstyp);
  29.478 -    fun mk_index v = 
  29.479 -      let
  29.480 -        val k = find_index (fn w => v = w) typarms;
  29.481 -      in if k = ~1
  29.482 -        then error ("Free type variable: " ^ quote v)
  29.483 -        else TFree (string_of_int k, [])
  29.484 -      end;
  29.485 -    val typpat = map_atyps (fn TFree (v, _) => mk_index v) substtyp;
  29.486 -    fun apply_typpat (Type (tyco, tys)) =
  29.487 -          let
  29.488 -            val tys' = map apply_typpat tys;
  29.489 -          in if tyco = abstyco then
  29.490 -            (map_atyps (fn TFree (n, _) => nth tys' (the (Int.fromString n)))) typpat
  29.491 -          else
  29.492 -            Type (tyco, tys')
  29.493 -          end
  29.494 -      | apply_typpat ty = ty;
  29.495 -    val _ = Code.change thy (K CodegenThingol.empty_code);
  29.496 -  in
  29.497 -    thy
  29.498 -    |> (Translation.map o apsnd) (fn (abstypes, abscs) =>
  29.499 -          (abstypes
  29.500 -          |> Symtab.update (abstyco, typpat),
  29.501 -          abscs
  29.502 -          |> fold (add_consts thy apply_typpat) absconsts)
  29.503 -       )
  29.504 -  end;
  29.505 -
  29.506 -fun gen_constsubst prep_const raw_constsubsts thy =
  29.507 -  let
  29.508 -    val constsubsts = (map o pairself) (prep_const thy) raw_constsubsts;
  29.509 -    val _ = Code.change thy (K CodegenThingol.empty_code);
  29.510 -  in
  29.511 -    thy
  29.512 -    |> (Translation.map o apsnd o apsnd) (fold (add_consts thy I) constsubsts)
  29.513 -  end;
  29.514 -
  29.515 -in
  29.516 -
  29.517 -val abstyp = gen_abstyp (K I) Sign.certify_typ;
  29.518 -val abstyp_e = gen_abstyp CodegenConsts.read_const Sign.read_typ;
  29.519 -
  29.520 -val constsubst = gen_constsubst (K I);
  29.521 -val constsubst_e = gen_constsubst CodegenConsts.read_const;
  29.522 -
  29.523 -end; (*local*)
  29.524 -
  29.525 -
  29.526 -(** code generation interfaces **)
  29.527 -
  29.528 -(* generic generation combinators *)
  29.529 -
  29.530 -fun generate thy funcgr gen it =
  29.531 -  let
  29.532 -    (*FIXME*)
  29.533 -    val _ = Funcgr.intervene thy funcgr;
  29.534 -    val cs = map_filter (Consttab.lookup ((snd o snd o Translation.get) thy))
  29.535 -      (CodegenFuncgr.all funcgr);
  29.536 -    val funcgr' = Funcgr.make thy cs;
  29.537 -    val naming = NameSpace.qualified_names NameSpace.default_naming;
  29.538 -    val consttab = Consts.empty
  29.539 -      |> fold (fn c => Consts.declare naming
  29.540 -           ((CodegenNames.const thy c, CodegenFuncgr.typ funcgr' c), true))
  29.541 -           (CodegenFuncgr.all funcgr');
  29.542 -    val algbr = (CodegenData.operational_algebra thy, consttab);
  29.543 -  in   
  29.544 -    Code.change_yield thy
  29.545 -      (CodegenThingol.start_transact (gen thy algbr funcgr' it))
  29.546 -    |> fst
  29.547 -  end;
  29.548 -
  29.549 -fun eval_conv thy conv =
  29.550 -  let
  29.551 -    fun conv' funcgr ct =
  29.552 -      let
  29.553 -        val t = generate thy funcgr exprgen_term' (Thm.term_of ct);
  29.554 -        val consts = CodegenThingol.fold_constnames (insert (op =)) t [];
  29.555 -        val code = Code.get thy
  29.556 -          |> CodegenThingol.project_code true [] (SOME consts)
  29.557 -      in conv code t ct end;
  29.558 -  in Funcgr.eval_conv thy conv' end;
  29.559 -
  29.560 -fun codegen_term thy t =
  29.561 -  let
  29.562 -    val ct = Thm.cterm_of thy t;
  29.563 -    val (ct', funcgr) = Funcgr.make_term thy (K (K K)) ct;
  29.564 -    val t' = Thm.term_of ct';
  29.565 -  in generate thy funcgr exprgen_term' t' end;
  29.566 -
  29.567 -fun raw_eval_term thy (ref_spec, t) args =
  29.568 -  let
  29.569 -    val _ = (Term.map_types o Term.map_atyps) (fn _ =>
  29.570 -      error ("Term " ^ Sign.string_of_term thy t ^ " contains polymorphic type"))
  29.571 -      t;
  29.572 -    val t' = codegen_term thy t;
  29.573 -  in
  29.574 -    CodegenSerializer.eval_term thy CodegenNames.labelled_name
  29.575 -      (Code.get thy) (ref_spec, t') args
  29.576 -  end;
  29.577 -
  29.578 -val satisfies_ref : bool option ref = ref NONE;
  29.579 -
  29.580 -fun eval_term thy t = raw_eval_term thy t [];
  29.581 -fun satisfies thy t witnesses = raw_eval_term thy
  29.582 -  (("CodegenPackage.satisfies_ref", satisfies_ref), t) witnesses;
  29.583 -
  29.584 -fun filter_generatable thy consts =
  29.585 -  let
  29.586 -    val (consts', funcgr) = Funcgr.make_consts thy consts;
  29.587 -    val consts'' = generate thy funcgr (fold_map ooo perhaps_def_const) consts';
  29.588 -    val consts''' = map_filter (fn (const, SOME _) => SOME const | (_, NONE) => NONE)
  29.589 -      (consts' ~~ consts'');
  29.590 -  in consts''' end;
  29.591 -
  29.592 -
  29.593 -(** toplevel interface and setup **)
  29.594 -
  29.595 -local
  29.596 -
  29.597 -structure P = OuterParse
  29.598 -and K = OuterKeyword
  29.599 -
  29.600 -fun code raw_cs seris thy =
  29.601 -  let
  29.602 -    val (perm1, cs) = CodegenConsts.read_const_exprs thy
  29.603 -      (filter_generatable thy) raw_cs;
  29.604 -    val (perm2, cs') = case generate thy (Funcgr.make thy cs) (fold_map ooo ensure_def_const') cs
  29.605 -     of [] => (true, NONE)
  29.606 -      | cs => (false, SOME cs);
  29.607 -    val code = Code.get thy;
  29.608 -    val seris' = map (fn (((target, module), file), args) =>
  29.609 -      CodegenSerializer.get_serializer thy target (perm1 orelse perm2) module file args
  29.610 -        CodegenNames.labelled_name cs') seris;
  29.611 -  in
  29.612 -    (map (fn f => f code) seris' : unit list; ())
  29.613 -  end;
  29.614 -
  29.615 -fun code_thms_cmd thy =
  29.616 -  code_thms thy o snd o CodegenConsts.read_const_exprs thy (fst o Funcgr.make_consts thy);
  29.617 -
  29.618 -fun code_deps_cmd thy =
  29.619 -  code_deps thy o snd o CodegenConsts.read_const_exprs thy (fst o Funcgr.make_consts thy);
  29.620 -
  29.621 -val (inK, toK, fileK) = ("in", "to", "file");
  29.622 -
  29.623 -val code_exprP =
  29.624 -  (Scan.repeat P.term
  29.625 -  -- Scan.repeat (P.$$$ inK |-- P.name
  29.626 -     -- Scan.option (P.$$$ toK |-- P.name)
  29.627 -     -- Scan.option (P.$$$ fileK |-- P.name)
  29.628 -     -- Scan.optional (P.$$$ "(" |-- P.arguments --| P.$$$ ")") []
  29.629 -  ) >> (fn (raw_cs, seris) => code raw_cs seris));
  29.630 -
  29.631 -val _ = OuterSyntax.add_keywords [inK, toK, fileK];
  29.632 -
  29.633 -val (codeK, code_abstypeK, code_axiomsK, code_thmsK, code_depsK) =
  29.634 -  ("code_gen", "code_abstype", "code_axioms", "code_thms", "code_deps");
  29.635 -
  29.636 -in
  29.637 -
  29.638 -val codeP =
  29.639 -  OuterSyntax.improper_command codeK "generate executable code for constants"
  29.640 -    K.diag (P.!!! code_exprP >> (fn f => Toplevel.keep (f o Toplevel.theory_of)));
  29.641 -
  29.642 -fun codegen_command thy cmd =
  29.643 -  case Scan.read OuterLex.stopper (P.!!! code_exprP) ((filter OuterLex.is_proper o OuterSyntax.scan) cmd)
  29.644 -   of SOME f => (writeln "Now generating code..."; f thy)
  29.645 -    | NONE => error ("Bad directive " ^ quote cmd);
  29.646 -
  29.647 -val code_abstypeP =
  29.648 -  OuterSyntax.command code_abstypeK "axiomatic abstypes for code generation" K.thy_decl (
  29.649 -    (P.typ -- P.typ -- Scan.optional (P.$$$ "where" |-- Scan.repeat1
  29.650 -        (P.term --| (P.$$$ "\\<equiv>" || P.$$$ "==") -- P.term)) [])
  29.651 -    >> (Toplevel.theory o uncurry abstyp_e)
  29.652 -  );
  29.653 -
  29.654 -val code_axiomsP =
  29.655 -  OuterSyntax.command code_axiomsK "axiomatic constant equalities for code generation" K.thy_decl (
  29.656 -    Scan.repeat1 (P.term --| (P.$$$ "\\<equiv>" || P.$$$ "==") -- P.term)
  29.657 -    >> (Toplevel.theory o constsubst_e)
  29.658 -  );
  29.659 -
  29.660 -val code_thmsP =
  29.661 -  OuterSyntax.improper_command code_thmsK "print system of defining equations for code" OuterKeyword.diag
  29.662 -    (Scan.repeat P.term
  29.663 -      >> (fn cs => Toplevel.no_timing o Toplevel.unknown_theory
  29.664 -        o Toplevel.keep ((fn thy => code_thms_cmd thy cs) o Toplevel.theory_of)));
  29.665 -
  29.666 -val code_depsP =
  29.667 -  OuterSyntax.improper_command code_depsK "visualize dependencies of defining equations for code" OuterKeyword.diag
  29.668 -    (Scan.repeat P.term
  29.669 -      >> (fn cs => Toplevel.no_timing o Toplevel.unknown_theory
  29.670 -        o Toplevel.keep ((fn thy => code_deps_cmd thy cs) o Toplevel.theory_of)));
  29.671 -
  29.672 -val _ = OuterSyntax.add_parsers [codeP, code_abstypeP, code_axiomsP, code_thmsP, code_depsP];
  29.673 -
  29.674 -end; (* local *)
  29.675 -
  29.676 -end; (* struct *)
    30.1 --- a/src/Pure/Tools/codegen_serializer.ML	Fri Aug 10 17:04:24 2007 +0200
    30.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    30.3 @@ -1,2215 +0,0 @@
    30.4 -(*  Title:      Pure/Tools/codegen_serializer.ML
    30.5 -    ID:         $Id$
    30.6 -    Author:     Florian Haftmann, TU Muenchen
    30.7 -
    30.8 -Serializer from intermediate language ("Thin-gol") to
    30.9 -target languages (like SML or Haskell).
   30.10 -*)
   30.11 -
   30.12 -signature CODEGEN_SERIALIZER =
   30.13 -sig
   30.14 -  include BASIC_CODEGEN_THINGOL;
   30.15 -
   30.16 -  val add_syntax_class: string -> class
   30.17 -    -> (string * (CodegenConsts.const * string) list) option -> theory -> theory;
   30.18 -  val add_syntax_inst: string -> string * class -> bool -> theory -> theory;
   30.19 -  val add_syntax_tycoP: string -> string -> OuterParse.token list
   30.20 -    -> (theory -> theory) * OuterParse.token list;
   30.21 -  val add_syntax_constP: string -> string -> OuterParse.token list
   30.22 -    -> (theory -> theory) * OuterParse.token list;
   30.23 -
   30.24 -  val add_undefined: string -> string -> string -> theory -> theory;
   30.25 -  val add_pretty_list: string -> string -> string -> theory -> theory;
   30.26 -  val add_pretty_list_string: string -> string -> string
   30.27 -    -> string -> string list -> theory -> theory;
   30.28 -  val add_pretty_char: string -> string -> string list -> theory -> theory
   30.29 -  val add_pretty_numeral: string -> bool -> string * typ -> string -> string -> string
   30.30 -    -> string -> string -> theory -> theory;
   30.31 -  val add_pretty_ml_string: string -> string -> string list -> string
   30.32 -    -> string -> string -> theory -> theory;
   30.33 -  val add_pretty_imperative_monad_bind: string -> string -> theory -> theory;
   30.34 -
   30.35 -  type serializer;
   30.36 -  val add_serializer: string * serializer -> theory -> theory;
   30.37 -  val get_serializer: theory -> string -> bool -> string option -> string option -> Args.T list
   30.38 -    -> (theory -> string -> string) -> string list option -> CodegenThingol.code -> unit;
   30.39 -  val assert_serializer: theory -> string -> string;
   30.40 -
   30.41 -  val eval_verbose: bool ref;
   30.42 -  val eval_term: theory -> (theory -> string -> string) -> CodegenThingol.code
   30.43 -    -> (string * 'a option ref) * CodegenThingol.iterm -> string list -> 'a;
   30.44 -  val code_width: int ref;
   30.45 -end;
   30.46 -
   30.47 -structure CodegenSerializer : CODEGEN_SERIALIZER =
   30.48 -struct
   30.49 -
   30.50 -open BasicCodegenThingol;
   30.51 -val tracing = CodegenThingol.tracing;
   30.52 -
   30.53 -(** basics **)
   30.54 -
   30.55 -infixr 5 @@;
   30.56 -infixr 5 @|;
   30.57 -fun x @@ y = [x, y];
   30.58 -fun xs @| y = xs @ [y];
   30.59 -val str = PrintMode.with_default Pretty.str;
   30.60 -val concat = Pretty.block o Pretty.breaks;
   30.61 -val brackets = Pretty.enclose "(" ")" o Pretty.breaks;
   30.62 -fun semicolon ps = Pretty.block [concat ps, str ";"];
   30.63 -
   30.64 -
   30.65 -(** syntax **)
   30.66 -
   30.67 -datatype lrx = L | R | X;
   30.68 -
   30.69 -datatype fixity =
   30.70 -    BR
   30.71 -  | NOBR
   30.72 -  | INFX of (int * lrx);
   30.73 -
   30.74 -val APP = INFX (~1, L);
   30.75 -
   30.76 -fun eval_lrx L L = false
   30.77 -  | eval_lrx R R = false
   30.78 -  | eval_lrx _ _ = true;
   30.79 -
   30.80 -fun eval_fxy NOBR NOBR = false
   30.81 -  | eval_fxy BR NOBR = false
   30.82 -  | eval_fxy NOBR BR = false
   30.83 -  | eval_fxy (INFX (pr, lr)) (INFX (pr_ctxt, lr_ctxt)) =
   30.84 -      pr < pr_ctxt
   30.85 -      orelse pr = pr_ctxt
   30.86 -        andalso eval_lrx lr lr_ctxt
   30.87 -      orelse pr_ctxt = ~1
   30.88 -  | eval_fxy _ (INFX _) = false
   30.89 -  | eval_fxy (INFX _) NOBR = false
   30.90 -  | eval_fxy _ _ = true;
   30.91 -
   30.92 -fun gen_brackify _ [p] = p
   30.93 -  | gen_brackify true (ps as _::_) = Pretty.enclose "(" ")" ps
   30.94 -  | gen_brackify false (ps as _::_) = Pretty.block ps;
   30.95 -
   30.96 -fun brackify fxy_ctxt ps =
   30.97 -  gen_brackify (eval_fxy BR fxy_ctxt) (Pretty.breaks ps);
   30.98 -
   30.99 -fun brackify_infix infx fxy_ctxt ps =
  30.100 -  gen_brackify (eval_fxy (INFX infx) fxy_ctxt) (Pretty.breaks ps);
  30.101 -
  30.102 -type class_syntax = string * (string -> string option);
  30.103 -type typ_syntax = int * ((fixity -> itype -> Pretty.T)
  30.104 -  -> fixity -> itype list -> Pretty.T);
  30.105 -type term_syntax = int * ((CodegenNames.var_ctxt -> fixity -> iterm -> Pretty.T)
  30.106 -  -> CodegenNames.var_ctxt -> fixity -> (iterm * itype) list -> Pretty.T);
  30.107 -
  30.108 -
  30.109 -(* user-defined syntax *)
  30.110 -
  30.111 -datatype 'a mixfix =
  30.112 -    Arg of fixity
  30.113 -  | Pretty of Pretty.T;
  30.114 -
  30.115 -fun mk_mixfix prep_arg (fixity_this, mfx) =
  30.116 -  let
  30.117 -    fun is_arg (Arg _) = true
  30.118 -      | is_arg _ = false;
  30.119 -    val i = (length o filter is_arg) mfx;
  30.120 -    fun fillin _ [] [] =
  30.121 -          []
  30.122 -      | fillin pr (Arg fxy :: mfx) (a :: args) =
  30.123 -          (pr fxy o prep_arg) a :: fillin pr mfx args
  30.124 -      | fillin pr (Pretty p :: mfx) args =
  30.125 -          p :: fillin pr mfx args
  30.126 -      | fillin _ [] _ =
  30.127 -          error ("Inconsistent mixfix: too many arguments")
  30.128 -      | fillin _ _ [] =
  30.129 -          error ("Inconsistent mixfix: too less arguments");
  30.130 -  in
  30.131 -    (i, fn pr => fn fixity_ctxt => fn args =>
  30.132 -      gen_brackify (eval_fxy fixity_this fixity_ctxt) (fillin pr mfx args))
  30.133 -  end;
  30.134 -
  30.135 -fun parse_infix prep_arg (x, i) s =
  30.136 -  let
  30.137 -    val l = case x of L => INFX (i, L) | _ => INFX (i, X);
  30.138 -    val r = case x of R => INFX (i, R) | _ => INFX (i, X);
  30.139 -  in
  30.140 -    mk_mixfix prep_arg (INFX (i, x), [Arg l, (Pretty o Pretty.brk) 1, (Pretty o str) s, (Pretty o Pretty.brk) 1, Arg r])
  30.141 -  end;
  30.142 -
  30.143 -fun parse_mixfix prep_arg s =
  30.144 -  let
  30.145 -    val sym_any = Scan.one Symbol.is_regular;
  30.146 -    val parse = Scan.optional ($$ "!" >> K true) false -- Scan.repeat (
  30.147 -         ($$ "(" -- $$ "_" -- $$ ")" >> K (Arg NOBR))
  30.148 -      || ($$ "_" >> K (Arg BR))
  30.149 -      || ($$ "/" |-- Scan.repeat ($$ " ") >> (Pretty o Pretty.brk o length))
  30.150 -      || (Scan.repeat1
  30.151 -           (   $$ "'" |-- sym_any
  30.152 -            || Scan.unless ($$ "_" || $$ "/" || $$ "(" |-- $$ "_" |-- $$ ")")
  30.153 -                 sym_any) >> (Pretty o str o implode)));
  30.154 -  in case Scan.finite Symbol.stopper parse (Symbol.explode s)
  30.155 -   of ((_, p as [_]), []) => mk_mixfix prep_arg (NOBR, p)
  30.156 -    | ((b, p as _ :: _ :: _), []) => mk_mixfix prep_arg (if b then NOBR else BR, p)
  30.157 -    | _ => Scan.!! (the_default ("malformed mixfix annotation: " ^ quote s) o snd) Scan.fail ()
  30.158 -  end;
  30.159 -
  30.160 -fun parse_args f args =
  30.161 -  case Scan.read Args.stopper f args
  30.162 -   of SOME x => x
  30.163 -    | NONE => error "Bad serializer arguments";
  30.164 -
  30.165 -
  30.166 -(* generic serializer combinators *)
  30.167 -
  30.168 -fun gen_pr_app pr_app' pr_term const_syntax labelled_name is_cons
  30.169 -      lhs vars fxy (app as ((c, (_, tys)), ts)) =
  30.170 -  case const_syntax c
  30.171 -   of NONE => if lhs andalso not (is_cons c) then
  30.172 -          error ("non-constructor on left hand side of equation: " ^ labelled_name c)
  30.173 -        else brackify fxy (pr_app' lhs vars app)
  30.174 -    | SOME (i, pr) =>
  30.175 -        let
  30.176 -          val k = if i < 0 then length tys else i;
  30.177 -          fun pr' fxy ts = pr (pr_term lhs) vars fxy (ts ~~ curry Library.take k tys);
  30.178 -        in if k = length ts
  30.179 -          then pr' fxy ts
  30.180 -        else if k < length ts
  30.181 -          then case chop k ts of (ts1, ts2) =>
  30.182 -            brackify fxy (pr' APP ts1 :: map (pr_term lhs vars BR) ts2)
  30.183 -          else pr_term lhs vars fxy (CodegenThingol.eta_expand app k)
  30.184 -        end;
  30.185 -
  30.186 -fun gen_pr_bind pr_bind' pr_term fxy ((v, pat), ty) vars =
  30.187 -  let
  30.188 -    val vs = case pat
  30.189 -     of SOME pat => CodegenThingol.fold_varnames (insert (op =)) pat []
  30.190 -      | NONE => [];
  30.191 -    val vars' = CodegenNames.intro_vars (the_list v) vars;
  30.192 -    val vars'' = CodegenNames.intro_vars vs vars';
  30.193 -    val v' = Option.map (CodegenNames.lookup_var vars') v;
  30.194 -    val pat' = Option.map (pr_term vars'' fxy) pat;
  30.195 -  in (pr_bind' ((v', pat'), ty), vars'') end;
  30.196 -
  30.197 -
  30.198 -(* list, char, string, numeral and monad abstract syntax transformations *)
  30.199 -
  30.200 -fun implode_list c_nil c_cons t =
  30.201 -  let
  30.202 -    fun dest_cons (IConst (c, _) `$ t1 `$ t2) =
  30.203 -          if c = c_cons
  30.204 -          then SOME (t1, t2)
  30.205 -          else NONE
  30.206 -      | dest_cons _ = NONE;
  30.207 -    val (ts, t') = CodegenThingol.unfoldr dest_cons t;
  30.208 -  in case t'
  30.209 -   of IConst (c, _) => if c = c_nil then SOME ts else NONE
  30.210 -    | _ => NONE
  30.211 -  end;
  30.212 -
  30.213 -fun decode_char c_nibbles (IConst (c1, _), IConst (c2, _)) =
  30.214 -      let
  30.215 -        fun idx c = find_index (curry (op =) c) c_nibbles;
  30.216 -        fun decode ~1 _ = NONE
  30.217 -          | decode _ ~1 = NONE
  30.218 -          | decode n m = SOME (chr (n * 16 + m));
  30.219 -      in decode (idx c1) (idx c2) end
  30.220 -  | decode_char _ _ = NONE;
  30.221 -
  30.222 -fun implode_string c_char c_nibbles mk_char mk_string ts =
  30.223 -  let
  30.224 -    fun implode_char (IConst (c, _) `$ t1 `$ t2) =
  30.225 -          if c = c_char then decode_char c_nibbles (t1, t2) else NONE
  30.226 -      | implode_char _ = NONE;
  30.227 -    val ts' = map implode_char ts;
  30.228 -  in if forall is_some ts'
  30.229 -    then (SOME o str o mk_string o implode o map_filter I) ts'
  30.230 -    else NONE
  30.231 -  end;
  30.232 -
  30.233 -fun implode_numeral c_bit0 c_bit1 c_pls c_min c_bit =
  30.234 -  let
  30.235 -    fun dest_bit (IConst (c, _)) = if c = c_bit0 then SOME 0
  30.236 -          else if c = c_bit1 then SOME 1
  30.237 -          else NONE
  30.238 -      | dest_bit _ = NONE;
  30.239 -    fun dest_numeral (IConst (c, _)) = if c = c_pls then SOME (IntInf.fromInt 0)
  30.240 -          else if c = c_min then SOME (IntInf.fromInt ~1)
  30.241 -          else NONE
  30.242 -      | dest_numeral (IConst (c, _) `$ t1 `$ t2) =
  30.243 -          if c = c_bit then case (dest_numeral t1, dest_bit t2)
  30.244 -           of (SOME n, SOME b) => SOME (IntInf.fromInt 2 * n + IntInf.fromInt b)
  30.245 -            | _ => NONE
  30.246 -          else NONE
  30.247 -      | dest_numeral _ = NONE;
  30.248 -  in dest_numeral end;
  30.249 -
  30.250 -fun implode_monad c_mbind c_kbind t =
  30.251 -  let
  30.252 -    fun dest_monad (IConst (c, _) `$ t1 `$ t2) =
  30.253 -          if c = c_mbind
  30.254 -            then case CodegenThingol.split_abs t2
  30.255 -             of SOME (((v, pat), ty), t') => SOME ((SOME (((SOME v, pat), ty), true), t1), t')
  30.256 -              | NONE => NONE
  30.257 -          else if c = c_kbind
  30.258 -            then SOME ((NONE, t1), t2)
  30.259 -            else NONE
  30.260 -      | dest_monad t = case CodegenThingol.split_let t
  30.261 -           of SOME (((pat, ty), tbind), t') => SOME ((SOME (((NONE, SOME pat), ty), false), tbind), t')
  30.262 -            | NONE => NONE;
  30.263 -  in CodegenThingol.unfoldr dest_monad t end;
  30.264 -
  30.265 -
  30.266 -(** name auxiliary **)
  30.267 -
  30.268 -val first_upper = implode o nth_map 0 Symbol.to_ascii_upper o explode;
  30.269 -val first_lower = implode o nth_map 0 Symbol.to_ascii_lower o explode;
  30.270 -
  30.271 -val dest_name =
  30.272 -  apfst NameSpace.implode o split_last o fst o split_last o NameSpace.explode;
  30.273 -
  30.274 -fun mk_modl_name_tab init_names prefix module_alias code =
  30.275 -  let
  30.276 -    fun nsp_map f = NameSpace.explode #> map f #> NameSpace.implode;
  30.277 -    fun mk_alias name =
  30.278 -     case module_alias name
  30.279 -      of SOME name' => name'
  30.280 -       | NONE => nsp_map (fn name => (the_single o fst)
  30.281 -            (Name.variants [name] init_names)) name;
  30.282 -    fun mk_prefix name =
  30.283 -      case prefix
  30.284 -       of SOME prefix => NameSpace.append prefix name
  30.285 -        | NONE => name;
  30.286 -    val tab =
  30.287 -      Symtab.empty
  30.288 -      |> Graph.fold ((fn name => Symtab.default (name, (mk_alias #> mk_prefix) name))
  30.289 -           o fst o dest_name o fst)
  30.290 -             code
  30.291 -  in fn name => (the o Symtab.lookup tab) name end;
  30.292 -
  30.293 -
  30.294 -
  30.295 -(** SML/OCaml serializer **)
  30.296 -
  30.297 -datatype ml_def =
  30.298 -    MLFuns of (string * ((iterm list * iterm) list * typscheme)) list
  30.299 -  | MLDatas of (string * ((vname * sort) list * (string * itype list) list)) list
  30.300 -  | MLClass of string * ((class * string) list * (vname * (string * itype) list))
  30.301 -  | MLClassinst of string * ((class * (string * (vname * sort) list))
  30.302 -        * ((class * (string * (string * dict list list))) list
  30.303 -      * (string * iterm) list));
  30.304 -
  30.305 -fun pr_sml tyco_syntax const_syntax labelled_name init_syms deresolv is_cons ml_def =
  30.306 -  let
  30.307 -    val pr_label_classrel = translate_string (fn "." => "__" | c => c) o NameSpace.qualifier;
  30.308 -    val pr_label_classop = NameSpace.base o NameSpace.qualifier;
  30.309 -    fun pr_dicts fxy ds =
  30.310 -      let
  30.311 -        fun pr_dictvar (v, (_, 1)) = first_upper v ^ "_"
  30.312 -          | pr_dictvar (v, (i, _)) = first_upper v ^ string_of_int (i+1) ^ "_";
  30.313 -        fun pr_proj [] p =
  30.314 -              p
  30.315 -          | pr_proj [p'] p =
  30.316 -              brackets [p', p]
  30.317 -          | pr_proj (ps as _ :: _) p =
  30.318 -              brackets [Pretty.enum " o" "(" ")" ps, p];
  30.319 -        fun pr_dictc fxy (DictConst (inst, dss)) =
  30.320 -              brackify fxy ((str o deresolv) inst :: map (pr_dicts BR) dss)
  30.321 -          | pr_dictc fxy (DictVar (classrels, v)) =
  30.322 -              pr_proj (map (str o deresolv) classrels) ((str o pr_dictvar) v)
  30.323 -      in case ds
  30.324 -       of [] => str "()"
  30.325 -        | [d] => pr_dictc fxy d
  30.326 -        | _ :: _ => (Pretty.list "(" ")" o map (pr_dictc NOBR)) ds
  30.327 -      end;
  30.328 -    fun pr_tyvars vs =
  30.329 -      vs
  30.330 -      |> map (fn (v, sort) => map_index (fn (i, _) => DictVar ([], (v, (i, length sort)))) sort)
  30.331 -      |> map (pr_dicts BR);
  30.332 -    fun pr_tycoexpr fxy (tyco, tys) =
  30.333 -      let
  30.334 -        val tyco' = (str o deresolv) tyco
  30.335 -      in case map (pr_typ BR) tys
  30.336 -       of [] => tyco'
  30.337 -        | [p] => Pretty.block [p, Pretty.brk 1, tyco']
  30.338 -        | (ps as _::_) => Pretty.block [Pretty.list "(" ")" ps, Pretty.brk 1, tyco']
  30.339 -      end
  30.340 -    and pr_typ fxy (tyco `%% tys) =
  30.341 -          (case tyco_syntax tyco
  30.342 -           of NONE => pr_tycoexpr fxy (tyco, tys)
  30.343 -            | SOME (i, pr) =>
  30.344 -                if not (i = length tys)
  30.345 -                then error ("Number of argument mismatch in customary serialization: "
  30.346 -                  ^ (string_of_int o length) tys ^ " given, "
  30.347 -                  ^ string_of_int i ^ " expected")
  30.348 -                else pr pr_typ fxy tys)
  30.349 -      | pr_typ fxy (ITyVar v) =
  30.350 -          str ("'" ^ v);
  30.351 -    fun pr_term lhs vars fxy (IConst c) =
  30.352 -          pr_app lhs vars fxy (c, [])
  30.353 -      | pr_term lhs vars fxy (IVar v) =
  30.354 -          str (CodegenNames.lookup_var vars v)
  30.355 -      | pr_term lhs vars fxy (t as t1 `$ t2) =
  30.356 -          (case CodegenThingol.unfold_const_app t
  30.357 -           of SOME c_ts => pr_app lhs vars fxy c_ts
  30.358 -            | NONE =>
  30.359 -                brackify fxy [pr_term lhs vars NOBR t1, pr_term lhs vars BR t2])
  30.360 -      | pr_term lhs vars fxy (t as _ `|-> _) =
  30.361 -          let
  30.362 -            val (binds, t') = CodegenThingol.unfold_abs t;
  30.363 -            fun pr ((v, pat), ty) =
  30.364 -              pr_bind NOBR ((SOME v, pat), ty)
  30.365 -              #>> (fn p => concat [str "fn", p, str "=>"]);
  30.366 -            val (ps, vars') = fold_map pr binds vars;
  30.367 -          in brackets (ps @ [pr_term lhs vars' NOBR t']) end
  30.368 -      | pr_term lhs vars fxy (ICase (cases as (_, t0))) = (case CodegenThingol.unfold_const_app t0
  30.369 -           of SOME (c_ts as ((c, _), _)) => if is_none (const_syntax c)
  30.370 -                then pr_case vars fxy cases
  30.371 -                else pr_app lhs vars fxy c_ts
  30.372 -            | NONE => pr_case vars fxy cases)
  30.373 -    and pr_app' lhs vars (app as ((c, (iss, tys)), ts)) =
  30.374 -      if is_cons c then let
  30.375 -        val k = length tys
  30.376 -      in if k < 2 then 
  30.377 -        (str o deresolv) c :: map (pr_term lhs vars BR) ts
  30.378 -      else if k = length ts then
  30.379 -        [(str o deresolv) c, Pretty.enum "," "(" ")" (map (pr_term lhs vars NOBR) ts)]
  30.380 -      else [pr_term lhs vars BR (CodegenThingol.eta_expand app k)] end else
  30.381 -        (str o deresolv) c
  30.382 -          :: (map (pr_dicts BR) o filter_out null) iss @ map (pr_term lhs vars BR) ts
  30.383 -    and pr_app lhs vars = gen_pr_app pr_app' pr_term const_syntax labelled_name is_cons lhs vars
  30.384 -    and pr_bind' ((NONE, NONE), _) = str "_"
  30.385 -      | pr_bind' ((SOME v, NONE), _) = str v
  30.386 -      | pr_bind' ((NONE, SOME p), _) = p
  30.387 -      | pr_bind' ((SOME v, SOME p), _) = concat [str v, str "as", p]
  30.388 -    and pr_bind fxy = gen_pr_bind pr_bind' (pr_term false) fxy
  30.389 -    and pr_case vars fxy (cases as ((_, [_]), _)) =
  30.390 -          let
  30.391 -            val (binds, t') = CodegenThingol.unfold_let (ICase cases);
  30.392 -            fun pr ((pat, ty), t) vars =
  30.393 -              vars
  30.394 -              |> pr_bind NOBR ((NONE, SOME pat), ty)
  30.395 -              |>> (fn p => semicolon [str "val", p, str "=", pr_term false vars NOBR t])
  30.396 -            val (ps, vars') = fold_map pr binds vars;
  30.397 -          in
  30.398 -            Pretty.chunks [
  30.399 -              [str ("let"), Pretty.fbrk, Pretty.chunks ps] |> Pretty.block,
  30.400 -              [str ("in"), Pretty.fbrk, pr_term false vars' NOBR t'] |> Pretty.block,
  30.401 -              str ("end")
  30.402 -            ]
  30.403 -          end
  30.404 -      | pr_case vars fxy (((td, ty), b::bs), _) =
  30.405 -          let
  30.406 -            fun pr delim (pat, t) =
  30.407 -              let
  30.408 -                val (p, vars') = pr_bind NOBR ((NONE, SOME pat), ty) vars;
  30.409 -              in
  30.410 -                concat [str delim, p, str "=>", pr_term false vars' NOBR t]
  30.411 -              end;
  30.412 -          in
  30.413 -            (Pretty.enclose "(" ")" o single o brackify fxy) (
  30.414 -              str "case"
  30.415 -              :: pr_term false vars NOBR td
  30.416 -              :: pr "of" b
  30.417 -              :: map (pr "|") bs
  30.418 -            )
  30.419 -          end
  30.420 -      | pr_case vars fxy ((_, []), _) = str "raise Fail \"empty case\""
  30.421 -    fun pr_def (MLFuns (funns as (funn :: funns'))) =
  30.422 -          let
  30.423 -            val definer =
  30.424 -              let
  30.425 -                fun mk [] [] = "val"
  30.426 -                  | mk (_::_) _ = "fun"
  30.427 -                  | mk [] vs = if (null o filter_out (null o snd)) vs then "val" else "fun";
  30.428 -                fun chk (_, ((ts, _) :: _, (vs, _))) NONE = SOME (mk ts vs)
  30.429 -                  | chk (_, ((ts, _) :: _, (vs, _))) (SOME defi) =
  30.430 -                      if defi = mk ts vs then SOME defi
  30.431 -                      else error ("Mixing simultaneous vals and funs not implemented: "
  30.432 -                        ^ commas (map (labelled_name o fst) funns));
  30.433 -              in the (fold chk funns NONE) end;
  30.434 -            fun pr_funn definer (name, (eqs as eq::eqs', (raw_vs, ty))) =
  30.435 -              let
  30.436 -                val vs = filter_out (null o snd) raw_vs;
  30.437 -                val shift = if null eqs' then I else
  30.438 -                  map (Pretty.block o single o Pretty.block o single);
  30.439 -                fun pr_eq definer (ts, t) =
  30.440 -                  let
  30.441 -                    val consts = map_filter
  30.442 -                      (fn c => if (is_some o const_syntax) c
  30.443 -                        then NONE else (SOME o NameSpace.base o deresolv) c)
  30.444 -                        ((fold o CodegenThingol.fold_constnames) (insert (op =)) (t :: ts) []);
  30.445 -                    val vars = init_syms
  30.446 -                      |> CodegenNames.intro_vars consts
  30.447 -                      |> CodegenNames.intro_vars ((fold o CodegenThingol.fold_unbound_varnames)
  30.448 -                           (insert (op =)) ts []);
  30.449 -                  in
  30.450 -                    concat (
  30.451 -                      [str definer, (str o deresolv) name]
  30.452 -                      @ (if null ts andalso null vs
  30.453 -                           andalso not (ty = ITyVar "_")(*for evaluation*)
  30.454 -                         then [str ":", pr_typ NOBR ty]
  30.455 -                         else
  30.456 -                           pr_tyvars vs
  30.457 -                           @ map (pr_term true vars BR) ts)
  30.458 -                   @ [str "=", pr_term false vars NOBR t]
  30.459 -                    )
  30.460 -                  end
  30.461 -              in
  30.462 -                (Pretty.block o Pretty.fbreaks o shift) (
  30.463 -                  pr_eq definer eq
  30.464 -                  :: map (pr_eq "|") eqs'
  30.465 -                )
  30.466 -              end;
  30.467 -            val (ps, p) = split_last (pr_funn definer funn :: map (pr_funn "and") funns');
  30.468 -          in Pretty.chunks (ps @ [Pretty.block ([p, str ";"])]) end
  30.469 -     | pr_def (MLDatas (datas as (data :: datas'))) =
  30.470 -          let
  30.471 -            fun pr_co (co, []) =
  30.472 -                  str (deresolv co)
  30.473 -              | pr_co (co, tys) =
  30.474 -                  concat [
  30.475 -                    str (deresolv co),
  30.476 -                    str "of",
  30.477 -                    Pretty.enum " *" "" "" (map (pr_typ (INFX (2, X))) tys)
  30.478 -                  ];
  30.479 -            fun pr_data definer (tyco, (vs, [])) =
  30.480 -                  concat (
  30.481 -                    str definer
  30.482 -                    :: pr_tycoexpr NOBR (tyco, map (ITyVar o fst) vs)
  30.483 -                    :: str "="
  30.484 -                    @@ str "EMPTY__" 
  30.485 -                  )
  30.486 -              | pr_data definer (tyco, (vs, cos)) =
  30.487 -                  concat (
  30.488 -                    str definer
  30.489 -                    :: pr_tycoexpr NOBR (tyco, map (ITyVar o fst) vs)
  30.490 -                    :: str "="
  30.491 -                    :: separate (str "|") (map pr_co cos)
  30.492 -                  );
  30.493 -            val (ps, p) = split_last (pr_data "datatype" data :: map (pr_data "and") datas');
  30.494 -          in Pretty.chunks (ps @ [Pretty.block ([p, str ";"])]) end
  30.495 -     | pr_def (MLClass (class, (superclasses, (v, classops)))) =
  30.496 -          let
  30.497 -            val w = first_upper v ^ "_";
  30.498 -            fun pr_superclass_field (class, classrel) =
  30.499 -              (concat o map str) [
  30.500 -                pr_label_classrel classrel, ":", "'" ^ v, deresolv class
  30.501 -              ];
  30.502 -            fun pr_classop_field (classop, ty) =
  30.503 -              concat [
  30.504 -                (str o pr_label_classop) classop, str ":", pr_typ NOBR ty
  30.505 -              ];
  30.506 -            fun pr_classop_proj (classop, _) =
  30.507 -              semicolon [
  30.508 -                str "fun",
  30.509 -                (str o deresolv) classop,
  30.510 -                Pretty.enclose "(" ")" [str (w ^ ":'" ^ v ^ " " ^ deresolv class)],
  30.511 -                str "=",
  30.512 -                str ("#" ^ pr_label_classop classop),
  30.513 -                str w
  30.514 -              ];
  30.515 -            fun pr_superclass_proj (_, classrel) =
  30.516 -              semicolon [
  30.517 -                str "fun",
  30.518 -                (str o deresolv) classrel,
  30.519 -                Pretty.enclose "(" ")" [str (w ^ ":'" ^ v ^ " " ^ deresolv class)],
  30.520 -                str "=",
  30.521 -                str ("#" ^ pr_label_classrel classrel),
  30.522 -                str w
  30.523 -              ];
  30.524 -          in
  30.525 -            Pretty.chunks (
  30.526 -              concat [
  30.527 -                str ("type '" ^ v),
  30.528 -                (str o deresolv) class,
  30.529 -                str "=",
  30.530 -                Pretty.enum "," "{" "};" (
  30.531 -                  map pr_superclass_field superclasses @ map pr_classop_field classops
  30.532 -                )
  30.533 -              ]
  30.534 -              :: map pr_superclass_proj superclasses
  30.535 -              @ map pr_classop_proj classops
  30.536 -            )
  30.537 -          end
  30.538 -     | pr_def (MLClassinst (inst, ((class, (tyco, arity)), (superarities, classop_defs)))) =
  30.539 -          let
  30.540 -            fun pr_superclass (_, (classrel, dss)) =
  30.541 -              concat [
  30.542 -                (str o pr_label_classrel) classrel,
  30.543 -                str "=",
  30.544 -                pr_dicts NOBR [DictConst dss]
  30.545 -              ];
  30.546 -            fun pr_classop (classop, t) =
  30.547 -              let
  30.548 -                val consts = map_filter
  30.549 -                  (fn c => if (is_some o const_syntax) c
  30.550 -                    then NONE else (SOME o NameSpace.base o deresolv) c)
  30.551 -                    (CodegenThingol.fold_constnames (insert (op =)) t []);
  30.552 -                val vars = CodegenNames.intro_vars consts init_syms;
  30.553 -              in
  30.554 -                concat [
  30.555 -                  (str o pr_label_classop) classop,
  30.556 -                  str "=",
  30.557 -                  pr_term false vars NOBR t
  30.558 -                ]
  30.559 -              end;
  30.560 -          in
  30.561 -            semicolon ([
  30.562 -              str (if null arity then "val" else "fun"),
  30.563 -              (str o deresolv) inst ] @
  30.564 -              pr_tyvars arity @ [
  30.565 -              str "=",
  30.566 -              Pretty.enum "," "{" "}" (map pr_superclass superarities @ map pr_classop classop_defs),
  30.567 -              str ":",
  30.568 -              pr_tycoexpr NOBR (class, [tyco `%% map (ITyVar o fst) arity])
  30.569 -            ])
  30.570 -          end;
  30.571 -  in pr_def ml_def end;
  30.572 -
  30.573 -fun pr_sml_modl name content =
  30.574 -  Pretty.chunks ([
  30.575 -    str ("structure " ^ name ^ " = "),
  30.576 -    str "struct",
  30.577 -    str ""
  30.578 -  ] @ content @ [
  30.579 -    str "",
  30.580 -    str ("end; (*struct " ^ name ^ "*)")
  30.581 -  ]);
  30.582 -
  30.583 -fun pr_ocaml tyco_syntax const_syntax labelled_name init_syms deresolv is_cons ml_def =
  30.584 -  let
  30.585 -    fun pr_dicts fxy ds =
  30.586 -      let
  30.587 -        fun pr_dictvar (v, (_, 1)) = "_" ^ first_upper v
  30.588 -          | pr_dictvar (v, (i, _)) = "_" ^ first_upper v ^ string_of_int (i+1);
  30.589 -        fun pr_proj ps p =
  30.590 -          fold_rev (fn p2 => fn p1 => Pretty.block [p1, str ".", str p2]) ps p
  30.591 -        fun pr_dictc fxy (DictConst (inst, dss)) =
  30.592 -              brackify fxy ((str o deresolv) inst :: map (pr_dicts BR) dss)
  30.593 -          | pr_dictc fxy (DictVar (classrels, v)) =
  30.594 -              pr_proj (map deresolv classrels) ((str o pr_dictvar) v)
  30.595 -      in case ds
  30.596 -       of [] => str "()"
  30.597 -        | [d] => pr_dictc fxy d
  30.598 -        | _ :: _ => (Pretty.list "(" ")" o map (pr_dictc NOBR)) ds
  30.599 -      end;
  30.600 -    fun pr_tyvars vs =
  30.601 -      vs
  30.602 -      |> map (fn (v, sort) => map_index (fn (i, _) => DictVar ([], (v, (i, length sort)))) sort)
  30.603 -      |> map (pr_dicts BR);
  30.604 -    fun pr_tycoexpr fxy (tyco, tys) =
  30.605 -      let
  30.606 -        val tyco' = (str o deresolv) tyco
  30.607 -      in case map (pr_typ BR) tys
  30.608 -       of [] => tyco'
  30.609 -        | [p] => Pretty.block [p, Pretty.brk 1, tyco']
  30.610 -        | (ps as _::_) => Pretty.block [Pretty.list "(" ")" ps, Pretty.brk 1, tyco']
  30.611 -      end
  30.612 -    and pr_typ fxy (tyco `%% tys) =
  30.613 -          (case tyco_syntax tyco
  30.614 -           of NONE => pr_tycoexpr fxy (tyco, tys)
  30.615 -            | SOME (i, pr) =>
  30.616 -                if not (i = length tys)
  30.617 -                then error ("Number of argument mismatch in customary serialization: "
  30.618 -                  ^ (string_of_int o length) tys ^ " given, "
  30.619 -                  ^ string_of_int i ^ " expected")
  30.620 -                else pr pr_typ fxy tys)
  30.621 -      | pr_typ fxy (ITyVar v) =
  30.622 -          str ("'" ^ v);
  30.623 -    fun pr_term lhs vars fxy (IConst c) =
  30.624 -          pr_app lhs vars fxy (c, [])
  30.625 -      | pr_term lhs vars fxy (IVar v) =
  30.626 -          str (CodegenNames.lookup_var vars v)
  30.627 -      | pr_term lhs vars fxy (t as t1 `$ t2) =
  30.628 -          (case CodegenThingol.unfold_const_app t
  30.629 -           of SOME c_ts => pr_app lhs vars fxy c_ts
  30.630 -            | NONE =>
  30.631 -                brackify fxy [pr_term lhs vars NOBR t1, pr_term lhs vars BR t2])
  30.632 -      | pr_term lhs vars fxy (t as _ `|-> _) =
  30.633 -          let
  30.634 -            val (binds, t') = CodegenThingol.unfold_abs t;
  30.635 -            fun pr ((v, pat), ty) = pr_bind BR ((SOME v, pat), ty);
  30.636 -            val (ps, vars') = fold_map pr binds vars;
  30.637 -          in brackets (str "fun" :: ps @ str "->" @@ pr_term lhs vars' NOBR t') end
  30.638 -      | pr_term lhs vars fxy (ICase (cases as (_, t0))) = (case CodegenThingol.unfold_const_app t0
  30.639 -           of SOME (c_ts as ((c, _), _)) => if is_none (const_syntax c)
  30.640 -                then pr_case vars fxy cases
  30.641 -                else pr_app lhs vars fxy c_ts
  30.642 -            | NONE => pr_case vars fxy cases)
  30.643 -    and pr_app' lhs vars (app as ((c, (iss, tys)), ts)) =
  30.644 -      if is_cons c then
  30.645 -        if length tys = length ts
  30.646 -        then case ts
  30.647 -         of [] => [(str o deresolv) c]
  30.648 -          | [t] => [(str o deresolv) c, pr_term lhs vars BR t]
  30.649 -          | _ => [(str o deresolv) c, Pretty.enum "," "(" ")" (map (pr_term lhs vars NOBR) ts)]
  30.650 -        else [pr_term lhs vars BR (CodegenThingol.eta_expand app (length tys))]
  30.651 -      else (str o deresolv) c
  30.652 -        :: ((map (pr_dicts BR) o filter_out null) iss @ map (pr_term lhs vars BR) ts)
  30.653 -    and pr_app lhs vars = gen_pr_app pr_app' pr_term const_syntax labelled_name is_cons lhs vars
  30.654 -    and pr_bind' ((NONE, NONE), _) = str "_"
  30.655 -      | pr_bind' ((SOME v, NONE), _) = str v
  30.656 -      | pr_bind' ((NONE, SOME p), _) = p
  30.657 -      | pr_bind' ((SOME v, SOME p), _) = brackets [p, str "as", str v]
  30.658 -    and pr_bind fxy = gen_pr_bind pr_bind' (pr_term false) fxy
  30.659 -    and pr_case vars fxy (cases as ((_, [_]), _)) =
  30.660 -          let
  30.661 -            val (binds, t') = CodegenThingol.unfold_let (ICase cases);
  30.662 -            fun pr ((pat, ty), t) vars =
  30.663 -              vars
  30.664 -              |> pr_bind NOBR ((NONE, SOME pat), ty)
  30.665 -              |>> (fn p => concat [str "let", p, str "=", pr_term false vars NOBR t, str "in"])
  30.666 -            val (ps, vars') = fold_map pr binds vars;
  30.667 -          in Pretty.chunks (ps @| pr_term false vars' NOBR t') end
  30.668 -      | pr_case vars fxy (((td, ty), b::bs), _) =
  30.669 -          let
  30.670 -            fun pr delim (pat, t) =
  30.671 -              let
  30.672 -                val (p, vars') = pr_bind NOBR ((NONE, SOME pat), ty) vars;
  30.673 -              in concat [str delim, p, str "->", pr_term false vars' NOBR t] end;
  30.674 -          in
  30.675 -            (Pretty.enclose "(" ")" o single o brackify fxy) (
  30.676 -              str "match"
  30.677 -              :: pr_term false vars NOBR td
  30.678 -              :: pr "with" b
  30.679 -              :: map (pr "|") bs
  30.680 -            )
  30.681 -          end
  30.682 -      | pr_case vars fxy ((_, []), _) = str "failwith \"empty case\"";
  30.683 -    fun pr_def (MLFuns (funns as funn :: funns')) =
  30.684 -          let
  30.685 -            fun fish_parm _ (w as SOME _) = w
  30.686 -              | fish_parm (IVar v) NONE = SOME v
  30.687 -              | fish_parm _ NONE = NONE;
  30.688 -            fun fillup_parm _ (_, SOME v) = v
  30.689 -              | fillup_parm x (i, NONE) = x ^ string_of_int i;
  30.690 -            fun fish_parms vars eqs =
  30.691 -              let
  30.692 -                val raw_fished = fold (map2 fish_parm) eqs (replicate (length (hd eqs)) NONE);
  30.693 -                val x = Name.variant (map_filter I raw_fished) "x";
  30.694 -                val fished = map_index (fillup_parm x) raw_fished;
  30.695 -                val vars' = CodegenNames.intro_vars fished vars;
  30.696 -              in map (CodegenNames.lookup_var vars') fished end;
  30.697 -            fun pr_eq (ts, t) =
  30.698 -              let
  30.699 -                val consts = map_filter
  30.700 -                  (fn c => if (is_some o const_syntax) c
  30.701 -                    then NONE else (SOME o NameSpace.base o deresolv) c)
  30.702 -                    ((fold o CodegenThingol.fold_constnames) (insert (op =)) (t :: ts) []);
  30.703 -                val vars = init_syms
  30.704 -                  |> CodegenNames.intro_vars consts
  30.705 -                  |> CodegenNames.intro_vars ((fold o CodegenThingol.fold_unbound_varnames)
  30.706 -                      (insert (op =)) ts []);
  30.707 -              in concat [
  30.708 -                (Pretty.block o Pretty.commas) (map (pr_term true vars NOBR) ts),
  30.709 -                str "->",
  30.710 -                pr_term false vars NOBR t
  30.711 -              ] end;
  30.712 -            fun pr_eqs [(ts, t)] =
  30.713 -                  let
  30.714 -                    val consts = map_filter
  30.715 -                      (fn c => if (is_some o const_syntax) c
  30.716 -                        then NONE else (SOME o NameSpace.base o deresolv) c)
  30.717 -                        ((fold o CodegenThingol.fold_constnames) (insert (op =)) (t :: ts) []);
  30.718 -                    val vars = init_syms
  30.719 -                      |> CodegenNames.intro_vars consts
  30.720 -                      |> CodegenNames.intro_vars ((fold o CodegenThingol.fold_unbound_varnames)
  30.721 -                          (insert (op =)) ts []);
  30.722 -                  in
  30.723 -                    concat (
  30.724 -                      map (pr_term true vars BR) ts
  30.725 -                      @ str "="
  30.726 -                      @@ pr_term false vars NOBR t
  30.727 -                    )
  30.728 -                  end
  30.729 -              | pr_eqs (eqs as (eq as ([_], _)) :: eqs') =
  30.730 -                  Pretty.block (
  30.731 -                    str "="
  30.732 -                    :: Pretty.brk 1
  30.733 -                    :: str "function"
  30.734 -                    :: Pretty.brk 1
  30.735 -                    :: pr_eq eq
  30.736 -                    :: maps (append [Pretty.fbrk, str "|", Pretty.brk 1] o single o pr_eq) eqs'
  30.737 -                  )
  30.738 -              | pr_eqs (eqs as eq :: eqs') =
  30.739 -                  let
  30.740 -                    val consts = map_filter
  30.741 -                      (fn c => if (is_some o const_syntax) c
  30.742 -                        then NONE else (SOME o NameSpace.base o deresolv) c)
  30.743 -                        ((fold o CodegenThingol.fold_constnames) (insert (op =)) (map snd eqs) []);
  30.744 -                    val vars = init_syms
  30.745 -                      |> CodegenNames.intro_vars consts;
  30.746 -                    val dummy_parms = (map str o fish_parms vars o map fst) eqs;
  30.747 -                  in
  30.748 -                    Pretty.block (
  30.749 -                      Pretty.breaks dummy_parms
  30.750 -                      @ Pretty.brk 1
  30.751 -                      :: str "="
  30.752 -                      :: Pretty.brk 1
  30.753 -                      :: str "match"
  30.754 -                      :: Pretty.brk 1
  30.755 -                      :: (Pretty.block o Pretty.commas) dummy_parms
  30.756 -                      :: Pretty.brk 1
  30.757 -                      :: str "with"
  30.758 -                      :: Pretty.brk 1
  30.759 -                      :: pr_eq eq
  30.760 -                      :: maps (append [Pretty.fbrk, str "|", Pretty.brk 1] o single o pr_eq) eqs'
  30.761 -                    )
  30.762 -                  end;
  30.763 -            fun pr_funn definer (name, (eqs, (vs, ty))) =
  30.764 -              concat (
  30.765 -                str definer
  30.766 -                :: (str o deresolv) name
  30.767 -                :: pr_tyvars (filter_out (null o snd) vs)
  30.768 -                @| pr_eqs eqs
  30.769 -              );
  30.770 -            val (ps, p) = split_last (pr_funn "let rec" funn :: map (pr_funn "and") funns');
  30.771 -          in Pretty.chunks (ps @ [Pretty.block ([p, str ";;"])]) end
  30.772 -     | pr_def (MLDatas (datas as (data :: datas'))) =
  30.773 -          let
  30.774 -            fun pr_co (co, []) =
  30.775 -                  str (deresolv co)
  30.776 -              | pr_co (co, tys) =
  30.777 -                  concat [
  30.778 -                    str (deresolv co),
  30.779 -                    str "of",
  30.780 -                    Pretty.enum " *" "" "" (map (pr_typ (INFX (2, X))) tys)
  30.781 -                  ];
  30.782 -            fun pr_data definer (tyco, (vs, [])) =
  30.783 -                  concat (
  30.784 -                    str definer
  30.785 -                    :: pr_tycoexpr NOBR (tyco, map (ITyVar o fst) vs)
  30.786 -                    :: str "="
  30.787 -                    @@ str "EMPTY_"
  30.788 -                  )
  30.789 -              | pr_data definer (tyco, (vs, cos)) =
  30.790 -                  concat (
  30.791 -                    str definer
  30.792 -                    :: pr_tycoexpr NOBR (tyco, map (ITyVar o fst) vs)
  30.793 -                    :: str "="
  30.794 -                    :: separate (str "|") (map pr_co cos)
  30.795 -                  );
  30.796 -            val (ps, p) = split_last (pr_data "type" data :: map (pr_data "and") datas');
  30.797 -          in Pretty.chunks (ps @ [Pretty.block ([p, str ";;"])]) end
  30.798 -     | pr_def (MLClass (class, (superclasses, (v, classops)))) =
  30.799 -          let
  30.800 -            val w = "_" ^ first_upper v;
  30.801 -            fun pr_superclass_field (class, classrel) =
  30.802 -              (concat o map str) [
  30.803 -                deresolv classrel, ":", "'" ^ v, deresolv class
  30.804 -              ];
  30.805 -            fun pr_classop_field (classop, ty) =
  30.806 -              concat [
  30.807 -                (str o deresolv) classop, str ":", pr_typ NOBR ty
  30.808 -              ];
  30.809 -            fun pr_classop_proj (classop, _) =
  30.810 -              concat [
  30.811 -                str "let",
  30.812 -                (str o deresolv) classop,
  30.813 -                str w,
  30.814 -                str "=",
  30.815 -                str (w ^ "." ^ deresolv classop ^ ";;")
  30.816 -              ];
  30.817 -          in Pretty.chunks (
  30.818 -            concat [
  30.819 -              str ("type '" ^ v),
  30.820 -              (str o deresolv) class,
  30.821 -              str "=",
  30.822 -              Pretty.enum ";" "{" "};;" (
  30.823 -                map pr_superclass_field superclasses @ map pr_classop_field classops
  30.824 -              )
  30.825 -            ]
  30.826 -            :: map pr_classop_proj classops
  30.827 -          ) end
  30.828 -     | pr_def (MLClassinst (inst, ((class, (tyco, arity)), (superarities, classop_defs)))) =
  30.829 -          let
  30.830 -            fun pr_superclass (_, (classrel, dss)) =
  30.831 -              concat [
  30.832 -                (str o deresolv) classrel,
  30.833 -                str "=",
  30.834 -                pr_dicts NOBR [DictConst dss]
  30.835 -              ];
  30.836 -            fun pr_classop_def (classop, t) =
  30.837 -              let
  30.838 -                val consts = map_filter
  30.839 -                  (fn c => if (is_some o const_syntax) c
  30.840 -                    then NONE else (SOME o NameSpace.base o deresolv) c)
  30.841 -                    (CodegenThingol.fold_constnames (insert (op =)) t []);
  30.842 -                val vars = CodegenNames.intro_vars consts init_syms;
  30.843 -              in
  30.844 -                concat [
  30.845 -                  (str o deresolv) classop,
  30.846 -                  str "=",
  30.847 -                  pr_term false vars NOBR t
  30.848 -                ]
  30.849 -              end;
  30.850 -          in
  30.851 -            concat (
  30.852 -              str "let"
  30.853 -              :: (str o deresolv) inst
  30.854 -              :: pr_tyvars arity
  30.855 -              @ str "="
  30.856 -              @@ (Pretty.enclose "(" ");;" o Pretty.breaks) [
  30.857 -                Pretty.enum ";" "{" "}" (map pr_superclass superarities @ map pr_classop_def classop_defs),
  30.858 -                str ":",
  30.859 -                pr_tycoexpr NOBR (class, [tyco `%% map (ITyVar o fst) arity])
  30.860 -              ]
  30.861 -            )
  30.862 -          end;
  30.863 -  in pr_def ml_def end;
  30.864 -
  30.865 -fun pr_ocaml_modl name content =
  30.866 -  Pretty.chunks ([
  30.867 -    str ("module " ^ name ^ " = "),
  30.868 -    str "struct",
  30.869 -    str ""
  30.870 -  ] @ content @ [
  30.871 -    str "",
  30.872 -    str ("end;; (*struct " ^ name ^ "*)")
  30.873 -  ]);
  30.874 -
  30.875 -val code_width = ref 80;
  30.876 -fun code_output p = Pretty.setmp_margin (!code_width) Pretty.output p ^ "\n";
  30.877 -
  30.878 -fun seri_ml pr_def pr_modl module output labelled_name reserved_syms raw_module_alias module_prolog
  30.879 -  (_ : string -> class_syntax option) tyco_syntax const_syntax code =
  30.880 -  let
  30.881 -    val module_alias = if is_some module then K module else raw_module_alias;
  30.882 -    val is_cons = CodegenThingol.is_cons code;
  30.883 -    datatype node =
  30.884 -        Def of string * ml_def option
  30.885 -      | Module of string * ((Name.context * Name.context) * node Graph.T);
  30.886 -    val init_names = Name.make_context reserved_syms;
  30.887 -    val init_module = ((init_names, init_names), Graph.empty);
  30.888 -    fun map_node [] f = f
  30.889 -      | map_node (m::ms) f =
  30.890 -          Graph.default_node (m, Module (m, init_module))
  30.891 -          #> Graph.map_node m (fn (Module (dmodlname, (nsp, nodes))) => Module (dmodlname, (nsp, map_node ms f nodes)));
  30.892 -    fun map_nsp_yield [] f (nsp, nodes) =
  30.893 -          let
  30.894 -            val (x, nsp') = f nsp
  30.895 -          in (x, (nsp', nodes)) end
  30.896 -      | map_nsp_yield (m::ms) f (nsp, nodes) =
  30.897 -          let
  30.898 -            val (x, nodes') =
  30.899 -              nodes
  30.900 -              |> Graph.default_node (m, Module (m, init_module))
  30.901 -              |> Graph.map_node_yield m (fn Module (dmodlname, nsp_nodes) => 
  30.902 -                  let
  30.903 -                    val (x, nsp_nodes') = map_nsp_yield ms f nsp_nodes
  30.904 -                  in (x, Module (dmodlname, nsp_nodes')) end)
  30.905 -          in (x, (nsp, nodes')) end;
  30.906 -    val init_syms = CodegenNames.make_vars reserved_syms;
  30.907 -    val name_modl = mk_modl_name_tab init_names NONE module_alias code;
  30.908 -    fun name_def upper name nsp =
  30.909 -      let
  30.910 -        val (_, base) = dest_name name;
  30.911 -        val base' = if upper then first_upper base else base;
  30.912 -        val ([base''], nsp') = Name.variants [base'] nsp;
  30.913 -      in (base'', nsp') end;
  30.914 -    fun map_nsp_fun f (nsp_fun, nsp_typ) =
  30.915 -      let
  30.916 -        val (x, nsp_fun') = f nsp_fun
  30.917 -      in (x, (nsp_fun', nsp_typ)) end;
  30.918 -    fun map_nsp_typ f (nsp_fun, nsp_typ) =
  30.919 -      let
  30.920 -        val (x, nsp_typ') = f nsp_typ
  30.921 -      in (x, (nsp_fun, nsp_typ')) end;
  30.922 -    fun mk_funs defs =
  30.923 -      fold_map
  30.924 -        (fn (name, CodegenThingol.Fun info) =>
  30.925 -              map_nsp_fun (name_def false name) >> (fn base => (base, (name, info)))
  30.926 -          | (name, def) => error ("Function block containing illegal definition: " ^ labelled_name name)
  30.927 -        ) defs
  30.928 -      >> (split_list #> apsnd MLFuns);
  30.929 -    fun mk_datatype defs =
  30.930 -      fold_map
  30.931 -        (fn (name, CodegenThingol.Datatype info) =>
  30.932 -              map_nsp_typ (name_def false name) >> (fn base => (base, SOME (name, info)))
  30.933 -          | (name, CodegenThingol.Datatypecons _) =>
  30.934 -              map_nsp_fun (name_def true name) >> (fn base => (base, NONE))
  30.935 -          | (name, def) => error ("Datatype block containing illegal definition: " ^ labelled_name name)
  30.936 -        ) defs
  30.937 -      >> (split_list #> apsnd (map_filter I
  30.938 -        #> (fn [] => error ("Datatype block without data definition: " ^ (commas o map (labelled_name o fst)) defs)
  30.939 -             | infos => MLDatas infos)));
  30.940 -    fun mk_class defs =
  30.941 -      fold_map
  30.942 -        (fn (name, CodegenThingol.Class info) =>
  30.943 -              map_nsp_typ (name_def false name) >> (fn base => (base, SOME (name, info)))
  30.944 -          | (name, CodegenThingol.Classrel _) =>
  30.945 -              map_nsp_fun (name_def false name) >> (fn base => (base, NONE))
  30.946 -          | (name, CodegenThingol.Classop _) =>
  30.947 -              map_nsp_fun (name_def false name) >> (fn base => (base, NONE))
  30.948 -          | (name, def) => error ("Class block containing illegal definition: " ^ labelled_name name)
  30.949 -        ) defs
  30.950 -      >> (split_list #> apsnd (map_filter I
  30.951 -        #> (fn [] => error ("Class block without class definition: " ^ (commas o map (labelled_name o fst)) defs)
  30.952 -             | [info] => MLClass info)));
  30.953 -    fun mk_inst [(name, CodegenThingol.Classinst info)] =
  30.954 -      map_nsp_fun (name_def false name)
  30.955 -      >> (fn base => ([base], MLClassinst (name, info)));
  30.956 -    fun add_group mk defs nsp_nodes =
  30.957 -      let
  30.958 -        val names as (name :: names') = map fst defs;
  30.959 -        val deps =
  30.960 -          []
  30.961 -          |> fold (fold (insert (op =)) o Graph.imm_succs code) names
  30.962 -          |> subtract (op =) names;
  30.963 -        val (modls, _) = (split_list o map dest_name) names;
  30.964 -        val modl' = (the_single o distinct (op =) o map name_modl) modls
  30.965 -          handle Empty =>
  30.966 -            error ("Illegal mutual dependencies: " ^ commas (map labelled_name names));
  30.967 -        val modl_explode = NameSpace.explode modl';
  30.968 -        fun add_dep name name'' =
  30.969 -          let
  30.970 -            val modl'' = (name_modl o fst o dest_name) name'';
  30.971 -          in if modl' = modl'' then
  30.972 -            map_node modl_explode
  30.973 -              (Graph.add_edge (name, name''))
  30.974 -          else let
  30.975 -            val (common, (diff1::_, diff2::_)) = chop_prefix (op =)
  30.976 -              (modl_explode, NameSpace.explode modl'');
  30.977 -          in
  30.978 -            map_node common
  30.979 -              (fn gr => Graph.add_edge_acyclic (diff1, diff2) gr
  30.980 -                handle Graph.CYCLES _ => error ("Dependency "
  30.981 -                  ^ quote name ^ " -> " ^ quote name''
  30.982 -                  ^ " would result in module dependency cycle"))
  30.983 -          end end;
  30.984 -      in
  30.985 -        nsp_nodes
  30.986 -        |> map_nsp_yield modl_explode (mk defs)
  30.987 -        |-> (fn (base' :: bases', def') =>
  30.988 -           apsnd (map_node modl_explode (Graph.new_node (name, (Def (base', SOME def')))
  30.989 -              #> fold2 (fn name' => fn base' => Graph.new_node (name', (Def (base', NONE)))) names' bases')))
  30.990 -        |> apsnd (fold (fn name => fold (add_dep name) deps) names)
  30.991 -        |> apsnd (fold (map_node modl_explode o Graph.add_edge) (product names names))
  30.992 -      end;
  30.993 -    fun group_defs [(_, CodegenThingol.Bot)] =
  30.994 -          I
  30.995 -      | group_defs ((defs as (_, CodegenThingol.Fun _)::_)) =
  30.996 -          add_group mk_funs defs
  30.997 -      | group_defs ((defs as (_, CodegenThingol.Datatypecons _)::_)) =
  30.998 -          add_group mk_datatype defs
  30.999 -      | group_defs ((defs as (_, CodegenThingol.Datatype _)::_)) =
 30.1000 -          add_group mk_datatype defs
 30.1001 -      | group_defs ((defs as (_, CodegenThingol.Class _)::_)) =
 30.1002 -          add_group mk_class defs
 30.1003 -      | group_defs ((defs as (_, CodegenThingol.Classrel _)::_)) =
 30.1004 -          add_group mk_class defs
 30.1005 -      | group_defs ((defs as (_, CodegenThingol.Classop _)::_)) =
 30.1006 -          add_group mk_class defs
 30.1007 -      | group_defs ((defs as [(_, CodegenThingol.Classinst _)])) =
 30.1008 -          add_group mk_inst defs
 30.1009 -      | group_defs defs = error ("Illegal mutual dependencies: " ^
 30.1010 -          (commas o map (labelled_name o fst)) defs)
 30.1011 -    val (_, nodes) =
 30.1012 -      init_module
 30.1013 -      |> fold group_defs (map (AList.make (Graph.get_node code))
 30.1014 -          (rev (Graph.strong_conn code)))
 30.1015 -    fun deresolver prefix name = 
 30.1016 -      let
 30.1017 -        val modl = (fst o dest_name) name;
 30.1018 -        val modl' = (NameSpace.explode o name_modl) modl;
 30.1019 -        val (_, (_, remainder)) = chop_prefix (op =) (prefix, modl');
 30.1020 -        val defname' =
 30.1021 -          nodes
 30.1022 -          |> fold (fn m => fn g => case Graph.get_node g m
 30.1023 -              of Module (_, (_, g)) => g) modl'
 30.1024 -          |> (fn g => case Graph.get_node g name of Def (defname, _) => defname);
 30.1025 -      in
 30.1026 -        NameSpace.implode (remainder @ [defname'])
 30.1027 -      end handle Graph.UNDEF _ =>
 30.1028 -        error ("Unknown definition name: " ^ labelled_name name);
 30.1029 -    fun the_prolog modlname = case module_prolog modlname
 30.1030 -     of NONE => []
 30.1031 -      | SOME p => [p, str ""];
 30.1032 -    fun pr_node prefix (Def (_, NONE)) =
 30.1033 -          NONE
 30.1034 -      | pr_node prefix (Def (_, SOME def)) =
 30.1035 -          SOME (pr_def tyco_syntax const_syntax labelled_name init_syms
 30.1036 -            (deresolver prefix) is_cons def)
 30.1037 -      | pr_node prefix (Module (dmodlname, (_, nodes))) =
 30.1038 -          SOME (pr_modl dmodlname (the_prolog (NameSpace.implode (prefix @ [dmodlname]))
 30.1039 -            @ separate (str "") ((map_filter (pr_node (prefix @ [dmodlname]) o Graph.get_node nodes)
 30.1040 -                o rev o flat o Graph.strong_conn) nodes)));
 30.1041 -    val p = Pretty.chunks (the_prolog "" @ separate (str "") ((map_filter
 30.1042 -      (pr_node [] o Graph.get_node nodes) o rev o flat o Graph.strong_conn) nodes))
 30.1043 -  in output p end;
 30.1044 -
 30.1045 -val eval_verbose = ref false;
 30.1046 -
 30.1047 -fun isar_seri_sml module file =
 30.1048 -  let
 30.1049 -    val output = case file
 30.1050 -     of NONE => use_text "generated code" Output.ml_output (!eval_verbose) o code_output
 30.1051 -      | SOME "-" => writeln o code_output
 30.1052 -      | SOME file => File.write (Path.explode file) o code_output;
 30.1053 -  in
 30.1054 -    parse_args (Scan.succeed ())
 30.1055 -    #> (fn () => seri_ml pr_sml pr_sml_modl module output)
 30.1056 -  end;
 30.1057 -
 30.1058 -fun isar_seri_ocaml module file =
 30.1059 -  let
 30.1060 -    val output = case file
 30.1061 -     of NONE => error "OCaml: no internal compilation"
 30.1062 -      | SOME "-" => writeln o code_output
 30.1063 -      | SOME file => File.write (Path.explode file) o code_output;
 30.1064 -    fun output_file file = File.write (Path.explode file) o code_output;
 30.1065 -    val output_diag = writeln o code_output;
 30.1066 -  in
 30.1067 -    parse_args (Scan.succeed ())
 30.1068 -    #> (fn () => seri_ml pr_ocaml pr_ocaml_modl module output)
 30.1069 -  end;
 30.1070 -
 30.1071 -
 30.1072 -(** Haskell serializer **)
 30.1073 -
 30.1074 -local
 30.1075 -
 30.1076 -fun pr_bind' ((NONE, NONE), _) = str "_"
 30.1077 -  | pr_bind' ((SOME v, NONE), _) = str v
 30.1078 -  | pr_bind' ((NONE, SOME p), _) = p
 30.1079 -  | pr_bind' ((SOME v, SOME p), _) = brackets [str v, str "@", p]
 30.1080 -
 30.1081 -val pr_bind_haskell = gen_pr_bind pr_bind';
 30.1082 -
 30.1083 -in
 30.1084 -
 30.1085 -fun pr_haskell class_syntax tyco_syntax const_syntax labelled_name init_syms
 30.1086 -    deresolv_here deresolv is_cons deriving_show def =
 30.1087 -  let
 30.1088 -    fun class_name class = case class_syntax class
 30.1089 -     of NONE => deresolv class
 30.1090 -      | SOME (class, _) => class;
 30.1091 -    fun classop_name class classop = case class_syntax class
 30.1092 -     of NONE => deresolv_here classop
 30.1093 -      | SOME (_, classop_syntax) => case classop_syntax classop
 30.1094 -         of NONE => (snd o dest_name) classop
 30.1095 -          | SOME classop => classop
 30.1096 -    fun pr_typparms tyvars vs =
 30.1097 -      case maps (fn (v, sort) => map (pair v) sort) vs
 30.1098 -       of [] => str ""
 30.1099 -        | xs => Pretty.block [
 30.1100 -            Pretty.enum "," "(" ")" (
 30.1101 -              map (fn (v, class) => str
 30.1102 -                (class_name class ^ " " ^ CodegenNames.lookup_var tyvars v)) xs
 30.1103 -            ),
 30.1104 -            str " => "
 30.1105 -          ];
 30.1106 -    fun pr_tycoexpr tyvars fxy (tyco, tys) =
 30.1107 -      brackify fxy (str tyco :: map (pr_typ tyvars BR) tys)
 30.1108 -    and pr_typ tyvars fxy (tycoexpr as tyco `%% tys) =
 30.1109 -          (case tyco_syntax tyco
 30.1110 -           of NONE =>
 30.1111 -                pr_tycoexpr tyvars fxy (deresolv tyco, tys)
 30.1112 -            | SOME (i, pr) =>
 30.1113 -                if not (i = length tys)
 30.1114 -                then error ("Number of argument mismatch in customary serialization: "
 30.1115 -                  ^ (string_of_int o length) tys ^ " given, "
 30.1116 -                  ^ string_of_int i ^ " expected")
 30.1117 -                else pr (pr_typ tyvars) fxy tys)
 30.1118 -      | pr_typ tyvars fxy (ITyVar v) =
 30.1119 -          (str o CodegenNames.lookup_var tyvars) v;
 30.1120 -    fun pr_typscheme_expr tyvars (vs, tycoexpr) =
 30.1121 -      Pretty.block (pr_typparms tyvars vs @@ pr_tycoexpr tyvars NOBR tycoexpr);
 30.1122 -    fun pr_typscheme tyvars (vs, ty) =
 30.1123 -      Pretty.block (pr_typparms tyvars vs @@ pr_typ tyvars NOBR ty);
 30.1124 -    fun pr_term lhs vars fxy (IConst c) =
 30.1125 -          pr_app lhs vars fxy (c, [])
 30.1126 -      | pr_term lhs vars fxy (t as (t1 `$ t2)) =
 30.1127 -          (case CodegenThingol.unfold_const_app t
 30.1128 -           of SOME app => pr_app lhs vars fxy app
 30.1129 -            | _ =>
 30.1130 -                brackify fxy [
 30.1131 -                  pr_term lhs vars NOBR t1,
 30.1132 -                  pr_term lhs vars BR t2
 30.1133 -                ])
 30.1134 -      | pr_term lhs vars fxy (IVar v) =
 30.1135 -          (str o CodegenNames.lookup_var vars) v
 30.1136 -      | pr_term lhs vars fxy (t as _ `|-> _) =
 30.1137 -          let
 30.1138 -            val (binds, t') = CodegenThingol.unfold_abs t;
 30.1139 -            fun pr ((v, pat), ty) = pr_bind BR ((SOME v, pat), ty);
 30.1140 -            val (ps, vars') = fold_map pr binds vars;
 30.1141 -          in brackets (str "\\" :: ps @ str "->" @@ pr_term lhs vars' NOBR t') end
 30.1142 -      | pr_term lhs vars fxy (ICase (cases as (_, t0))) = (case CodegenThingol.unfold_const_app t0
 30.1143 -           of SOME (c_ts as ((c, _), _)) => if is_none (const_syntax c)
 30.1144 -                then pr_case vars fxy cases
 30.1145 -                else pr_app lhs vars fxy c_ts
 30.1146 -            | NONE => pr_case vars fxy cases)
 30.1147 -    and pr_app' lhs vars ((c, _), ts) =
 30.1148 -      (str o deresolv) c :: map (pr_term lhs vars BR) ts
 30.1149 -    and pr_app lhs vars = gen_pr_app pr_app' pr_term const_syntax labelled_name is_cons lhs vars
 30.1150 -    and pr_bind fxy = pr_bind_haskell (pr_term false) fxy
 30.1151 -    and pr_case vars fxy (cases as ((_, [_]), _)) =
 30.1152 -          let
 30.1153 -            val (binds, t) = CodegenThingol.unfold_let (ICase cases);
 30.1154 -            fun pr ((pat, ty), t) vars =
 30.1155 -              vars
 30.1156 -              |> pr_bind BR ((NONE, SOME pat), ty)
 30.1157 -              |>> (fn p => semicolon [p, str "=", pr_term false vars NOBR t])
 30.1158 -            val (ps, vars') = fold_map pr binds vars;
 30.1159 -          in
 30.1160 -            Pretty.block_enclose (
 30.1161 -              str "let {",
 30.1162 -              concat [str "}", str "in", pr_term false vars' NOBR t]
 30.1163 -            ) ps
 30.1164 -          end
 30.1165 -      | pr_case vars fxy (((td, ty), bs as _ :: _), _) =
 30.1166 -          let
 30.1167 -            fun pr (pat, t) =
 30.1168 -              let
 30.1169 -                val (p, vars') = pr_bind NOBR ((NONE, SOME pat), ty) vars;
 30.1170 -              in semicolon [p, str "->", pr_term false vars' NOBR t] end;
 30.1171 -          in
 30.1172 -            Pretty.block_enclose (
 30.1173 -              concat [str "(case", pr_term false vars NOBR td, str "of", str "{"],
 30.1174 -              str "})"
 30.1175 -            ) (map pr bs)
 30.1176 -          end
 30.1177 -      | pr_case vars fxy ((_, []), _) = str "error \"empty case\"";
 30.1178 -    fun pr_def (name, CodegenThingol.Fun (eqs, (vs, ty))) =
 30.1179 -          let
 30.1180 -            val tyvars = CodegenNames.intro_vars (map fst vs) init_syms;
 30.1181 -            fun pr_eq (ts, t) =
 30.1182 -              let
 30.1183 -                val consts = map_filter
 30.1184 -                  (fn c => if (is_some o const_syntax) c
 30.1185 -                    then NONE else (SOME o NameSpace.base o deresolv) c)
 30.1186 -                    ((fold o CodegenThingol.fold_constnames) (insert (op =)) (t :: ts) []);
 30.1187 -                val vars = init_syms
 30.1188 -                  |> CodegenNames.intro_vars consts
 30.1189 -                  |> CodegenNames.intro_vars ((fold o CodegenThingol.fold_unbound_varnames)
 30.1190 -                       (insert (op =)) ts []);
 30.1191 -              in
 30.1192 -                semicolon (
 30.1193 -                  (str o deresolv_here) name
 30.1194 -                  :: map (pr_term true vars BR) ts
 30.1195 -                  @ str "="
 30.1196 -                  @@ pr_term false vars NOBR t
 30.1197 -                )
 30.1198 -              end;
 30.1199 -          in
 30.1200 -            Pretty.chunks (
 30.1201 -              Pretty.block [
 30.1202 -                (str o suffix " ::" o deresolv_here) name,
 30.1203 -                Pretty.brk 1,
 30.1204 -                pr_typscheme tyvars (vs, ty),
 30.1205 -                str ";"
 30.1206 -              ]
 30.1207 -              :: map pr_eq eqs
 30.1208 -            )
 30.1209 -          end
 30.1210 -      | pr_def (name, CodegenThingol.Datatype (vs, [])) =
 30.1211 -          let
 30.1212 -            val tyvars = CodegenNames.intro_vars (map fst vs) init_syms;
 30.1213 -          in
 30.1214 -            semicolon [
 30.1215 -              str "data",
 30.1216 -              pr_typscheme_expr tyvars (vs, (deresolv_here name, map (ITyVar o fst) vs))
 30.1217 -            ]
 30.1218 -          end
 30.1219 -      | pr_def (name, CodegenThingol.Datatype (vs, [(co, [ty])])) =
 30.1220 -          let
 30.1221 -            val tyvars = CodegenNames.intro_vars (map fst vs) init_syms;
 30.1222 -          in
 30.1223 -            semicolon (
 30.1224 -              str "newtype"
 30.1225 -              :: pr_typscheme_expr tyvars (vs, (deresolv_here name, map (ITyVar o fst) vs))
 30.1226 -              :: str "="
 30.1227 -              :: (str o deresolv_here) co
 30.1228 -              :: pr_typ tyvars BR ty
 30.1229 -              :: (if deriving_show name then [str "deriving (Read, Show)"] else [])
 30.1230 -            )
 30.1231 -          end
 30.1232 -      | pr_def (name, CodegenThingol.Datatype (vs, co :: cos)) =
 30.1233 -          let
 30.1234 -            val tyvars = CodegenNames.intro_vars (map fst vs) init_syms;
 30.1235 -            fun pr_co (co, tys) =
 30.1236 -              concat (
 30.1237 -                (str o deresolv_here) co
 30.1238 -                :: map (pr_typ tyvars BR) tys
 30.1239 -              )
 30.1240 -          in
 30.1241 -            semicolon (
 30.1242 -              str "data"
 30.1243 -              :: pr_typscheme_expr tyvars (vs, (deresolv_here name, map (ITyVar o fst) vs))
 30.1244 -              :: str "="
 30.1245 -              :: pr_co co
 30.1246 -              :: map ((fn p => Pretty.block [str "| ", p]) o pr_co) cos
 30.1247 -              @ (if deriving_show name then [str "deriving (Read, Show)"] else [])
 30.1248 -            )
 30.1249 -          end
 30.1250 -      | pr_def (name, CodegenThingol.Class (superclasss, (v, classops))) =
 30.1251 -          let
 30.1252 -            val tyvars = CodegenNames.intro_vars [v] init_syms;
 30.1253 -            fun pr_classop (classop, ty) =
 30.1254 -              semicolon [
 30.1255 -                (str o classop_name name) classop,
 30.1256 -                str "::",
 30.1257 -                pr_typ tyvars NOBR ty
 30.1258 -              ]
 30.1259 -          in
 30.1260 -            Pretty.block_enclose (
 30.1261 -              Pretty.block [
 30.1262 -                str "class ",
 30.1263 -                pr_typparms tyvars [(v, map fst superclasss)],
 30.1264 -                str (deresolv_here name ^ " " ^ CodegenNames.lookup_var tyvars v),
 30.1265 -                str " where {"
 30.1266 -              ],
 30.1267 -              str "};"
 30.1268 -            ) (map pr_classop classops)
 30.1269 -          end
 30.1270 -      | pr_def (_, CodegenThingol.Classinst ((class, (tyco, vs)), (_, classop_defs))) =
 30.1271 -          let
 30.1272 -            val tyvars = CodegenNames.intro_vars (map fst vs) init_syms;
 30.1273 -            fun pr_instdef (classop, t) =
 30.1274 -                let
 30.1275 -                  val consts = map_filter
 30.1276 -                    (fn c => if (is_some o const_syntax) c
 30.1277 -                      then NONE else (SOME o NameSpace.base o deresolv) c)
 30.1278 -                      (CodegenThingol.fold_constnames (insert (op =)) t []);
 30.1279 -                  val vars = init_syms
 30.1280 -                    |> CodegenNames.intro_vars consts;
 30.1281 -                in
 30.1282 -                  semicolon [
 30.1283 -                    (str o classop_name class) classop,
 30.1284 -                    str "=",
 30.1285 -                    pr_term false vars NOBR t
 30.1286 -                  ]
 30.1287 -                end;
 30.1288 -          in
 30.1289 -            Pretty.block_enclose (
 30.1290 -              Pretty.block [
 30.1291 -                str "instance ",
 30.1292 -                pr_typparms tyvars vs,
 30.1293 -                str (class_name class ^ " "),
 30.1294 -                pr_typ tyvars BR (tyco `%% map (ITyVar o fst) vs),
 30.1295 -                str " where {"
 30.1296 -              ],
 30.1297 -              str "};"
 30.1298 -            ) (map pr_instdef classop_defs)
 30.1299 -          end;
 30.1300 -  in pr_def def end;
 30.1301 -
 30.1302 -fun pretty_haskell_monad c_mbind c_kbind =
 30.1303 -  let
 30.1304 -    fun pretty pr vars fxy [(t, _)] =
 30.1305 -      let
 30.1306 -        val pr_bind = pr_bind_haskell pr;
 30.1307 -        fun pr_mbind (NONE, t) vars =
 30.1308 -              (semicolon [pr vars NOBR t], vars)
 30.1309 -          | pr_mbind (SOME (bind, true), t) vars = vars
 30.1310 -              |> pr_bind NOBR bind
 30.1311 -              |>> (fn p => semicolon [p, str "<-", pr vars NOBR t])
 30.1312 -          | pr_mbind (SOME (bind, false), t) vars = vars
 30.1313 -              |> pr_bind NOBR bind
 30.1314 -              |>> (fn p => semicolon [str "let", p, str "=", pr vars NOBR t]);
 30.1315 -        val (binds, t) = implode_monad c_mbind c_kbind t;
 30.1316 -        val (ps, vars') = fold_map pr_mbind binds vars;
 30.1317 -        fun brack p = if eval_fxy BR fxy then Pretty.block [str "(", p, str ")"] else p;
 30.1318 -      in (brack o Pretty.block_enclose (str "do {", str "}")) (ps @| pr vars' NOBR t) end;
 30.1319 -  in (1, pretty) end;
 30.1320 -
 30.1321 -end; (*local*)
 30.1322 -
 30.1323 -fun seri_haskell module_prefix module destination string_classes labelled_name
 30.1324 -    reserved_syms raw_module_alias module_prolog class_syntax tyco_syntax const_syntax code =
 30.1325 -  let
 30.1326 -    val _ = Option.map File.check destination;
 30.1327 -    val is_cons = CodegenThingol.is_cons code;
 30.1328 -    val module_alias = if is_some module then K module else raw_module_alias;
 30.1329 -    val init_names = Name.make_context reserved_syms;
 30.1330 -    val name_modl = mk_modl_name_tab init_names module_prefix module_alias code;
 30.1331 -    fun add_def (name, (def, deps)) =
 30.1332 -      let
 30.1333 -        val (modl, base) = dest_name name;
 30.1334 -        fun name_def base = Name.variants [base] #>> the_single;
 30.1335 -        fun add_fun upper (nsp_fun, nsp_typ) =
 30.1336 -          let
 30.1337 -            val (base', nsp_fun') = name_def (if upper then first_upper base else base) nsp_fun
 30.1338 -          in (base', (nsp_fun', nsp_typ)) end;
 30.1339 -        fun add_typ (nsp_fun, nsp_typ) =
 30.1340 -          let
 30.1341 -            val (base', nsp_typ') = name_def (first_upper base) nsp_typ
 30.1342 -          in (base', (nsp_fun, nsp_typ')) end;
 30.1343 -        val add_name =
 30.1344 -          case def
 30.1345 -           of CodegenThingol.Bot => pair base
 30.1346 -            | CodegenThingol.Fun _ => add_fun false
 30.1347 -            | CodegenThingol.Datatype _ => add_typ
 30.1348 -            | CodegenThingol.Datatypecons _ => add_fun true
 30.1349 -            | CodegenThingol.Class _ => add_typ
 30.1350 -            | CodegenThingol.Classrel _ => pair base
 30.1351 -            | CodegenThingol.Classop _ => add_fun false
 30.1352 -            | CodegenThingol.Classinst _ => pair base;
 30.1353 -        val modlname' = name_modl modl;
 30.1354 -        fun add_def base' =
 30.1355 -          case def
 30.1356 -           of CodegenThingol.Bot => I
 30.1357 -            | CodegenThingol.Datatypecons _ =>
 30.1358 -                cons (name, ((NameSpace.append modlname' base', base'), NONE))
 30.1359 -            | CodegenThingol.Classrel _ => I
 30.1360 -            | CodegenThingol.Classop _ =>
 30.1361 -                cons (name, ((NameSpace.append modlname' base', base'), NONE))
 30.1362 -            | _ => cons (name, ((NameSpace.append modlname' base', base'), SOME def));
 30.1363 -      in
 30.1364 -        Symtab.map_default (modlname', ([], ([], (init_names, init_names))))
 30.1365 -              (apfst (fold (insert (op = : string * string -> bool)) deps))
 30.1366 -        #> `(fn code => add_name ((snd o snd o the o Symtab.lookup code) modlname'))
 30.1367 -        #-> (fn (base', names) =>
 30.1368 -              (Symtab.map_entry modlname' o apsnd) (fn (defs, _) =>
 30.1369 -              (add_def base' defs, names)))
 30.1370 -      end;
 30.1371 -    val code' =
 30.1372 -      fold add_def (AList.make (fn name => (Graph.get_node code name, Graph.imm_succs code name))
 30.1373 -        (Graph.strong_conn code |> flat)) Symtab.empty;
 30.1374 -    val init_syms = CodegenNames.make_vars reserved_syms;
 30.1375 -    fun deresolv name =
 30.1376 -      (fst o fst o the o AList.lookup (op =) ((fst o snd o the
 30.1377 -        o Symtab.lookup code') ((name_modl o fst o dest_name) name))) name
 30.1378 -        handle Option => error ("Unknown definition name: " ^ labelled_name name);
 30.1379 -    fun deresolv_here name =
 30.1380 -      (snd o fst o the o AList.lookup (op =) ((fst o snd o the
 30.1381 -        o Symtab.lookup code') ((name_modl o fst o dest_name) name))) name
 30.1382 -        handle Option => error ("Unknown definition name: " ^ labelled_name name);
 30.1383 -    fun deriving_show tyco =
 30.1384 -      let
 30.1385 -        fun deriv _ "fun" = false
 30.1386 -          | deriv tycos tyco = member (op =) tycos tyco orelse
 30.1387 -              case the_default CodegenThingol.Bot (try (Graph.get_node code) tyco)
 30.1388 -               of CodegenThingol.Bot => true
 30.1389 -                | CodegenThingol.Datatype (_, cs) => forall (deriv' (tyco :: tycos))
 30.1390 -                    (maps snd cs)
 30.1391 -        and deriv' tycos (tyco `%% tys) = deriv tycos tyco
 30.1392 -              andalso forall (deriv' tycos) tys
 30.1393 -          | deriv' _ (ITyVar _) = true
 30.1394 -      in deriv [] tyco end;
 30.1395 -    fun seri_def qualified = pr_haskell class_syntax tyco_syntax const_syntax labelled_name init_syms
 30.1396 -      deresolv_here (if qualified then deresolv else deresolv_here) is_cons
 30.1397 -      (if string_classes then deriving_show else K false);
 30.1398 -    fun write_module (SOME destination) modlname =
 30.1399 -          let
 30.1400 -            val filename = case modlname
 30.1401 -             of "" => Path.explode "Main.hs"
 30.1402 -              | _ => (Path.ext "hs" o Path.explode o implode o separate "/" o NameSpace.explode) modlname;
 30.1403 -            val pathname = Path.append destination filename;
 30.1404 -            val _ = File.mkdir (Path.dir pathname);
 30.1405 -          in File.write pathname end
 30.1406 -      | write_module NONE _ = writeln;
 30.1407 -    fun seri_module (modlname', (imports, (defs, _))) =
 30.1408 -      let
 30.1409 -        val imports' =
 30.1410 -          imports
 30.1411 -          |> map (name_modl o fst o dest_name)
 30.1412 -          |> distinct (op =)
 30.1413 -          |> remove (op =) modlname';
 30.1414 -        val qualified =
 30.1415 -          imports
 30.1416 -          |> map_filter (try deresolv)
 30.1417 -          |> map NameSpace.base
 30.1418 -          |> has_duplicates (op =);
 30.1419 -        val mk_import = str o (if qualified
 30.1420 -          then prefix "import qualified "
 30.1421 -          else prefix "import ") o suffix ";";
 30.1422 -      in
 30.1423 -        Pretty.chunks (
 30.1424 -          str ("module " ^ modlname' ^ " where {")
 30.1425 -          :: str ""
 30.1426 -          :: map mk_import imports'
 30.1427 -          @ str ""
 30.1428 -          :: separate (str "") ((case module_prolog modlname'
 30.1429 -             of SOME prolog => [prolog]
 30.1430 -              | NONE => [])
 30.1431 -          @ map_filter
 30.1432 -            (fn (name, (_, SOME def)) => SOME (seri_def qualified (name, def))
 30.1433 -              | (_, (_, NONE)) => NONE) defs)
 30.1434 -          @ str ""
 30.1435 -          @@ str "}"
 30.1436 -        )
 30.1437 -        |> code_output
 30.1438 -        |> write_module destination modlname'
 30.1439 -      end;
 30.1440 -  in Symtab.fold (fn modl => fn () => seri_module modl) code' () end;
 30.1441 -
 30.1442 -fun isar_seri_haskell module file =
 30.1443 -  let
 30.1444 -    val destination = case file
 30.1445 -     of NONE => error ("Haskell: no internal compilation")
 30.1446 -      | SOME "-" => NONE
 30.1447 -      | SOME file => SOME (Path.explode file)
 30.1448 -  in
 30.1449 -    parse_args (Scan.option (Args.$$$ "root" -- Args.colon |-- Args.name)
 30.1450 -      -- Scan.optional (Args.$$$ "string_classes" >> K true) false
 30.1451 -      >> (fn (module_prefix, string_classes) =>
 30.1452 -        seri_haskell module_prefix module destination string_classes))
 30.1453 -  end;
 30.1454 -
 30.1455 -
 30.1456 -(** diagnosis serializer **)
 30.1457 -
 30.1458 -fun seri_diagnosis labelled_name _ _ _ _ _ _ code =
 30.1459 -  let
 30.1460 -    val init_names = CodegenNames.make_vars [];
 30.1461 -    fun pr_fun "fun" = SOME (2, fn pr_typ => fn fxy => fn [ty1, ty2] =>
 30.1462 -          brackify_infix (1, R) fxy [
 30.1463 -            pr_typ (INFX (1, X)) ty1,
 30.1464 -            str "->",
 30.1465 -            pr_typ (INFX (1, R)) ty2
 30.1466 -          ])
 30.1467 -      | pr_fun _ = NONE
 30.1468 -    val pr = pr_haskell (K NONE) pr_fun (K NONE) labelled_name init_names I I (K false) (K false);
 30.1469 -  in
 30.1470 -    []
 30.1471 -    |> Graph.fold (fn (name, (def, _)) => case try pr (name, def) of SOME p => cons p | NONE => I) code
 30.1472 -    |> Pretty.chunks2
 30.1473 -    |> code_output
 30.1474 -    |> writeln
 30.1475 -  end;
 30.1476 -
 30.1477 -
 30.1478 -
 30.1479 -(** theory data **)
 30.1480 -
 30.1481 -datatype syntax_expr = SyntaxExpr of {
 30.1482 -  class: (string * (string -> string option)) Symtab.table,
 30.1483 -  inst: unit Symtab.table,
 30.1484 -  tyco: typ_syntax Symtab.table,
 30.1485 -  const: term_syntax Symtab.table
 30.1486 -};
 30.1487 -
 30.1488 -fun mk_syntax_expr ((class, inst), (tyco, const)) =
 30.1489 -  SyntaxExpr { class = class, inst = inst, tyco = tyco, const = const };
 30.1490 -fun map_syntax_expr f (SyntaxExpr { class, inst, tyco, const }) =
 30.1491 -  mk_syntax_expr (f ((class, inst), (tyco, const)));
 30.1492 -fun merge_syntax_expr (SyntaxExpr { class = class1, inst = inst1, tyco = tyco1, const = const1 },
 30.1493 -    SyntaxExpr { class = class2, inst = inst2, tyco = tyco2, const = const2 }) =
 30.1494 -  mk_syntax_expr (
 30.1495 -    (Symtab.join (K snd) (class1, class2),
 30.1496 -       Symtab.join (K snd) (inst1, inst2)),
 30.1497 -    (Symtab.join (K snd) (tyco1, tyco2),
 30.1498 -       Symtab.join (K snd) (const1, const2))
 30.1499 -  );
 30.1500 -
 30.1501 -datatype syntax_modl = SyntaxModl of {
 30.1502 -  alias: string Symtab.table,
 30.1503 -  prolog: Pretty.T Symtab.table
 30.1504 -};
 30.1505 -
 30.1506 -fun mk_syntax_modl (alias, prolog) =
 30.1507 -  SyntaxModl { alias = alias, prolog = prolog };
 30.1508 -fun map_syntax_modl f (SyntaxModl { alias, prolog }) =
 30.1509 -  mk_syntax_modl (f (alias, prolog));
 30.1510 -fun merge_syntax_modl (SyntaxModl { alias = alias1, prolog = prolog1 },
 30.1511 -    SyntaxModl { alias = alias2, prolog = prolog2 }) =
 30.1512 -  mk_syntax_modl (
 30.1513 -    Symtab.join (K snd) (alias1, alias2),
 30.1514 -    Symtab.join (K snd) (prolog1, prolog2)
 30.1515 -  );
 30.1516 -
 30.1517 -type serializer =
 30.1518 -  string option
 30.1519 -  -> string option
 30.1520 -  -> Args.T list
 30.1521 -  -> (string -> string)
 30.1522 -  -> string list
 30.1523 -  -> (string -> string option)
 30.1524 -  -> (string -> Pretty.T option)
 30.1525 -  -> (string -> class_syntax option)
 30.1526 -  -> (string -> typ_syntax option)
 30.1527 -  -> (string -> term_syntax option)
 30.1528 -  -> CodegenThingol.code -> unit;
 30.1529 -
 30.1530 -datatype target = Target of {
 30.1531 -  serial: serial,
 30.1532 -  serializer: serializer,
 30.1533 -  syntax_expr: syntax_expr,
 30.1534 -  syntax_modl: syntax_modl,
 30.1535 -  reserved: string list
 30.1536 -};
 30.1537 -
 30.1538 -fun mk_target (serial, ((serializer, reserved), (syntax_expr, syntax_modl))) =
 30.1539 -  Target { serial = serial, reserved = reserved, serializer = serializer, syntax_expr = syntax_expr, syntax_modl = syntax_modl };
 30.1540 -fun map_target f ( Target { serial, serializer, reserved, syntax_expr, syntax_modl } ) =
 30.1541 -  mk_target (f (serial, ((serializer, reserved), (syntax_expr, syntax_modl))));
 30.1542 -fun merge_target target (Target { serial = serial1, serializer = serializer, reserved = reserved1,
 30.1543 -  syntax_expr = syntax_expr1, syntax_modl = syntax_modl1 },
 30.1544 -    Target { serial = serial2, serializer = _, reserved = reserved2,
 30.1545 -      syntax_expr = syntax_expr2, syntax_modl = syntax_modl2 }) =
 30.1546 -  if serial1 = serial2 then
 30.1547 -    mk_target (serial1, ((serializer, merge (op =) (reserved1, reserved2)),
 30.1548 -      (merge_syntax_expr (syntax_expr1, syntax_expr2),
 30.1549 -        merge_syntax_modl (syntax_modl1, syntax_modl2))
 30.1550 -    ))
 30.1551 -  else
 30.1552 -    error ("Incompatible serializers: " ^ quote target);
 30.1553 -
 30.1554 -structure CodegenSerializerData = TheoryDataFun
 30.1555 -(
 30.1556 -  type T = target Symtab.table;
 30.1557 -  val empty = Symtab.empty;
 30.1558 -  val copy = I;
 30.1559 -  val extend = I;
 30.1560 -  fun merge _ = Symtab.join merge_target;
 30.1561 -);
 30.1562 -
 30.1563 -fun the_serializer (Target { serializer, ... }) = serializer;
 30.1564 -fun the_reserved (Target { reserved, ... }) = reserved;
 30.1565 -fun the_syntax_expr (Target { syntax_expr = SyntaxExpr x, ... }) = x;
 30.1566 -fun the_syntax_modl (Target { syntax_modl = SyntaxModl x, ... }) = x;
 30.1567 -
 30.1568 -fun assert_serializer thy target =
 30.1569 -  case Symtab.lookup (CodegenSerializerData.get thy) target
 30.1570 -   of SOME data => target
 30.1571 -    | NONE => error ("Unknown code target language: " ^ quote target);
 30.1572 -
 30.1573 -fun add_serializer (target, seri) thy =
 30.1574 -  let
 30.1575 -    val _ = case Symtab.lookup (CodegenSerializerData.get thy) target
 30.1576 -     of SOME _ => warning ("overwriting existing serializer " ^ quote target)
 30.1577 -      | NONE => ();
 30.1578 -  in
 30.1579 -    thy
 30.1580 -    |> (CodegenSerializerData.map oo Symtab.map_default)
 30.1581 -          (target, mk_target (serial (), ((seri, []),
 30.1582 -            (mk_syntax_expr ((Symtab.empty, Symtab.empty), (Symtab.empty, Symtab.empty)),
 30.1583 -              mk_syntax_modl (Symtab.empty, Symtab.empty)))))
 30.1584 -          (map_target (fn (serial, ((_, keywords), syntax)) => (serial, ((seri, keywords), syntax))))
 30.1585 -  end;
 30.1586 -
 30.1587 -fun map_seri_data target f thy =
 30.1588 -  let
 30.1589 -    val _ = assert_serializer thy target;
 30.1590 -  in
 30.1591 -    thy
 30.1592 -    |> (CodegenSerializerData.map o Symtab.map_entry target o map_target) f
 30.1593 -  end;
 30.1594 -
 30.1595 -val target_SML = "SML";
 30.1596 -val target_OCaml = "OCaml";
 30.1597 -val target_Haskell = "Haskell";
 30.1598 -val target_diag = "diag";
 30.1599 -
 30.1600 -val _ = Context.add_setup (
 30.1601 -  add_serializer (target_SML, isar_seri_sml)
 30.1602 -  #> add_serializer (target_OCaml, isar_seri_ocaml)
 30.1603 -  #> add_serializer (target_Haskell, isar_seri_haskell)
 30.1604 -  #> add_serializer (target_diag, (fn _ => fn _ => fn _ => seri_diagnosis))
 30.1605 -);
 30.1606 -
 30.1607 -fun get_serializer thy target permissive module file args labelled_name = fn cs =>
 30.1608 -  let
 30.1609 -    val data = case Symtab.lookup (CodegenSerializerData.get thy) target
 30.1610 -     of SOME data => data
 30.1611 -      | NONE => error ("Unknown code target language: " ^ quote target);
 30.1612 -    val seri = the_serializer data;
 30.1613 -    val reserved = the_reserved data;
 30.1614 -    val { alias, prolog } = the_syntax_modl data;
 30.1615 -    val { class, inst, tyco, const } = the_syntax_expr data;
 30.1616 -    val project = if target = target_diag then I
 30.1617 -      else CodegenThingol.project_code permissive
 30.1618 -        (Symtab.keys class @ Symtab.keys inst @ Symtab.keys tyco @ Symtab.keys const) cs;
 30.1619 -    fun check_empty_funs code = case CodegenThingol.empty_funs code
 30.1620 -     of [] => code
 30.1621 -      | names => error ("No defining equations for " ^ commas (map (labelled_name thy) names));
 30.1622 -  in
 30.1623 -    project
 30.1624 -    #> check_empty_funs
 30.1625 -    #> seri module file args (labelled_name thy) reserved (Symtab.lookup alias) (Symtab.lookup prolog)
 30.1626 -      (Symtab.lookup class) (Symtab.lookup tyco) (Symtab.lookup const)
 30.1627 -  end;
 30.1628 -
 30.1629 -fun eval_term thy labelled_name code ((ref_name, reff), t) args =
 30.1630 -  let
 30.1631 -    val val_name = "Isabelle_Eval.EVAL.EVAL";
 30.1632 -    val val_name' = "Isabelle_Eval.EVAL";
 30.1633 -    val val_name'_args = space_implode " " (val_name' :: map (enclose "(" ")") args);
 30.1634 -    val seri = get_serializer thy "SML" false (SOME "Isabelle_Eval") NONE [] labelled_name;
 30.1635 -    fun eval code = (
 30.1636 -      reff := NONE;
 30.1637 -      seri (SOME [val_name]) code;
 30.1638 -      use_text "generated code for evaluation" Output.ml_output (!eval_verbose)
 30.1639 -        ("val _ = (" ^ ref_name ^ " := SOME (" ^ val_name'_args ^ "))");
 30.1640 -      case !reff
 30.1641 -       of NONE => error ("Could not retrieve value of ML reference " ^ quote ref_name
 30.1642 -            ^ " (reference probably has been shadowed)")
 30.1643 -        | SOME value => value
 30.1644 -      );
 30.1645 -  in
 30.1646 -    code
 30.1647 -    |> CodegenThingol.add_eval_def (val_name, t)
 30.1648 -    |> eval
 30.1649 -  end;
 30.1650 -
 30.1651 -
 30.1652 -
 30.1653 -(** optional pretty serialization **)
 30.1654 -
 30.1655 -local
 30.1656 -
 30.1657 -val pretty : (string * {
 30.1658 -    pretty_char: string -> string,
 30.1659 -    pretty_string: string -> string,
 30.1660 -    pretty_numeral: bool -> IntInf.int -> string,
 30.1661 -    pretty_list: Pretty.T list -> Pretty.T,
 30.1662 -    infix_cons: int * string
 30.1663 -  }) list = [
 30.1664 -  ("SML", { pretty_char = prefix "#" o quote o ML_Syntax.print_char,
 30.1665 -      pretty_string = ML_Syntax.print_string,
 30.1666 -      pretty_numeral = fn unbounded => fn k =>
 30.1667 -        if unbounded then "(" ^ IntInf.toString k ^ " : IntInf.int)"
 30.1668 -        else IntInf.toString k,
 30.1669 -      pretty_list = Pretty.enum "," "[" "]",
 30.1670 -      infix_cons = (7, "::")}),
 30.1671 -  ("OCaml", { pretty_char = fn c => enclose "'" "'"
 30.1672 -        (let val i = ord c
 30.1673 -          in if i < 32 orelse i = 39 orelse i = 92
 30.1674 -            then prefix "\\" (string_of_int i)
 30.1675 -            else c
 30.1676 -          end),
 30.1677 -      pretty_string = (fn _ => error "OCaml: no pretty strings"),
 30.1678 -      pretty_numeral = fn unbounded => fn k => if k >= IntInf.fromInt 0 then
 30.1679 -            if unbounded then
 30.1680 -              "(Big_int.big_int_of_int " ^ IntInf.toString k ^ ")"
 30.1681 -            else IntInf.toString k
 30.1682 -          else
 30.1683 -            if unbounded then
 30.1684 -              "(Big_int.big_int_of_int " ^ (enclose "(" ")" o prefix "-"
 30.1685 -                o IntInf.toString o op ~) k ^ ")"
 30.1686 -            else (enclose "(" ")" o prefix "-" o IntInf.toString o op ~) k,
 30.1687 -      pretty_list = Pretty.enum ";" "[" "]",
 30.1688 -      infix_cons = (6, "::")}),
 30.1689 -  ("Haskell", { pretty_char = fn c => enclose "'" "'"
 30.1690 -        (let val i = ord c
 30.1691 -          in if i < 32 orelse i = 39 orelse i = 92
 30.1692 -            then Library.prefix "\\" (string_of_int i)
 30.1693 -            else c
 30.1694 -          end),
 30.1695 -      pretty_string = ML_Syntax.print_string,
 30.1696 -      pretty_numeral = fn unbounded => fn k => if k >= IntInf.fromInt 0 then
 30.1697 -            IntInf.toString k
 30.1698 -          else
 30.1699 -            (enclose "(" ")" o Library.prefix "-" o IntInf.toString o IntInf.~) k,
 30.1700 -      pretty_list = Pretty.enum "," "[" "]",
 30.1701 -      infix_cons = (5, ":")})
 30.1702 -];
 30.1703 -
 30.1704 -in
 30.1705 -
 30.1706 -fun pr_pretty target = case AList.lookup (op =) pretty target
 30.1707 - of SOME x => x
 30.1708 -  | NONE => error ("Unknown code target language: " ^ quote target);
 30.1709 -
 30.1710 -fun default_list (target_fxy, target_cons) pr fxy t1 t2 =
 30.1711 -  brackify_infix (target_fxy, R) fxy [
 30.1712 -    pr (INFX (target_fxy, X)) t1,
 30.1713 -    str target_cons,
 30.1714 -    pr (INFX (target_fxy, R)) t2
 30.1715 -  ];
 30.1716 -
 30.1717 -fun pretty_list c_nil c_cons target =
 30.1718 -  let
 30.1719 -    val pretty_ops = pr_pretty target;
 30.1720 -    val mk_list = #pretty_list pretty_ops;
 30.1721 -    fun pretty pr vars fxy [(t1, _), (t2, _)] =
 30.1722 -      case Option.map (cons t1) (implode_list c_nil c_cons t2)
 30.1723 -       of SOME ts => mk_list (map (pr vars NOBR) ts)
 30.1724 -        | NONE => default_list (#infix_cons pretty_ops) (pr vars) fxy t1 t2;
 30.1725 -  in (2, pretty) end;
 30.1726 -
 30.1727 -fun pretty_list_string c_nil c_cons c_char c_nibbles target =
 30.1728 -  let
 30.1729 -    val pretty_ops = pr_pretty target;
 30.1730 -    val mk_list = #pretty_list pretty_ops;
 30.1731 -    val mk_char = #pretty_char pretty_ops;
 30.1732 -    val mk_string = #pretty_string pretty_ops;
 30.1733 -    fun pretty pr vars fxy [(t1, _), (t2, _)] =
 30.1734 -      case Option.map (cons t1) (implode_list c_nil c_cons t2)
 30.1735 -       of SOME ts => case implode_string c_char c_nibbles mk_char mk_string ts
 30.1736 -           of SOME p => p
 30.1737 -            | NONE => mk_list (map (pr vars NOBR) ts)
 30.1738 -        | NONE => default_list (#infix_cons pretty_ops) (pr vars) fxy t1 t2;
 30.1739 -  in (2, pretty) end;
 30.1740 -
 30.1741 -fun pretty_char c_char c_nibbles target =
 30.1742 -  let
 30.1743 -    val mk_char = #pretty_char (pr_pretty target);
 30.1744 -    fun pretty _ _ _ [(t1, _), (t2, _)] =
 30.1745 -      case decode_char c_nibbles (t1, t2)
 30.1746 -       of SOME c => (str o mk_char) c
 30.1747 -        | NONE => error "Illegal character expression";
 30.1748 -  in (2, pretty) end;
 30.1749 -
 30.1750 -fun pretty_numeral unbounded c_bit0 c_bit1 c_pls c_min c_bit target =
 30.1751 -  let
 30.1752 -    val mk_numeral = #pretty_numeral (pr_pretty target);
 30.1753 -    fun pretty _ _ _ [(t, _)] =
 30.1754 -      case implode_numeral c_bit0 c_bit1 c_pls c_min c_bit t
 30.1755 -       of SOME k => (str o mk_numeral unbounded) k
 30.1756 -        | NONE => error "Illegal numeral expression";
 30.1757 -  in (1, pretty) end;
 30.1758 -
 30.1759 -fun pretty_ml_string c_char c_nibbles c_nil c_cons target =
 30.1760 -  let
 30.1761 -    val pretty_ops = pr_pretty target;
 30.1762 -    val mk_char = #pretty_char pretty_ops;
 30.1763 -    val mk_string = #pretty_string pretty_ops;
 30.1764 -    fun pretty pr vars fxy [(t, _)] =
 30.1765 -      case implode_list c_nil c_cons t
 30.1766 -       of SOME ts => (case implode_string c_char c_nibbles mk_char mk_string ts
 30.1767 -           of SOME p => p
 30.1768 -            | NONE => error "Illegal ml_string expression")
 30.1769 -        | NONE => error "Illegal ml_string expression";
 30.1770 -  in (1, pretty) end;
 30.1771 -
 30.1772 -val pretty_imperative_monad_bind =
 30.1773 -  let
 30.1774 -    fun pretty (pr : CodegenNames.var_ctxt -> fixity -> iterm -> Pretty.T)
 30.1775 -          vars fxy [(t1, _), ((v, ty) `|-> t2, _)] =
 30.1776 -            pr vars fxy (ICase (((t1, ty), ([(IVar v, t2)])), IVar ""))
 30.1777 -      | pretty pr vars fxy [(t1, _), (t2, ty2)] =
 30.1778 -          let
 30.1779 -            (*this code suffers from the lack of a proper concept for bindings*)
 30.1780 -            val vs = CodegenThingol.fold_varnames cons t2 [];
 30.1781 -            val v = Name.variant vs "x";
 30.1782 -            val vars' = CodegenNames.intro_vars [v] vars;
 30.1783 -            val var = IVar v;
 30.1784 -            val ty = (hd o fst o CodegenThingol.unfold_fun) ty2;
 30.1785 -          in pr vars' fxy (ICase (((t1, ty), ([(var, t2 `$ var)])), IVar "")) end;
 30.1786 -  in (2, pretty) end;
 30.1787 -
 30.1788 -end; (*local*)
 30.1789 -
 30.1790 -(** ML and Isar interface **)
 30.1791 -
 30.1792 -local
 30.1793 -
 30.1794 -fun map_syntax_exprs target =
 30.1795 -  map_seri_data target o apsnd o apsnd o apfst o map_syntax_expr;
 30.1796 -fun map_syntax_modls target =
 30.1797 -  map_seri_data target o apsnd o apsnd o apsnd o map_syntax_modl;
 30.1798 -fun map_reserveds target =
 30.1799 -  map_seri_data target o apsnd o apfst o apsnd;
 30.1800 -
 30.1801 -fun gen_add_syntax_class prep_class prep_const target raw_class raw_syn thy =
 30.1802 -  let
 30.1803 -    val cls = prep_class thy raw_class;
 30.1804 -    val class = CodegenNames.class thy cls;
 30.1805 -    fun mk_classop (const as (c, _)) = case AxClass.class_of_param thy c
 30.1806 -     of SOME class' => if cls = class' then CodegenNames.const thy const
 30.1807 -          else error ("Not a class operation for class " ^ quote class ^ ": " ^ quote c)
 30.1808 -      | NONE => error ("Not a class operation: " ^ quote c);
 30.1809 -    fun mk_syntax_ops raw_ops = AList.lookup (op =)
 30.1810 -      ((map o apfst) (mk_classop o prep_const thy) raw_ops);
 30.1811 -  in case raw_syn
 30.1812 -   of SOME (syntax, raw_ops) =>
 30.1813 -      thy
 30.1814 -      |> (map_syntax_exprs target o apfst o apfst)
 30.1815 -           (Symtab.update (class, (syntax, mk_syntax_ops raw_ops)))
 30.1816 -    | NONE =>
 30.1817 -      thy
 30.1818 -      |> (map_syntax_exprs target o apfst o apfst)
 30.1819 -           (Symtab.delete_safe class)
 30.1820 -  end;
 30.1821 -
 30.1822 -fun gen_add_syntax_inst prep_class prep_tyco target (raw_tyco, raw_class) add_del thy =
 30.1823 -  let
 30.1824 -    val inst = CodegenNames.instance thy (prep_class thy raw_class, prep_tyco thy raw_tyco);
 30.1825 -  in if add_del then
 30.1826 -    thy
 30.1827 -    |> (map_syntax_exprs target o apfst o apsnd)
 30.1828 -        (Symtab.update (inst, ()))
 30.1829 -  else
 30.1830 -    thy
 30.1831 -    |> (map_syntax_exprs target o apfst o apsnd)
 30.1832 -        (Symtab.delete_safe inst)
 30.1833 -  end;
 30.1834 -
 30.1835 -fun gen_add_syntax_tyco prep_tyco target raw_tyco raw_syn thy =
 30.1836 -  let
 30.1837 -    val tyco = prep_tyco thy raw_tyco;
 30.1838 -    val tyco' = if tyco = "fun" then "fun" else CodegenNames.tyco thy tyco;
 30.1839 -    fun check_args (syntax as (n, _)) = if n <> Sign.arity_number thy tyco
 30.1840 -      then error ("Number of arguments mismatch in syntax for type constructor " ^ quote tyco)
 30.1841 -      else syntax
 30.1842 -  in case raw_syn
 30.1843 -   of SOME syntax =>
 30.1844 -      thy
 30.1845 -      |> (map_syntax_exprs target o apsnd o apfst)
 30.1846 -           (Symtab.update (tyco', check_args syntax))
 30.1847 -   | NONE =>
 30.1848 -      thy
 30.1849 -      |> (map_syntax_exprs target o apsnd o apfst)
 30.1850 -           (Symtab.delete_safe tyco')
 30.1851 -  end;
 30.1852 -
 30.1853 -fun gen_add_syntax_const prep_const target raw_c raw_syn thy =
 30.1854 -  let
 30.1855 -    val c = prep_const thy raw_c;
 30.1856 -    val c' = CodegenNames.const thy c;
 30.1857 -    fun check_args (syntax as (n, _)) = if n > (length o fst o strip_type o Sign.the_const_type thy o fst) c
 30.1858 -      then error ("Too many arguments in syntax for constant " ^ (quote o fst) c)
 30.1859 -      else syntax;
 30.1860 -  in case raw_syn
 30.1861 -   of SOME syntax =>
 30.1862 -      thy
 30.1863 -      |> (map_syntax_exprs target o apsnd o apsnd)
 30.1864 -           (Symtab.update (c', check_args syntax))
 30.1865 -   | NONE =>
 30.1866 -      thy
 30.1867 -      |> (map_syntax_exprs target o apsnd o apsnd)
 30.1868 -           (Symtab.delete_safe c')
 30.1869 -  end;
 30.1870 -
 30.1871 -fun cert_class thy class =
 30.1872 -  let
 30.1873 -    val _ = AxClass.get_definition thy class;
 30.1874 -  in class end;
 30.1875 -
 30.1876 -fun read_class thy raw_class =
 30.1877 -  let
 30.1878 -    val class = Sign.intern_class thy raw_class;
 30.1879 -    val _ = AxClass.get_definition thy class;
 30.1880 -  in class end;
 30.1881 -
 30.1882 -fun cert_tyco thy tyco =
 30.1883 -  let
 30.1884 -    val _ = if Sign.declared_tyname thy tyco then ()
 30.1885 -      else error ("No such type constructor: " ^ quote tyco);
 30.1886 -  in tyco end;
 30.1887 -
 30.1888 -fun read_tyco thy raw_tyco =
 30.1889 -  let
 30.1890 -    val tyco = Sign.intern_type thy raw_tyco;
 30.1891 -    val _ = if Sign.declared_tyname thy tyco then ()
 30.1892 -      else error ("No such type constructor: " ^ quote raw_tyco);
 30.1893 -  in tyco end;
 30.1894 -
 30.1895 -fun idfs_of_const thy c =
 30.1896 -  let
 30.1897 -    val c' = (c, Sign.the_const_type thy c);
 30.1898 -    val c'' = CodegenConsts.const_of_cexpr thy c';
 30.1899 -  in (c'', CodegenNames.const thy c'') end;
 30.1900 -
 30.1901 -fun no_bindings x = (Option.map o apsnd)
 30.1902 -  (fn pretty => fn pr => fn vars => pretty (pr vars)) x;
 30.1903 -
 30.1904 -fun gen_add_haskell_monad prep_const c_run c_mbind c_kbind thy =
 30.1905 -  let
 30.1906 -    val c_run' = prep_const thy c_run;
 30.1907 -    val c_mbind' = prep_const thy c_mbind;
 30.1908 -    val c_mbind'' = CodegenNames.const thy c_mbind';
 30.1909 -    val c_kbind' = prep_const thy c_kbind;
 30.1910 -    val c_kbind'' = CodegenNames.const thy c_kbind';
 30.1911 -    val pr = pretty_haskell_monad c_mbind'' c_kbind''
 30.1912 -  in
 30.1913 -    thy
 30.1914 -    |> gen_add_syntax_const (K I) target_Haskell c_run' (SOME pr)
 30.1915 -    |> gen_add_syntax_const (K I) target_Haskell c_mbind'
 30.1916 -          (no_bindings (SOME (parse_infix fst (L, 1) ">>=")))
 30.1917 -    |> gen_add_syntax_const (K I) target_Haskell c_kbind'
 30.1918 -          (no_bindings (SOME (parse_infix fst (L, 1) ">>")))
 30.1919 -  end;
 30.1920 -
 30.1921 -fun add_reserved target =
 30.1922 -  let
 30.1923 -    fun add sym syms = if member (op =) syms sym
 30.1924 -      then error ("Reserved symbol " ^ quote sym ^ " already declared")
 30.1925 -      else insert (op =) sym syms
 30.1926 -  in map_reserveds target o add end;
 30.1927 -
 30.1928 -fun add_modl_alias target =
 30.1929 -  map_syntax_modls target o apfst o Symtab.update o apsnd CodegenNames.check_modulename;
 30.1930 -
 30.1931 -fun add_modl_prolog target =
 30.1932 -  map_syntax_modls target o apsnd o
 30.1933 -    (fn (modl, NONE) => Symtab.delete modl | (modl, SOME prolog) =>
 30.1934 -      Symtab.update (modl, Pretty.str prolog));
 30.1935 -
 30.1936 -fun zip_list (x::xs) f g =
 30.1937 -  f
 30.1938 -  #-> (fn y =>
 30.1939 -    fold_map (fn x => g |-- f >> pair x) xs
 30.1940 -    #-> (fn xys => pair ((x, y) :: xys)));
 30.1941 -
 30.1942 -structure P = OuterParse
 30.1943 -and K = OuterKeyword
 30.1944 -
 30.1945 -fun parse_multi_syntax parse_thing parse_syntax =
 30.1946 -  P.and_list1 parse_thing
 30.1947 -  #-> (fn things => Scan.repeat1 (P.$$$ "(" |-- P.name --
 30.1948 -        (zip_list things parse_syntax (P.$$$ "and")) --| P.$$$ ")"));
 30.1949 -
 30.1950 -val (infixK, infixlK, infixrK) = ("infix", "infixl", "infixr");
 30.1951 -
 30.1952 -fun parse_syntax prep_arg xs =
 30.1953 -  Scan.option ((
 30.1954 -      ((P.$$$ infixK  >> K X)
 30.1955 -        || (P.$$$ infixlK >> K L)
 30.1956 -        || (P.$$$ infixrK >> K R))
 30.1957 -        -- P.nat >> parse_infix prep_arg
 30.1958 -      || Scan.succeed (parse_mixfix prep_arg))
 30.1959 -      -- P.string
 30.1960 -      >> (fn (parse, s) => parse s)) xs;
 30.1961 -
 30.1962 -val (code_classK, code_instanceK, code_typeK, code_constK, code_monadK,
 30.1963 -  code_reservedK, code_modulenameK, code_moduleprologK) =
 30.1964 -  ("code_class", "code_instance", "code_type", "code_const", "code_monad",
 30.1965 -    "code_reserved", "code_modulename", "code_moduleprolog");
 30.1966 -
 30.1967 -in
 30.1968 -
 30.1969 -val parse_syntax = parse_syntax;
 30.1970 -
 30.1971 -val add_syntax_class = gen_add_syntax_class cert_class (K I);
 30.1972 -val add_syntax_inst = gen_add_syntax_inst cert_class cert_tyco;
 30.1973 -val add_syntax_tyco = gen_add_syntax_tyco cert_tyco;
 30.1974 -val add_syntax_const = gen_add_syntax_const (K I);
 30.1975 -
 30.1976 -val add_syntax_class_cmd = gen_add_syntax_class read_class CodegenConsts.read_const;
 30.1977 -val add_syntax_inst_cmd = gen_add_syntax_inst read_class read_tyco;
 30.1978 -val add_syntax_tyco_cmd = gen_add_syntax_tyco read_tyco;
 30.1979 -val add_syntax_const_cmd = gen_add_syntax_const CodegenConsts.read_const;
 30.1980 -
 30.1981 -fun add_syntax_tycoP target tyco = parse_syntax I >> add_syntax_tyco_cmd target tyco;
 30.1982 -fun add_syntax_constP target c = parse_syntax fst >> (add_syntax_const_cmd target c o no_bindings);
 30.1983 -
 30.1984 -fun add_undefined target undef target_undefined thy =
 30.1985 -  let
 30.1986 -    val (undef', _) = idfs_of_const thy undef;
 30.1987 -    fun pr _ _ _ _ = str target_undefined;
 30.1988 -  in
 30.1989 -    thy
 30.1990 -    |> add_syntax_const target undef' (SOME (~1, pr))
 30.1991 -  end;
 30.1992 -
 30.1993 -fun add_pretty_list target nill cons thy =
 30.1994 -  let
 30.1995 -    val (_, nil'') = idfs_of_const thy nill;
 30.1996 -    val (cons', cons'') = idfs_of_const thy cons;
 30.1997 -    val pr = pretty_list nil'' cons'' target;
 30.1998 -  in
 30.1999 -    thy
 30.2000 -    |> add_syntax_const target cons' (SOME pr)
 30.2001 -  end;
 30.2002 -
 30.2003 -fun add_pretty_list_string target nill cons charr nibbles thy =
 30.2004 -  let
 30.2005 -    val (_, nil'') = idfs_of_const thy nill;
 30.2006 -    val (cons', cons'') = idfs_of_const thy cons;
 30.2007 -    val (_, charr'') = idfs_of_const thy charr;
 30.2008 -    val (_, nibbles'') = split_list (map (idfs_of_const thy) nibbles);
 30.2009 -    val pr = pretty_list_string nil'' cons'' charr'' nibbles'' target;
 30.2010 -  in
 30.2011 -    thy
 30.2012 -    |> add_syntax_const target cons' (SOME pr)
 30.2013 -  end;
 30.2014 -
 30.2015 -fun add_pretty_char target charr nibbles thy =
 30.2016 -  let
 30.2017 -    val (charr', charr'') = idfs_of_const thy charr;
 30.2018 -    val (_, nibbles'') = split_list (map (idfs_of_const thy) nibbles);
 30.2019 -    val pr = pretty_char charr'' nibbles'' target;
 30.2020 -  in
 30.2021 -    thy
 30.2022 -    |> add_syntax_const target charr' (SOME pr)
 30.2023 -  end;
 30.2024 -
 30.2025 -fun add_pretty_numeral target unbounded number_of b0 b1 pls min bit thy =
 30.2026 -  let
 30.2027 -    val number_of' = CodegenConsts.const_of_cexpr thy number_of;
 30.2028 -    val (_, b0'') = idfs_of_const thy b0;
 30.2029 -    val (_, b1'') = idfs_of_const thy b1;
 30.2030 -    val (_, pls'') = idfs_of_const thy pls;
 30.2031 -    val (_, min'') = idfs_of_const thy min;
 30.2032 -    val (_, bit'') = idfs_of_const thy bit;
 30.2033 -    val pr = pretty_numeral unbounded b0'' b1'' pls'' min'' bit'' target;
 30.2034 -  in
 30.2035 -    thy
 30.2036 -    |> add_syntax_const target number_of' (SOME pr)
 30.2037 -  end;
 30.2038 -
 30.2039 -fun add_pretty_ml_string target charr nibbles nill cons str thy =
 30.2040 -  let
 30.2041 -    val (_, charr'') = idfs_of_const thy charr;
 30.2042 -    val (_, nibbles'') = split_list (map (idfs_of_const thy) nibbles);
 30.2043 -    val (_, nil'') = idfs_of_const thy nill;
 30.2044 -    val (_, cons'') = idfs_of_const thy cons;
 30.2045 -    val (str', _) = idfs_of_const thy str;
 30.2046 -    val pr = pretty_ml_string charr'' nibbles'' nil'' cons'' target;
 30.2047 -  in
 30.2048 -    thy
 30.2049 -    |> add_syntax_const target str' (SOME pr)
 30.2050 -  end;
 30.2051 -
 30.2052 -fun add_pretty_imperative_monad_bind target bind thy =
 30.2053 -  let
 30.2054 -    val (bind', _) = idfs_of_const thy bind;
 30.2055 -    val pr = pretty_imperative_monad_bind
 30.2056 -  in
 30.2057 -    thy
 30.2058 -    |> add_syntax_const target bind' (SOME pr)
 30.2059 -  end;
 30.2060 -
 30.2061 -val add_haskell_monad = gen_add_haskell_monad CodegenConsts.read_const;
 30.2062 -
 30.2063 -val code_classP =
 30.2064 -  OuterSyntax.command code_classK "define code syntax for class" K.thy_decl (
 30.2065 -    parse_multi_syntax P.xname
 30.2066 -      (Scan.option (P.string -- Scan.optional (P.$$$ "where" |-- Scan.repeat1
 30.2067 -        (P.term --| (P.$$$ "\\<equiv>" || P.$$$ "==") -- P.string)) []))
 30.2068 -    >> (Toplevel.theory oo fold) (fn (target, syns) =>
 30.2069 -          fold (fn (raw_class, syn) => add_syntax_class_cmd target raw_class syn) syns)
 30.2070 -  );
 30.2071 -
 30.2072 -val code_instanceP =
 30.2073 -  OuterSyntax.command code_instanceK "define code syntax for instance" K.thy_decl (
 30.2074 -    parse_multi_syntax (P.xname --| P.$$$ "::" -- P.xname)
 30.2075 -      ((P.minus >> K true) || Scan.succeed false)
 30.2076 -    >> (Toplevel.theory oo fold) (fn (target, syns) =>
 30.2077 -          fold (fn (raw_inst, add_del) => add_syntax_inst_cmd target raw_inst add_del) syns)
 30.2078 -  );
 30.2079 -
 30.2080 -val code_typeP =
 30.2081 -  OuterSyntax.command code_typeK "define code syntax for type constructor" K.thy_decl (
 30.2082 -    parse_multi_syntax P.xname (parse_syntax I)
 30.2083 -    >> (Toplevel.theory oo fold) (fn (target, syns) =>
 30.2084 -          fold (fn (raw_tyco, syn) => add_syntax_tyco_cmd target raw_tyco syn) syns)
 30.2085 -  );
 30.2086 -
 30.2087 -val code_constP =
 30.2088 -  OuterSyntax.command code_constK "define code syntax for constant" K.thy_decl (
 30.2089 -    parse_multi_syntax P.term (parse_syntax fst)
 30.2090 -    >> (Toplevel.theory oo fold) (fn (target, syns) =>
 30.2091 -          fold (fn (raw_const, syn) => add_syntax_const_cmd target raw_const (no_bindings syn)) syns)
 30.2092 -  );
 30.2093 -
 30.2094 -val code_monadP =
 30.2095 -  OuterSyntax.command code_monadK "define code syntax for Haskell monads" K.thy_decl (
 30.2096 -    P.term -- P.term -- P.term
 30.2097 -    >> (fn ((raw_run, raw_mbind), raw_kbind) => Toplevel.theory 
 30.2098 -          (add_haskell_monad raw_run raw_mbind raw_kbind))
 30.2099 -  );
 30.2100 -
 30.2101 -val code_reservedP =
 30.2102 -  OuterSyntax.command code_reservedK "declare words as reserved for target language" K.thy_decl (
 30.2103 -    P.name -- Scan.repeat1 P.name
 30.2104 -    >> (fn (target, reserveds) => (Toplevel.theory o fold (add_reserved target)) reserveds)
 30.2105 -  )
 30.2106 -
 30.2107 -val code_modulenameP =
 30.2108 -  OuterSyntax.command code_modulenameK "alias module to other name" K.thy_decl (
 30.2109 -    P.name -- Scan.repeat1 (P.name -- P.name)
 30.2110 -    >> (fn (target, modlnames) => (Toplevel.theory o fold (add_modl_alias target)) modlnames)
 30.2111 -  )
 30.2112 -
 30.2113 -val code_moduleprologP =
 30.2114 -  OuterSyntax.command code_moduleprologK "add prolog to module" K.thy_decl (
 30.2115 -    P.name -- Scan.repeat1 (P.name -- (P.text >> (fn "-" => NONE | s => SOME s)))
 30.2116 -    >> (fn (target, prologs) => (Toplevel.theory o fold (add_modl_prolog target)) prologs)
 30.2117 -  )
 30.2118 -
 30.2119 -val _ = OuterSyntax.add_keywords [infixK, infixlK, infixrK];
 30.2120 -
 30.2121 -val _ = OuterSyntax.add_parsers [code_classP, code_instanceP, code_typeP, code_constP,
 30.2122 -  code_reservedP, code_modulenameP, code_moduleprologP, code_monadP];
 30.2123 -
 30.2124 -
 30.2125 -(*including serializer defaults*)
 30.2126 -val _ = Context.add_setup (
 30.2127 -  add_syntax_tyco "SML" "fun" (SOME (2, fn pr_typ => fn fxy => fn [ty1, ty2] =>
 30.2128 -      (gen_brackify (case fxy of NOBR => false | _ => eval_fxy (INFX (1, R)) fxy) o Pretty.breaks) [
 30.2129 -        pr_typ (INFX (1, X)) ty1,
 30.2130 -        str "->",
 30.2131 -        pr_typ (INFX (1, R)) ty2
 30.2132 -      ]))
 30.2133 -  #> add_syntax_tyco "OCaml" "fun" (SOME (2, fn pr_typ => fn fxy => fn [ty1, ty2] =>
 30.2134 -      (gen_brackify (case fxy of NOBR => false | _ => eval_fxy (INFX (1, R)) fxy) o Pretty.breaks) [
 30.2135 -        pr_typ (INFX (1, X)) ty1,
 30.2136 -        str "->",
 30.2137 -        pr_typ (INFX (1, R)) ty2
 30.2138 -      ]))
 30.2139 -  #> add_syntax_tyco "Haskell" "fun" (SOME (2, fn pr_typ => fn fxy => fn [ty1, ty2] =>
 30.2140 -      brackify_infix (1, R) fxy [
 30.2141 -        pr_typ (INFX (1, X)) ty1,
 30.2142 -        str "->",
 30.2143 -        pr_typ (INFX (1, R)) ty2
 30.2144 -      ]))
 30.2145 -  #> fold (add_reserved "SML") ML_Syntax.reserved_names
 30.2146 -  #> fold (add_reserved "SML")
 30.2147 -      ["o" (*dictionary projections use it already*), "Fail", "div", "mod" (*standard infixes*)]
 30.2148 -  #> fold (add_reserved "OCaml") [
 30.2149 -      "and", "as", "assert", "begin", "class",
 30.2150 -      "constraint", "do", "done", "downto", "else", "end", "exception",
 30.2151 -      "external", "false", "for", "fun", "function", "functor", "if",
 30.2152 -      "in", "include", "inherit", "initializer", "lazy", "let", "match", "method",
 30.2153 -      "module", "mutable", "new", "object", "of", "open", "or", "private", "rec",
 30.2154 -      "sig", "struct", "then", "to", "true", "try", "type", "val",
 30.2155 -      "virtual", "when", "while", "with"
 30.2156 -    ]
 30.2157 -  #> fold (add_reserved "OCaml") ["failwith", "mod"]
 30.2158 -  #> fold (add_reserved "Haskell") [
 30.2159 -      "hiding", "deriving", "where", "case", "of", "infix", "infixl", "infixr",
 30.2160 -      "import", "default", "forall", "let", "in", "class", "qualified", "data",
 30.2161 -      "newtype", "instance", "if", "then", "else", "type", "as", "do", "module"
 30.2162 -    ]
 30.2163 -  #> fold (add_reserved "Haskell") [
 30.2164 -      "Prelude", "Main", "Bool", "Maybe", "Either", "Ordering", "Char", "String", "Int",
 30.2165 -      "Integer", "Float", "Double", "Rational", "IO", "Eq", "Ord", "Enum", "Bounded",
 30.2166 -      "Num", "Real", "Integral", "Fractional", "Floating", "RealFloat", "Monad", "Functor",
 30.2167 -      "AlreadyExists", "ArithException", "ArrayException", "AssertionFailed", "AsyncException",
 30.2168 -      "BlockedOnDeadMVar", "Deadlock", "Denormal", "DivideByZero", "DotNetException", "DynException",
 30.2169 -      "Dynamic", "EOF", "EQ", "EmptyRec", "ErrorCall", "ExitException", "ExitFailure",
 30.2170 -      "ExitSuccess", "False", "GT", "HeapOverflow",
 30.2171 -      "IOError", "IOException", "IllegalOperation",
 30.2172 -      "IndexOutOfBounds", "Just", "Key", "LT", "Left", "LossOfPrecision", "NoMethodError",
 30.2173 -      "NoSuchThing", "NonTermination", "Nothing", "Obj", "OtherError", "Overflow",
 30.2174 -      "PatternMatchFail", "PermissionDenied", "ProtocolError", "RecConError", "RecSelError",
 30.2175 -      "RecUpdError", "ResourceBusy", "ResourceExhausted", "Right", "StackOverflow",
 30.2176 -      "ThreadKilled", "True", "TyCon", "TypeRep", "UndefinedElement", "Underflow",
 30.2177 -      "UnsupportedOperation", "UserError", "abs", "absReal", "acos", "acosh", "all",
 30.2178 -      "and", "any", "appendFile", "asTypeOf", "asciiTab", "asin", "asinh", "atan",
 30.2179 -      "atan2", "atanh", "basicIORun", "blockIO", "boundedEnumFrom", "boundedEnumFromThen",
 30.2180 -      "boundedEnumFromThenTo", "boundedEnumFromTo", "boundedPred", "boundedSucc", "break",
 30.2181 -      "catch", "catchException", "ceiling", "compare", "concat", "concatMap", "const",
 30.2182 -      "cos", "cosh", "curry", "cycle", "decodeFloat", "denominator", "div", "divMod",
 30.2183 -      "doubleToRatio", "doubleToRational", "drop", "dropWhile", "either", "elem",
 30.2184 -      "emptyRec", "encodeFloat", "enumFrom", "enumFromThen", "enumFromThenTo",
 30.2185 -      "enumFromTo", "error", "even", "exp", "exponent", "fail", "filter", "flip",
 30.2186 -      "floatDigits", "floatProperFraction", "floatRadix", "floatRange", "floatToRational",
 30.2187 -      "floor", "fmap", "foldl", "foldl'", "foldl1", "foldr", "foldr1", "fromDouble",
 30.2188 -      "fromEnum", "fromEnum_0", "fromInt", "fromInteger", "fromIntegral", "fromObj",
 30.2189 -      "fromRational", "fst", "gcd", "getChar", "getContents", "getLine", "head",
 30.2190 -      "id", "inRange", "index", "init", "intToRatio", "interact", "ioError", "isAlpha",
 30.2191 -      "isAlphaNum", "isDenormalized", "isDigit", "isHexDigit", "isIEEE", "isInfinite",
 30.2192 -      "isLower", "isNaN", "isNegativeZero", "isOctDigit", "isSpace", "isUpper", "iterate", "iterate'",
 30.2193 -      "last", "lcm", "length", "lex", "lexDigits", "lexLitChar", "lexmatch", "lines", "log",
 30.2194 -      "logBase", "lookup", "loop", "map", "mapM", "mapM_", "max", "maxBound", "maximum",
 30.2195 -      "maybe", "min", "minBound", "minimum", "mod", "negate", "nonnull", "not", "notElem",
 30.2196 -      "null", "numerator", "numericEnumFrom", "numericEnumFromThen", "numericEnumFromThenTo",
 30.2197 -      "numericEnumFromTo", "odd", "or", "otherwise", "pi", "pred", 
 30.2198 -      "print", "product", "properFraction", "protectEsc", "putChar", "putStr", "putStrLn",
 30.2199 -      "quot", "quotRem", "range", "rangeSize", "rationalToDouble", "rationalToFloat",
 30.2200 -      "rationalToRealFloat", "read", "readDec", "readField", "readFieldName", "readFile",
 30.2201 -      "readFloat", "readHex", "readIO", "readInt", "readList", "readLitChar", "readLn",
 30.2202 -      "readOct", "readParen", "readSigned", "reads", "readsPrec", "realFloatToRational",
 30.2203 -      "realToFrac", "recip", "reduce", "rem", "repeat", "replicate", "return", "reverse",
 30.2204 -      "round", "scaleFloat", "scanl", "scanl1", "scanr", "scanr1", "seq", "sequence",
 30.2205 -      "sequence_", "show", "showChar", "showException", "showField", "showList",
 30.2206 -      "showLitChar", "showParen", "showString", "shows", "showsPrec", "significand",
 30.2207 -      "signum", "signumReal", "sin", "sinh", "snd", "span", "splitAt", "sqrt", "subtract",
 30.2208 -      "succ", "sum", "tail", "take", "takeWhile", "takeWhile1", "tan", "tanh", "threadToIOResult",
 30.2209 -      "throw", "toEnum", "toInt", "toInteger", "toObj", "toRational", "truncate", "uncurry",
 30.2210 -      "undefined", "unlines", "unsafeCoerce", "unsafeIndex", "unsafeRangeSize", "until", "unwords",
 30.2211 -      "unzip", "unzip3", "userError", "words", "writeFile", "zip", "zip3", "zipWith", "zipWith3"
 30.2212 -    ] (*due to weird handling of ':', we can't do anything else than to import *all* prelude symbols*)
 30.2213 -
 30.2214 -)
 30.2215 -
 30.2216 -end; (*local*)
 30.2217 -
 30.2218 -end; (*struct*)
    31.1 --- a/src/Pure/Tools/codegen_thingol.ML	Fri Aug 10 17:04:24 2007 +0200
    31.2 +++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
    31.3 @@ -1,442 +0,0 @@
    31.4 -(*  Title:      Pure/Tools/codegen_thingol.ML
    31.5 -    ID:         $Id$
    31.6 -    Author:     Florian Haftmann, TU Muenchen
    31.7 -
    31.8 -Intermediate language ("Thin-gol") representing executable code.
    31.9 -*)
   31.10 -
   31.11 -infix 8 `%%;
   31.12 -infixr 6 `->;
   31.13 -infixr 6 `-->;
   31.14 -infix 4 `$;
   31.15 -infix 4 `$$;
   31.16 -infixr 3 `|->;
   31.17 -infixr 3 `|-->;
   31.18 -
   31.19 -signature BASIC_CODEGEN_THINGOL =
   31.20 -sig
   31.21 -  type vname = string;
   31.22 -  datatype dict =
   31.23 -      DictConst of string * dict list list
   31.24 -    | DictVar of string list * (vname * (int * int));
   31.25 -  datatype itype =
   31.26 -      `%% of string * itype list
   31.27 -    | ITyVar of vname;
   31.28 -  datatype iterm =
   31.29 -      IConst of string * (dict list list * itype list (*types of arguments*))
   31.30 -    | IVar of vname
   31.31 -    | `$ of iterm * iterm
   31.32 -    | `|-> of (vname * itype) * iterm
   31.33 -    | ICase of ((iterm * itype) * (iterm * iterm) list) * iterm;
   31.34 -        (*((term, type), [(selector pattern, body term )]), primitive term)*)
   31.35 -  val `-> : itype * itype -> itype;
   31.36 -  val `--> : itype list * itype -> itype;
   31.37 -  val `$$ : iterm * iterm list -> iterm;
   31.38 -  val `|--> : (vname * itype) list * iterm -> iterm;
   31.39 -  type typscheme = (vname * sort) list * itype;
   31.40 -end;
   31.41 -
   31.42 -signature CODEGEN_THINGOL =
   31.43 -sig
   31.44 -  include BASIC_CODEGEN_THINGOL;
   31.45 -  val unfoldl: ('a -> ('a * 'b) option) -> 'a -> 'a * 'b list;
   31.46 -  val unfoldr: ('a -> ('b * 'a) option) -> 'a -> 'b list * 'a;
   31.47 -  val unfold_fun: itype -> itype list * itype;
   31.48 -  val unfold_app: iterm -> iterm * iterm list;
   31.49 -  val split_abs: iterm -> (((vname * iterm option) * itype) * iterm) option;
   31.50 -  val unfold_abs: iterm -> ((vname * iterm option) * itype) list * iterm;
   31.51 -  val split_let: iterm -> (((iterm * itype) * iterm) * iterm) option;
   31.52 -  val unfold_let: iterm -> ((iterm * itype) * iterm) list * iterm;
   31.53 -  val unfold_const_app: iterm ->
   31.54 -    ((string * (dict list list * itype list)) * iterm list) option;
   31.55 -  val collapse_let: ((vname * itype) * iterm) * iterm
   31.56 -    -> (iterm * itype) * (iterm * iterm) list;
   31.57 -  val eta_expand: (string * (dict list list * itype list)) * iterm list -> int -> iterm;
   31.58 -  val fold_constnames: (string -> 'a -> 'a) -> iterm -> 'a -> 'a;
   31.59 -  val fold_varnames: (string -> 'a -> 'a) -> iterm -> 'a -> 'a;
   31.60 -  val fold_unbound_varnames: (string -> 'a -> 'a) -> iterm -> 'a -> 'a;
   31.61 -
   31.62 -  datatype def =
   31.63 -      Bot
   31.64 -    | Fun of (iterm list * iterm) list * typscheme
   31.65 -    | Datatype of (vname * sort) list * (string * itype list) list
   31.66 -    | Datatypecons of string
   31.67 -    | Class of (class * string) list * (vname * (string * itype) list)
   31.68 -    | Classop of class
   31.69 -    | Classrel of class * class
   31.70 -    | Classinst of (class * (string * (vname * sort) list))
   31.71 -          * ((class * (string * (string * dict list list))) list
   31.72 -        * (string * iterm) list);
   31.73 -  type code = def Graph.T;
   31.74 -  type transact;
   31.75 -  val empty_code: code;
   31.76 -  val merge_code: code * code -> code;
   31.77 -  val project_code: bool (*delete empty funs*)
   31.78 -    -> string list (*hidden*) -> string list option (*selected*)
   31.79 -    -> code -> code;
   31.80 -  val empty_funs: code -> string list;
   31.81 -  val is_cons: code -> string -> bool;
   31.82 -  val add_eval_def: string (*bind name*) * iterm -> code -> code;
   31.83 -
   31.84 -  val ensure_def: (string -> string) -> (transact -> def * code) -> string
   31.85 -    -> string -> transact -> transact;
   31.86 -  val succeed: 'a -> transact -> 'a * code;
   31.87 -  val fail: string -> transact -> 'a * code;
   31.88 -  val message: string -> (transact -> 'a) -> transact -> 'a;
   31.89 -  val start_transact: (transact -> 'a * transact) -> code -> 'a * code;
   31.90 -
   31.91 -  val trace: bool ref;
   31.92 -  val tracing: ('a -> string) -> 'a -> 'a;
   31.93 -end;
   31.94 -
   31.95 -structure CodegenThingol: CODEGEN_THINGOL =
   31.96 -struct
   31.97 -
   31.98 -(** auxiliary **)
   31.99 -
  31.100 -val trace = ref false;
  31.101 -fun tracing f x = (if !trace then Output.tracing (f x) else (); x);
  31.102 -
  31.103 -fun unfoldl dest x =
  31.104 -  case dest x
  31.105 -   of NONE => (x, [])
  31.106 -    | SOME (x1, x2) =>
  31.107 -        let val (x', xs') = unfoldl dest x1 in (x', xs' @ [x2]) end;
  31.108 -
  31.109 -fun unfoldr dest x =
  31.110 -  case dest x
  31.111 -   of NONE => ([], x)
  31.112 -    | SOME (x1, x2) =>
  31.113 -        let val (xs', x') = unfoldr dest x2 in (x1::xs', x') end;
  31.114 -
  31.115 -
  31.116 -(** language core - types, pattern, expressions **)
  31.117 -
  31.118 -(* language representation *)
  31.119 -
  31.120 -type vname = string;
  31.121 -
  31.122 -datatype dict =
  31.123 -    DictConst of string * dict list list
  31.124 -  | DictVar of string list * (vname * (int * int));
  31.125 -
  31.126 -datatype itype =
  31.127 -    `%% of string * itype list
  31.128 -  | ITyVar of vname;
  31.129 -
  31.130 -datatype iterm =
  31.131 -    IConst of string * (dict list list * itype list)
  31.132 -  | IVar of vname
  31.133 -  | `$ of iterm * iterm
  31.134 -  | `|-> of (vname * itype) * iterm
  31.135 -  | ICase of ((iterm * itype) * (iterm * iterm) list) * iterm;
  31.136 -    (*see also signature*)
  31.137 -
  31.138 -(*
  31.139 -  variable naming conventions
  31.140 -
  31.141 -  bare names:
  31.142 -    variable names          v
  31.143 -    class names             class
  31.144 -    type constructor names  tyco
  31.145 -    datatype names          dtco
  31.146 -    const names (general)   c
  31.147 -    constructor names       co
  31.148 -    class operation names   clsop (op)
  31.149 -    arbitrary name          s
  31.150 -
  31.151 -    v, c, co, clsop also annotated with types etc.
  31.152 -
  31.153 -  constructs:
  31.154 -    sort                    sort
  31.155 -    type parameters         vs
  31.156 -    type                    ty
  31.157 -    type schemes            tysm
  31.158 -    term                    t
  31.159 -    (term as pattern)       p
  31.160 -    instance (class, tyco)  inst
  31.161 - *)
  31.162 -
  31.163 -fun ty1 `-> ty2 = "fun" `%% [ty1, ty2];
  31.164 -val op `--> = Library.foldr (op `->);
  31.165 -val op `$$ = Library.foldl (op `$);
  31.166 -val op `|--> = Library.foldr (op `|->);
  31.167 -
  31.168 -val unfold_fun = unfoldr
  31.169 -  (fn "fun" `%% [ty1, ty2] => SOME (ty1, ty2)
  31.170 -    | _ => NONE);
  31.171 -
  31.172 -val unfold_app = unfoldl
  31.173 -  (fn op `$ t => SOME t
  31.174 -    | _ => NONE);
  31.175 -
  31.176 -val split_abs =
  31.177 -  (fn (v, ty) `|-> (t as ICase (((IVar w, _), [(p, t')]), _)) =>
  31.178 -        if v = w then SOME (((v, SOME p), ty), t') else SOME (((v, NONE), ty), t)
  31.179 -    | (v, ty) `|-> t => SOME (((v, NONE), ty), t)
  31.180 -    | _ => NONE);
  31.181 -
  31.182 -val unfold_abs = unfoldr split_abs;
  31.183 -
  31.184 -val split_let = 
  31.185 -  (fn ICase (((td, ty), [(p, t)]), _) => SOME (((p, ty), td), t)
  31.186 -    | _ => NONE);
  31.187 -
  31.188 -val unfold_let = unfoldr split_let;
  31.189 -
  31.190 -fun unfold_const_app t =
  31.191 - case unfold_app t
  31.192 -  of (IConst c, ts) => SOME (c, ts)
  31.193 -   | _ => NONE;
  31.194 -
  31.195 -fun fold_aiterms f (t as IConst _) = f t
  31.196 -  | fold_aiterms f (t as IVar _) = f t
  31.197 -  | fold_aiterms f (t1 `$ t2) = fold_aiterms f t1 #> fold_aiterms f t2
  31.198 -  | fold_aiterms f (t as _ `|-> t') = f t #> fold_aiterms f t'
  31.199 -  | fold_aiterms f (ICase (_, t)) = fold_aiterms f t;
  31.200 -
  31.201 -fun fold_constnames f =
  31.202 -  let
  31.203 -    fun add (IConst (c, _)) = f c
  31.204 -      | add _ = I;
  31.205 -  in fold_aiterms add end;
  31.206 -
  31.207 -fun fold_varnames f =
  31.208 -  let
  31.209 -    fun add (IVar v) = f v
  31.210 -      | add ((v, _) `|-> _) = f v
  31.211 -      | add _ = I;
  31.212 -  in fold_aiterms add end;
  31.213 -
  31.214 -fun fold_unbound_varnames f =
  31.215 -  let
  31.216 -    fun add _ (IConst _) = I
  31.217 -      | add vs (IVar v) = if not (member (op =) vs v) then f v else I
  31.218 -      | add vs (t1 `$ t2) = add vs t1 #> add vs t2
  31.219 -      | add vs ((v, _) `|-> t) = add (insert (op =) v vs) t
  31.220 -      | add vs (ICase (_, t)) = add vs t;
  31.221 -  in add [] end;
  31.222 -
  31.223 -fun collapse_let (((v, ty), se), be as ICase (((IVar w, _), ds), _)) =
  31.224 -      let
  31.225 -        fun exists_v t = fold_unbound_varnames (fn w => fn b =>
  31.226 -          b orelse v = w) t false;
  31.227 -      in if v = w andalso forall (fn (t1, t2) =>
  31.228 -        exists_v t1 orelse not (exists_v t2)) ds
  31.229 -        then ((se, ty), ds)
  31.230 -        else ((se, ty), [(IVar v, be)])
  31.231 -      end
  31.232 -  | collapse_let (((v, ty), se), be) =
  31.233 -      ((se, ty), [(IVar v, be)])
  31.234 -
  31.235 -fun eta_expand (c as (_, (_, tys)), ts) k =
  31.236 -  let
  31.237 -    val j = length ts;
  31.238 -    val l = k - j;
  31.239 -    val ctxt = (fold o fold_varnames) Name.declare ts Name.context;
  31.240 -    val vs_tys = Name.names ctxt "a" ((curry Library.take l o curry Library.drop j) tys);
  31.241 -  in vs_tys `|--> IConst c `$$ ts @ map (fn (v, _) => IVar v) vs_tys end;
  31.242 -
  31.243 -
  31.244 -(** definitions, transactions **)
  31.245 -
  31.246 -(* type definitions *)
  31.247 -
  31.248 -type typscheme = (vname * sort) list * itype;
  31.249 -datatype def =
  31.250 -    Bot
  31.251 -  | Fun of (iterm list * iterm) list * typscheme
  31.252 -  | Datatype of (vname * sort) list * (string * itype list) list
  31.253 -  | Datatypecons of string
  31.254 -  | Class of (class * string) list * (vname * (string * itype) list)
  31.255 -  | Classop of class
  31.256 -  | Classrel of class * class
  31.257 -  | Classinst of (class * (string * (vname * sort) list))
  31.258 -        * ((class * (string * (string * dict list list))) list
  31.259 -      * (string * iterm) list);
  31.260 -
  31.261 -type code = def Graph.T;
  31.262 -type transact = Graph.key option * code;
  31.263 -exception FAIL of string list;
  31.264 -
  31.265 -
  31.266 -(* abstract code *)
  31.267 -
  31.268 -val empty_code = Graph.empty : code; (*read: "depends on"*)
  31.269 -
  31.270 -fun ensure_bot name = Graph.default_node (name, Bot);
  31.271 -
  31.272 -fun add_def_incr (name, Bot) code =
  31.273 -      (case the_default Bot (try (Graph.get_node code) name)
  31.274 -       of Bot => error "Attempted to add Bot to code"
  31.275 -        | _ => code)
  31.276 -  | add_def_incr (name, def) code =
  31.277 -      (case try (Graph.get_node code) name
  31.278 -       of NONE => Graph.new_node (name, def) code
  31.279 -        | SOME Bot => Graph.map_node name (K def) code
  31.280 -        | SOME _ => error ("Tried to overwrite definition " ^ quote name));
  31.281 -
  31.282 -fun add_dep (dep as (name1, name2)) =
  31.283 -  if name1 = name2 then I else Graph.add_edge dep;
  31.284 -
  31.285 -val merge_code : code * code -> code = Graph.merge (K true);
  31.286 -
  31.287 -fun project_code delete_empty_funs hidden raw_selected code =
  31.288 -  let
  31.289 -    fun is_empty_fun name = case Graph.get_node code name
  31.290 -     of Fun ([], _) => true
  31.291 -      | _ => false;
  31.292 -    val names = subtract (op =) hidden (Graph.keys code);
  31.293 -    val deleted = Graph.all_preds code (filter is_empty_fun names);
  31.294 -    val selected = case raw_selected
  31.295 -     of NONE => names |> subtract (op =) deleted 
  31.296 -      | SOME sel => sel
  31.297 -          |> delete_empty_funs ? subtract (op =) deleted
  31.298 -          |> subtract (op =) hidden
  31.299 -          |> Graph.all_succs code
  31.300 -          |> delete_empty_funs ? subtract (op =) deleted
  31.301 -          |> subtract (op =) hidden;
  31.302 -  in
  31.303 -    code
  31.304 -    |> Graph.subgraph (member (op =) selected)
  31.305 -  end;
  31.306 -
  31.307 -fun empty_funs code =
  31.308 -  Graph.fold (fn (name, (Fun ([], _), _)) => cons name
  31.309 -               | _ => I) code [];
  31.310 -
  31.311 -fun is_cons code name = case Graph.get_node code name
  31.312 - of Datatypecons _ => true
  31.313 -  | _ => false;
  31.314 -
  31.315 -fun check_samemodule names =
  31.316 -  fold (fn name =>
  31.317 -    let
  31.318 -      val module_name = (NameSpace.qualifier o NameSpace.qualifier) name
  31.319 -    in
  31.320 -     fn NONE => SOME module_name
  31.321 -      | SOME module_name' => if module_name = module_name' then SOME module_name
  31.322 -          else error ("Inconsistent name prefix for simultanous names: " ^ commas_quote names)
  31.323 -    end
  31.324 -  ) names NONE;
  31.325 -
  31.326 -fun check_funeqs eqs =
  31.327 -  (fold (fn (pats, _) =>
  31.328 -    let
  31.329 -      val l = length pats
  31.330 -    in
  31.331 -     fn NONE => SOME l
  31.332 -      | SOME l' => if l = l' then SOME l
  31.333 -          else error "Function definition with different number of arguments"
  31.334 -    end
  31.335 -  ) eqs NONE; eqs);
  31.336 -
  31.337 -fun check_prep_def code Bot =
  31.338 -      Bot
  31.339 -  | check_prep_def code (Fun (eqs, d)) =
  31.340 -      Fun (check_funeqs eqs, d)
  31.341 -  | check_prep_def code (d as Datatype _) =
  31.342 -      d
  31.343 -  | check_prep_def code (Datatypecons dtco) =
  31.344 -      error "Attempted to add bare term constructor"
  31.345 -  | check_prep_def code (d as Class _) =
  31.346 -      d
  31.347 -  | check_prep_def code (Classop _) =
  31.348 -      error "Attempted to add bare class operation"
  31.349 -  | check_prep_def code (Classrel _) =
  31.350 -      error "Attempted to add bare class relation"
  31.351 -  | check_prep_def code (d as Classinst ((class, (tyco, arity)), (_, inst_classops))) =
  31.352 -      let
  31.353 -        val Class (_, (_, classops)) = Graph.get_node code class;
  31.354 -        val _ = if length inst_classops > length classops
  31.355 -          then error "Too many class operations given"
  31.356 -          else ();
  31.357 -        fun check_classop (f, _) =
  31.358 -          if AList.defined (op =) inst_classops f
  31.359 -          then () else error ("Missing definition for class operation " ^ quote f);
  31.360 -        val _ = map check_classop classops;
  31.361 -      in d end;
  31.362 -
  31.363 -fun postprocess_def (name, Datatype (_, constrs)) =
  31.364 -      tap (fn _ => check_samemodule (name :: map fst constrs))
  31.365 -      #> fold (fn (co, _) =>
  31.366 -        add_def_incr (co, Datatypecons name)
  31.367 -        #> add_dep (co, name)
  31.368 -        #> add_dep (name, co)
  31.369 -      ) constrs
  31.370 -  | postprocess_def (name, Class (classrels, (_, classops))) =
  31.371 -      tap (fn _ => check_samemodule (name :: map fst classops @ map snd classrels))
  31.372 -      #> fold (fn (f, _) =>
  31.373 -        add_def_incr (f, Classop name)
  31.374 -        #> add_dep (f, name)
  31.375 -        #> add_dep (name, f)
  31.376 -      ) classops
  31.377 -      #> fold (fn (superclass, classrel) =>
  31.378 -        add_def_incr (classrel, Classrel (name, superclass))
  31.379 -        #> add_dep (classrel, name)
  31.380 -        #> add_dep (name, classrel)
  31.381 -      ) classrels
  31.382 -  | postprocess_def _ =
  31.383 -      I;
  31.384 -
  31.385 -
  31.386 -(* transaction protocol *)
  31.387 -
  31.388 -fun ensure_def labelled_name defgen msg name (dep, code) =
  31.389 -  let
  31.390 -    val msg' = (case dep
  31.391 -     of NONE => msg
  31.392 -      | SOME dep => msg ^ ", required for " ^ labelled_name dep);
  31.393 -    fun add_dp NONE = I
  31.394 -      | add_dp (SOME dep) =
  31.395 -          tracing (fn _ => "adding dependency " ^ labelled_name dep
  31.396 -            ^ " -> " ^ labelled_name name)
  31.397 -          #> add_dep (dep, name);
  31.398 -    fun prep_def def code =
  31.399 -      (check_prep_def code def, code);
  31.400 -    fun invoke_generator name defgen code =
  31.401 -      defgen (SOME name, code) handle FAIL msgs => raise FAIL (msg' :: msgs);
  31.402 -    fun add_def false =
  31.403 -          ensure_bot name
  31.404 -          #> add_dp dep
  31.405 -          #> invoke_generator name defgen
  31.406 -          #-> (fn def => prep_def def)
  31.407 -          #-> (fn def => add_def_incr (name, def)
  31.408 -          #> postprocess_def (name, def))
  31.409 -      | add_def true =
  31.410 -          add_dp dep;
  31.411 -  in
  31.412 -    code
  31.413 -    |> add_def (can (Graph.get_node code) name)
  31.414 -    |> pair dep
  31.415 -  end;
  31.416 -
  31.417 -fun succeed some (_, code) = (some, code);
  31.418 -
  31.419 -fun fail msg (_, code) = raise FAIL [msg];
  31.420 -
  31.421 -fun message msg f trns =
  31.422 -  f trns handle FAIL msgs =>
  31.423 -    raise FAIL (msg :: msgs);
  31.424 -
  31.425 -fun start_transact f code =
  31.426 -  let
  31.427 -    fun handle_fail f x =
  31.428 -      (f x
  31.429 -      handle FAIL msgs =>
  31.430 -        (error o cat_lines) ("Code generation failed, while:" :: msgs))
  31.431 -  in
  31.432 -    (NONE, code)
  31.433 -    |> handle_fail f
  31.434 -    |-> (fn x => fn (_, code) => (x, code))
  31.435 -  end;
  31.436 -
  31.437 -fun add_eval_def (name, t) code =
  31.438 -  code
  31.439 -  |> Graph.new_node (name, Fun ([([], t)], ([("_", [])], ITyVar "_")))
  31.440 -  |> fold (curry Graph.add_edge name) (Graph.keys code);
  31.441 -
  31.442 -end; (*struct*)
  31.443 -
  31.444 -
  31.445 -structure BasicCodegenThingol: BASIC_CODEGEN_THINGOL = CodegenThingol;
    32.1 --- a/src/Pure/Tools/nbe.ML	Fri Aug 10 17:04:24 2007 +0200
    32.2 +++ b/src/Pure/Tools/nbe.ML	Fri Aug 10 17:04:34 2007 +0200
    32.3 @@ -65,7 +65,7 @@
    32.4  
    32.5  (* theorem store *)
    32.6  
    32.7 -structure Funcgr = CodegenFuncgrRetrieval (val rewrites = the_pres);
    32.8 +structure Funcgr = CodeFuncgrRetrieval (val rewrites = the_pres);
    32.9  
   32.10  (* code store *)
   32.11  
   32.12 @@ -110,14 +110,14 @@
   32.13  fun ensure_funs thy funcgr t =
   32.14    let
   32.15      fun consts_of thy t =
   32.16 -      fold_aterms (fn Const c => cons (CodegenConsts.const_of_cexpr thy c) | _ => I) t []
   32.17 +      fold_aterms (fn Const c => cons (CodeUnit.const_of_cexpr thy c) | _ => I) t []
   32.18      val consts = consts_of thy t;
   32.19      val nbe_tab = NBE_Data.get thy;
   32.20    in
   32.21 -    CodegenFuncgr.deps funcgr consts
   32.22 -    |> (map o filter_out) (Symtab.defined nbe_tab o CodegenNames.const thy)
   32.23 +    CodeFuncgr.deps funcgr consts
   32.24 +    |> (map o filter_out) (Symtab.defined nbe_tab o CodeNames.const thy)
   32.25      |> filter_out null
   32.26 -    |> (map o map) (fn c => (CodegenNames.const thy c, CodegenFuncgr.funcs funcgr c))
   32.27 +    |> (map o map) (fn c => (CodeNames.const thy c, CodeFuncgr.funcs funcgr c))
   32.28      |> generate thy
   32.29    end;
   32.30  
   32.31 @@ -156,7 +156,7 @@
   32.32  
   32.33  (* evaluation oracle *)
   32.34  
   32.35 -exception Normalization of CodegenFuncgr.T * term;
   32.36 +exception Normalization of CodeFuncgr.T * term;
   32.37  
   32.38  fun normalization_oracle (thy, Normalization (funcgr, t)) =
   32.39    Logic.mk_equals (t, eval_term thy funcgr t);
    33.1 --- a/src/Pure/Tools/nbe_codegen.ML	Fri Aug 10 17:04:24 2007 +0200
    33.2 +++ b/src/Pure/Tools/nbe_codegen.ML	Fri Aug 10 17:04:34 2007 +0200
    33.3 @@ -149,7 +149,7 @@
    33.4    let
    33.5      fun to_term bounds (C s) tcount =
    33.6            let
    33.7 -            val SOME (const as (c, _)) = CodegenNames.const_rev thy s;
    33.8 +            val SOME (const as (c, _)) = CodeNames.const_rev thy s;
    33.9              val ty = CodegenData.default_typ thy const;
   33.10              val ty' = map_type_tvar (fn ((s,i),S) => TypeInfer.param (tcount + i) (s,S)) ty;
   33.11              val tcount' = tcount + maxidx_of_typ ty + 1;
    34.1 --- a/src/Pure/Tools/nbe_eval.ML	Fri Aug 10 17:04:24 2007 +0200
    34.2 +++ b/src/Pure/Tools/nbe_eval.ML	Fri Aug 10 17:04:34 2007 +0200
    34.3 @@ -107,8 +107,8 @@
    34.4  
    34.5  (* ------------------ evaluation with greetings to Tarski ------------------ *)
    34.6  
    34.7 -fun prep_term thy (Const c) = Const (CodegenNames.const thy
    34.8 -      (CodegenConsts.const_of_cexpr thy c), dummyT)
    34.9 +fun prep_term thy (Const c) = Const (CodeNames.const thy
   34.10 +      (CodeUnit.const_of_cexpr thy c), dummyT)
   34.11    | prep_term thy (Free v_ty) = Free v_ty
   34.12    | prep_term thy (s $ t) = prep_term thy s $ prep_term thy t
   34.13    | prep_term thy (Abs (raw_v, ty, raw_t)) =
    35.1 --- a/src/Pure/codegen.ML	Fri Aug 10 17:04:24 2007 +0200
    35.2 +++ b/src/Pure/codegen.ML	Fri Aug 10 17:04:34 2007 +0200
    35.3 @@ -26,7 +26,6 @@
    35.4  
    35.5    val add_codegen: string -> term codegen -> theory -> theory
    35.6    val add_tycodegen: string -> typ codegen -> theory -> theory
    35.7 -  val add_attribute: string -> (Args.T list -> attribute * Args.T list) -> theory -> theory
    35.8    val add_preprocessor: (theory -> thm list -> thm list) -> theory -> theory
    35.9    val preprocess: theory -> thm list -> thm list
   35.10    val preprocess_term: theory -> term -> term
   35.11 @@ -202,8 +201,6 @@
   35.12  
   35.13  (* theory data *)
   35.14  
   35.15 -structure CodeData = CodegenData;
   35.16 -
   35.17  structure CodegenData = TheoryDataFun
   35.18  (
   35.19    type T =
   35.20 @@ -211,29 +208,27 @@
   35.21       tycodegens : (string * typ codegen) list,
   35.22       consts : ((string * typ) * (term mixfix list * (string * string) list)) list,
   35.23       types : (string * (typ mixfix list * (string * string) list)) list,
   35.24 -     attrs: (string * (Args.T list -> attribute * Args.T list)) list,
   35.25       preprocs: (stamp * (theory -> thm list -> thm list)) list,
   35.26       modules: codegr Symtab.table,
   35.27       test_params: test_params};
   35.28  
   35.29    val empty =
   35.30 -    {codegens = [], tycodegens = [], consts = [], types = [], attrs = [],
   35.31 +    {codegens = [], tycodegens = [], consts = [], types = [],
   35.32       preprocs = [], modules = Symtab.empty, test_params = default_test_params};
   35.33    val copy = I;
   35.34    val extend = I;
   35.35  
   35.36    fun merge _
   35.37      ({codegens = codegens1, tycodegens = tycodegens1,
   35.38 -      consts = consts1, types = types1, attrs = attrs1,
   35.39 +      consts = consts1, types = types1,
   35.40        preprocs = preprocs1, modules = modules1, test_params = test_params1},
   35.41       {codegens = codegens2, tycodegens = tycodegens2,
   35.42 -      consts = consts2, types = types2, attrs = attrs2,
   35.43 +      consts = consts2, types = types2,
   35.44        preprocs = preprocs2, modules = modules2, test_params = test_params2}) =
   35.45      {codegens = AList.merge (op =) (K true) (codegens1, codegens2),
   35.46       tycodegens = AList.merge (op =) (K true) (tycodegens1, tycodegens2),
   35.47       consts = AList.merge (op =) (K true) (consts1, consts2),
   35.48       types = AList.merge (op =) (K true) (types1, types2),
   35.49 -     attrs = AList.merge (op =) (K true) (attrs1, attrs2),
   35.50       preprocs = AList.merge (op =) (K true) (preprocs1, preprocs2),
   35.51       modules = Symtab.merge (K true) (modules1, modules2),
   35.52       test_params = merge_test_params test_params1 test_params2};
   35.53 @@ -253,10 +248,10 @@
   35.54  fun get_test_params thy = #test_params (CodegenData.get thy);
   35.55  
   35.56  fun map_test_params f thy =
   35.57 -  let val {codegens, tycodegens, consts, types, attrs, preprocs, modules, test_params} =
   35.58 +  let val {codegens, tycodegens, consts, types, preprocs, modules, test_params} =
   35.59      CodegenData.get thy;
   35.60    in CodegenData.put {codegens = codegens, tycodegens = tycodegens,
   35.61 -    consts = consts, types = types, attrs = attrs, preprocs = preprocs,
   35.62 +    consts = consts, types = types, preprocs = preprocs,
   35.63      modules = modules, test_params = f test_params} thy
   35.64    end;
   35.65  
   35.66 @@ -266,10 +261,10 @@
   35.67  fun get_modules thy = #modules (CodegenData.get thy);
   35.68  
   35.69  fun map_modules f thy =
   35.70 -  let val {codegens, tycodegens, consts, types, attrs, preprocs, modules, test_params} =
   35.71 +  let val {codegens, tycodegens, consts, types, preprocs, modules, test_params} =
   35.72      CodegenData.get thy;
   35.73    in CodegenData.put {codegens = codegens, tycodegens = tycodegens,
   35.74 -    consts = consts, types = types, attrs = attrs, preprocs = preprocs,
   35.75 +    consts = consts, types = types, preprocs = preprocs,
   35.76      modules = f modules, test_params = test_params} thy
   35.77    end;
   35.78  
   35.79 @@ -277,23 +272,23 @@
   35.80  (**** add new code generators to theory ****)
   35.81  
   35.82  fun add_codegen name f thy =
   35.83 -  let val {codegens, tycodegens, consts, types, attrs, preprocs, modules, test_params} =
   35.84 +  let val {codegens, tycodegens, consts, types, preprocs, modules, test_params} =
   35.85      CodegenData.get thy
   35.86    in (case AList.lookup (op =) codegens name of
   35.87        NONE => CodegenData.put {codegens = (name, f) :: codegens,
   35.88          tycodegens = tycodegens, consts = consts, types = types,
   35.89 -        attrs = attrs, preprocs = preprocs, modules = modules,
   35.90 +        preprocs = preprocs, modules = modules,
   35.91          test_params = test_params} thy
   35.92      | SOME _ => error ("Code generator " ^ name ^ " already declared"))
   35.93    end;
   35.94  
   35.95  fun add_tycodegen name f thy =
   35.96 -  let val {codegens, tycodegens, consts, types, attrs, preprocs, modules, test_params} =
   35.97 +  let val {codegens, tycodegens, consts, types, preprocs, modules, test_params} =
   35.98      CodegenData.get thy
   35.99    in (case ALi