wneuper/isa: src/Tools/code/code_thingol.ML@97ebdbdb0299

     1 (*  Title:      Tools/code/code_thingol.ML

     2     ID:         $Id$

     3     Author:     Florian Haftmann, TU Muenchen

     5 Intermediate language ("Thin-gol") representing executable code.

     6 Representation and translation.

     7 *)

     9 infix 8 `%%;

    10 infixr 6 `->;

    11 infixr 6 `-->;

    12 infix 4 `$;

    13 infix 4 `$$;

    14 infixr 3 `|->;

    15 infixr 3 `|-->;

    17 signature BASIC_CODE_THINGOL =

    18 sig

    19   type vname = string;

    20   datatype dict =

    21       DictConst of string * dict list list

    22     | DictVar of string list * (vname * (int * int));

    23   datatype itype =

    24       `%% of string * itype list

    25     | ITyVar of vname;

    26   type const = string * (dict list list * itype list (*types of arguments*))

    27   datatype iterm =

    28       IConst of const

    29     | IVar of vname

    30     | `$ of iterm * iterm

    31     | `|-> of (vname * itype) * iterm

    32     | ICase of ((iterm * itype) * (iterm * iterm) list) * iterm;

    33         (*((term, type), [(selector pattern, body term )]), primitive term)*)

    34   val `-> : itype * itype -> itype;

    35   val `--> : itype list * itype -> itype;

    36   val `$$ : iterm * iterm list -> iterm;

    37   val `|--> : (vname * itype) list * iterm -> iterm;

    38   type typscheme = (vname * sort) list * itype;

    39 end;

    41 signature CODE_THINGOL =

    42 sig

    43   include BASIC_CODE_THINGOL;

    44   val unfoldl: ('a -> ('a * 'b) option) -> 'a -> 'a * 'b list;

    45   val unfoldr: ('a -> ('b * 'a) option) -> 'a -> 'b list * 'a;

    46   val unfold_fun: itype -> itype list * itype;

    47   val unfold_app: iterm -> iterm * iterm list;

    48   val split_abs: iterm -> (((vname * iterm option) * itype) * iterm) option;

    49   val unfold_abs: iterm -> ((vname * iterm option) * itype) list * iterm;

    50   val split_let: iterm -> (((iterm * itype) * iterm) * iterm) option;

    51   val unfold_let: iterm -> ((iterm * itype) * iterm) list * iterm;

    52   val unfold_const_app: iterm ->

    53     ((string * (dict list list * itype list)) * iterm list) option;

    54   val collapse_let: ((vname * itype) * iterm) * iterm

    55     -> (iterm * itype) * (iterm * iterm) list;

    56   val eta_expand: (string * (dict list list * itype list)) * iterm list -> int -> iterm;

    57   val contains_dictvar: iterm -> bool;

    58   val locally_monomorphic: iterm -> bool;

    59   val fold_constnames: (string -> 'a -> 'a) -> iterm -> 'a -> 'a;

    60   val fold_varnames: (string -> 'a -> 'a) -> iterm -> 'a -> 'a;

    61   val fold_unbound_varnames: (string -> 'a -> 'a) -> iterm -> 'a -> 'a;

    63   datatype stmt =

    64       Bot

    65     | Fun of typscheme * ((iterm list * iterm) * thm) list

    66     | Datatype of (vname * sort) list * (string * itype list) list

    67     | Datatypecons of string

    68     | Class of vname * ((class * string) list * (string * itype) list)

    69     | Classrel of class * class

    70     | Classparam of class

    71     | Classinst of (class * (string * (vname * sort) list))

    72           * ((class * (string * (string * dict list list))) list

    73         * ((string * const) * thm) list);

    74   type code = stmt Graph.T;

    75   val empty_code: code;

    76   val merge_code: code * code -> code;

    77   val project_code: bool (*delete empty funs*)

    78     -> string list (*hidden*) -> string list option (*selected*)

    79     -> code -> code;

    80   val empty_funs: code -> string list;

    81   val is_cons: code -> string -> bool;

    82   val contr_classparam_typs: code -> string -> itype option list;

    84   type transact;

    85   val ensure_const: theory -> ((sort -> sort) * Sorts.algebra) * Consts.T

    86     -> CodeFuncgr.T -> string -> transact -> string * transact;

    87   val ensure_value: theory -> ((sort -> sort) * Sorts.algebra) * Consts.T

    88     -> CodeFuncgr.T -> term -> transact -> string * transact;

    89   val add_value_stmt: iterm * itype -> code -> code;

    90   val transact: (transact -> 'a * transact) -> code -> 'a * code;

    91 end;

    93 structure CodeThingol: CODE_THINGOL =

    94 struct

    96 (** auxiliary **)

    98 fun unfoldl dest x =

    99   case dest x

   100    of NONE => (x, [])

   101     | SOME (x1, x2) =>

   102         let val (x', xs') = unfoldl dest x1 in (x', xs' @ [x2]) end;

   104 fun unfoldr dest x =

   105   case dest x

   106    of NONE => ([], x)

   107     | SOME (x1, x2) =>

   108         let val (xs', x') = unfoldr dest x2 in (x1::xs', x') end;

   111 (** language core - types, pattern, expressions **)

   113 (* language representation *)

   115 type vname = string;

   117 datatype dict =

   118     DictConst of string * dict list list

   119   | DictVar of string list * (vname * (int * int));

   121 datatype itype =

   122     `%% of string * itype list

   123   | ITyVar of vname;

   125 type const = string * (dict list list * itype list (*types of arguments*))

   127 datatype iterm =

   128     IConst of const

   129   | IVar of vname

   130   | `$ of iterm * iterm

   131   | `|-> of (vname * itype) * iterm

   132   | ICase of ((iterm * itype) * (iterm * iterm) list) * iterm;

   133     (*see also signature*)

   135 (*

   136   variable naming conventions

   138   bare names:

   139     variable names          v

   140     class names             class

   141     type constructor names  tyco

   142     datatype names          dtco

   143     const names (general)   c (const)

   144     constructor names       co

   145     class parameter names   classparam

   146     arbitrary name          s

   148     v, c, co, classparam also annotated with types etc.

   150   constructs:

   151     sort                    sort

   152     type parameters         vs

   153     type                    ty

   154     type schemes            tysm

   155     term                    t

   156     (term as pattern)       p

   157     instance (class, tyco)  inst

   158  *)

   160 fun ty1 `-> ty2 = "fun" `%% [ty1, ty2];

   161 val op `--> = Library.foldr (op `->);

   162 val op `$$ = Library.foldl (op `$);

   163 val op `|--> = Library.foldr (op `|->);

   165 val unfold_fun = unfoldr

   166   (fn "fun" `%% [ty1, ty2] => SOME (ty1, ty2)

   167     | _ => NONE);

   169 val unfold_app = unfoldl

   170   (fn op `$ t => SOME t

   171     | _ => NONE);

   173 val split_abs =

   174   (fn (v, ty) `|-> (t as ICase (((IVar w, _), [(p, t')]), _)) =>

   175         if v = w then SOME (((v, SOME p), ty), t') else SOME (((v, NONE), ty), t)

   176     | (v, ty) `|-> t => SOME (((v, NONE), ty), t)

   177     | _ => NONE);

   179 val unfold_abs = unfoldr split_abs;

   181 val split_let =

   182   (fn ICase (((td, ty), [(p, t)]), _) => SOME (((p, ty), td), t)

   183     | _ => NONE);

   185 val unfold_let = unfoldr split_let;

   187 fun unfold_const_app t =

   188  case unfold_app t

   189   of (IConst c, ts) => SOME (c, ts)

   190    | _ => NONE;

   192 fun fold_aiterms f (t as IConst _) = f t

   193   | fold_aiterms f (t as IVar _) = f t

   194   | fold_aiterms f (t1 `$ t2) = fold_aiterms f t1 #> fold_aiterms f t2

   195   | fold_aiterms f (t as _ `|-> t') = f t #> fold_aiterms f t'

   196   | fold_aiterms f (ICase (_, t)) = fold_aiterms f t;

   198 fun fold_constnames f =

   199   let

   200     fun add (IConst (c, _)) = f c

   201       | add _ = I;

   202   in fold_aiterms add end;

   204 fun fold_varnames f =

   205   let

   206     fun add (IVar v) = f v

   207       | add ((v, _) `|-> _) = f v

   208       | add _ = I;

   209   in fold_aiterms add end;

   211 fun fold_unbound_varnames f =

   212   let

   213     fun add _ (IConst _) = I

   214       | add vs (IVar v) = if not (member (op =) vs v) then f v else I

   215       | add vs (t1 `$ t2) = add vs t1 #> add vs t2

   216       | add vs ((v, _) `|-> t) = add (insert (op =) v vs) t

   217       | add vs (ICase (_, t)) = add vs t;

   218   in add [] end;

   220 fun collapse_let (((v, ty), se), be as ICase (((IVar w, _), ds), _)) =

   221       let

   222         fun exists_v t = fold_unbound_varnames (fn w => fn b =>

   223           b orelse v = w) t false;

   224       in if v = w andalso forall (fn (t1, t2) =>

   225         exists_v t1 orelse not (exists_v t2)) ds

   226         then ((se, ty), ds)

   227         else ((se, ty), [(IVar v, be)])

   228       end

   229   | collapse_let (((v, ty), se), be) =

   230       ((se, ty), [(IVar v, be)])

   232 fun eta_expand (c as (_, (_, tys)), ts) k =

   233   let

   234     val j = length ts;

   235     val l = k - j;

   236     val ctxt = (fold o fold_varnames) Name.declare ts Name.context;

   237     val vs_tys = Name.names ctxt "a" ((curry Library.take l o curry Library.drop j) tys);

   238   in vs_tys `|--> IConst c `$$ ts @ map (fn (v, _) => IVar v) vs_tys end;

   240 fun contains_dictvar t =

   241   let

   242     fun contains (DictConst (_, dss)) = (fold o fold) contains dss

   243       | contains (DictVar _) = K true;

   244   in

   245     fold_aiterms

   246       (fn IConst (_, (dss, _)) => (fold o fold) contains dss | _ => I) t false

   247   end;

   249 fun locally_monomorphic (IConst _) = false

   250   | locally_monomorphic (IVar _) = true

   251   | locally_monomorphic (t `$ _) = locally_monomorphic t

   252   | locally_monomorphic (_ `|-> t) = locally_monomorphic t

   253   | locally_monomorphic (ICase ((_, ds), _)) = exists (locally_monomorphic o snd) ds;

   257 (** definitions, transactions **)

   259 type typscheme = (vname * sort) list * itype;

   260 datatype stmt =

   261     Bot

   262   | Fun of typscheme * ((iterm list * iterm) * thm) list

   263   | Datatype of (vname * sort) list * (string * itype list) list

   264   | Datatypecons of string

   265   | Class of vname * ((class * string) list * (string * itype) list)

   266   | Classrel of class * class

   267   | Classparam of class

   268   | Classinst of (class * (string * (vname * sort) list))

   269         * ((class * (string * (string * dict list list))) list

   270       * ((string * const) * thm) list);

   272 type code = stmt Graph.T;

   275 (* abstract code *)

   277 val empty_code = Graph.empty : code; (*read: "depends on"*)

   279 fun ensure_bot name = Graph.default_node (name, Bot);

   281 fun add_def_incr (name, Bot) code =

   282       (case the_default Bot (try (Graph.get_node code) name)

   283        of Bot => error "Attempted to add Bot to code"

   284         | _ => code)

   285   | add_def_incr (name, def) code =

   286       (case try (Graph.get_node code) name

   287        of NONE => Graph.new_node (name, def) code

   288         | SOME Bot => Graph.map_node name (K def) code

   289         | SOME _ => error ("Tried to overwrite definition " ^ quote name));

   291 fun add_dep (NONE, _) = I

   292   | add_dep (SOME name1, name2) =

   293       if name1 = name2 then I else Graph.add_edge (name1, name2);

   295 val merge_code : code * code -> code = Graph.merge (K true);

   297 fun project_code delete_empty_funs hidden raw_selected code =

   298   let

   299     fun is_empty_fun name = case Graph.get_node code name

   300      of Fun (_, []) => true

   301       | _ => false;

   302     val names = subtract (op =) hidden (Graph.keys code);

   303     val deleted = Graph.all_preds code (filter is_empty_fun names);

   304     val selected = case raw_selected

   305      of NONE => names |> subtract (op =) deleted

   306       | SOME sel => sel

   307           |> delete_empty_funs ? subtract (op =) deleted

   308           |> subtract (op =) hidden

   309           |> Graph.all_succs code

   310           |> delete_empty_funs ? subtract (op =) deleted

   311           |> subtract (op =) hidden;

   312   in

   313     code

   314     |> Graph.subgraph (member (op =) selected)

   315   end;

   317 fun empty_funs code =

   318   Graph.fold (fn (name, (Fun (_, []), _)) => cons name

   319                | _ => I) code [];

   321 fun is_cons code name = case Graph.get_node code name

   322  of Datatypecons _ => true

   323   | _ => false;

   325 fun contr_classparam_typs code name = case Graph.get_node code name

   326  of Classparam class => let

   327         val Class (_, (_, params)) = Graph.get_node code class;

   328         val SOME ty = AList.lookup (op =) params name;

   329         val (tys, res_ty) = unfold_fun ty;

   330         fun no_tyvar (_ `%% tys) = forall no_tyvar tys

   331           | no_tyvar (ITyVar _) = false;

   332       in if no_tyvar res_ty

   333         then map (fn ty => if no_tyvar ty then NONE else SOME ty) tys

   334         else []

   335       end

   336   | _ => [];

   339 (* transaction protocol *)

   341 type transact = Graph.key option * code;

   343 fun ensure_stmt stmtgen name (dep, code) =

   344   let

   345     fun add_def false =

   346           ensure_bot name

   347           #> add_dep (dep, name)

   348           #> curry stmtgen (SOME name)

   349           ##> snd

   350           #-> (fn def => add_def_incr (name, def))

   351       | add_def true =

   352           add_dep (dep, name);

   353   in

   354     code

   355     |> add_def (can (Graph.get_node code) name)

   356     |> pair dep

   357     |> pair name

   358   end;

   360 fun transact f code =

   361   (NONE, code)

   362   |> f

   363   |-> (fn x => fn (_, code) => (x, code));

   366 (* translation kernel *)

   368 fun ensure_class thy (algbr as ((_, algebra), _)) funcgr class =

   369   let

   370     val superclasses = (Sorts.certify_sort algebra o Sorts.super_classes algebra) class;

   371     val cs = #params (AxClass.get_info thy class);

   372     val class' = CodeName.class thy class;

   373     val stmt_class =

   374       fold_map (fn superclass => ensure_class thy algbr funcgr superclass

   375         ##>> ensure_classrel thy algbr funcgr (class, superclass)) superclasses

   376       ##>> fold_map (fn (c, ty) => ensure_const thy algbr funcgr c

   377         ##>> exprgen_typ thy algbr funcgr ty) cs

   378       #>> (fn info => Class (unprefix "'" Name.aT, info))

   379   in

   380     ensure_stmt stmt_class class'

   381   end

   382 and ensure_classrel thy algbr funcgr (subclass, superclass) =

   383   let

   384     val classrel' = CodeName.classrel thy (subclass, superclass);

   385     val stmt_classrel =

   386       ensure_class thy algbr funcgr subclass

   387       ##>> ensure_class thy algbr funcgr superclass

   388       #>> Classrel;

   389   in

   390     ensure_stmt stmt_classrel classrel'

   391   end

   392 and ensure_tyco thy algbr funcgr "fun" =

   393       pair "fun"

   394   | ensure_tyco thy algbr funcgr tyco =

   395       let

   396         val stmt_datatype =

   397           let

   398             val (vs, cos) = Code.get_datatype thy tyco;

   399           in

   400             fold_map (exprgen_tyvar_sort thy algbr funcgr) vs

   401             ##>> fold_map (fn (c, tys) =>

   402               ensure_const thy algbr funcgr c

   403               ##>> fold_map (exprgen_typ thy algbr funcgr) tys) cos

   404             #>> Datatype

   405           end;

   406         val tyco' = CodeName.tyco thy tyco;

   407       in

   408         ensure_stmt stmt_datatype tyco'

   409       end

   410 and exprgen_tyvar_sort thy (algbr as ((proj_sort, _), _)) funcgr (v, sort) =

   411   fold_map (ensure_class thy algbr funcgr) (proj_sort sort)

   412   #>> (fn sort => (unprefix "'" v, sort))

   413 and exprgen_typ thy algbr funcgr (TFree vs) =

   414       exprgen_tyvar_sort thy algbr funcgr vs

   415       #>> (fn (v, sort) => ITyVar v)

   416   | exprgen_typ thy algbr funcgr (Type (tyco, tys)) =

   417       ensure_tyco thy algbr funcgr tyco

   418       ##>> fold_map (exprgen_typ thy algbr funcgr) tys

   419       #>> (fn (tyco, tys) => tyco `%% tys)

   420 and exprgen_dicts thy (algbr as ((proj_sort, algebra), consts)) funcgr (ty_ctxt, sort_decl) =

   421   let

   422     val pp = Sign.pp thy;

   423     datatype typarg =

   424         Global of (class * string) * typarg list list

   425       | Local of (class * class) list * (string * (int * sort));

   426     fun class_relation (Global ((_, tyco), yss), _) class =

   427           Global ((class, tyco), yss)

   428       | class_relation (Local (classrels, v), subclass) superclass =

   429           Local ((subclass, superclass) :: classrels, v);

   430     fun type_constructor tyco yss class =

   431       Global ((class, tyco), (map o map) fst yss);

   432     fun type_variable (TFree (v, sort)) =

   433       let

   434         val sort' = proj_sort sort;

   435       in map_index (fn (n, class) => (Local ([], (v, (n, sort'))), class)) sort' end;

   436     val typargs = Sorts.of_sort_derivation pp algebra

   437       {class_relation = class_relation, type_constructor = type_constructor,

   438        type_variable = type_variable}

   439       (ty_ctxt, proj_sort sort_decl);

   440     fun mk_dict (Global (inst, yss)) =

   441           ensure_inst thy algbr funcgr inst

   442           ##>> (fold_map o fold_map) mk_dict yss

   443           #>> (fn (inst, dss) => DictConst (inst, dss))

   444       | mk_dict (Local (classrels, (v, (k, sort)))) =

   445           fold_map (ensure_classrel thy algbr funcgr) classrels

   446           #>> (fn classrels => DictVar (classrels, (unprefix "'" v, (k, length sort))))

   447   in

   448     fold_map mk_dict typargs

   449   end

   450 and exprgen_dict_parms thy (algbr as (_, consts)) funcgr (c, ty_ctxt) =

   451   let

   452     val ty_decl = Consts.the_type consts c;

   453     val (tys, tys_decl) = pairself (curry (Consts.typargs consts) c) (ty_ctxt, ty_decl);

   454     val sorts = map (snd o dest_TVar) tys_decl;

   455   in

   456     fold_map (exprgen_dicts thy algbr funcgr) (tys ~~ sorts)

   457   end

   458 and exprgen_eq thy algbr funcgr thm =

   459   let

   460     val (args, rhs) = (apfst (snd o strip_comb) o Logic.dest_equals

   461       o Logic.unvarify o prop_of) thm;

   462   in

   463     fold_map (exprgen_term thy algbr funcgr) args

   464     ##>> exprgen_term thy algbr funcgr rhs

   465     #>> rpair thm

   466   end

   467 and ensure_inst thy (algbr as ((_, algebra), _)) funcgr (class, tyco) =

   468   let

   469     val superclasses = (Sorts.certify_sort algebra o Sorts.super_classes algebra) class;

   470     val classparams = these (try (#params o AxClass.get_info thy) class);

   471     val vs = Name.names Name.context "'a" (Sorts.mg_domain algebra tyco [class]);

   472     val sorts' = Sorts.mg_domain (Sign.classes_of thy) tyco [class];

   473     val vs' = map2 (fn (v, sort1) => fn sort2 => (v,

   474       Sorts.inter_sort (Sign.classes_of thy) (sort1, sort2))) vs sorts';

   475     val arity_typ = Type (tyco, map TFree vs);

   476     val arity_typ' = Type (tyco, map (fn (v, sort) => TVar ((v, 0), sort)) vs');

   477     fun exprgen_superarity superclass =

   478       ensure_class thy algbr funcgr superclass

   479       ##>> ensure_classrel thy algbr funcgr (class, superclass)

   480       ##>> exprgen_dicts thy algbr funcgr (arity_typ, [superclass])

   481       #>> (fn ((superclass, classrel), [DictConst (inst, dss)]) =>

   482             (superclass, (classrel, (inst, dss))));

   483     fun exprgen_classparam_inst (c, ty) =

   484       let

   485         val c_inst = Const (c, map_type_tfree (K arity_typ') ty);

   486         val thm = AxClass.unoverload_conv thy (Thm.cterm_of thy c_inst);

   487         val c_ty = (apsnd Logic.unvarifyT o dest_Const o snd

   488           o Logic.dest_equals o Thm.prop_of) thm;

   489       in

   490         ensure_const thy algbr funcgr c

   491         ##>> exprgen_const thy algbr funcgr c_ty

   492         #>> (fn (c, IConst c_inst) => ((c, c_inst), thm))

   493       end;

   494     val stmt_inst =

   495       ensure_class thy algbr funcgr class

   496       ##>> ensure_tyco thy algbr funcgr tyco

   497       ##>> fold_map (exprgen_tyvar_sort thy algbr funcgr) vs

   498       ##>> fold_map exprgen_superarity superclasses

   499       ##>> fold_map exprgen_classparam_inst classparams

   500       #>> (fn ((((class, tyco), arity), superarities), classparams) =>

   501              Classinst ((class, (tyco, arity)), (superarities, classparams)));

   502     val inst = CodeName.instance thy (class, tyco);

   503   in

   504     ensure_stmt stmt_inst inst

   505   end

   506 and ensure_const thy (algbr as (_, consts)) funcgr c =

   507   let

   508     val c' = CodeName.const thy c;

   509     fun stmt_datatypecons tyco =

   510       ensure_tyco thy algbr funcgr tyco

   511       #>> Datatypecons;

   512     fun stmt_classparam class =

   513       ensure_class thy algbr funcgr class

   514       #>> Classparam;

   515     fun stmt_fun trns =

   516       let

   517         val raw_thms = CodeFuncgr.funcs funcgr c;

   518         val ty = (Logic.unvarifyT o CodeFuncgr.typ funcgr) c;

   519         val vs = (map dest_TFree o Consts.typargs consts) (c, ty);

   520         val thms = if (null o Term.typ_tfrees) ty orelse (null o fst o strip_type) ty

   521           then raw_thms

   522           else map (CodeUnit.expand_eta 1) raw_thms;

   523       in

   524         trns

   525         |> fold_map (exprgen_tyvar_sort thy algbr funcgr) vs

   526         ||>> exprgen_typ thy algbr funcgr ty

   527         ||>> fold_map (exprgen_eq thy algbr funcgr) thms

   528         |>> (fn ((vs, ty), eqs) => Fun ((vs, ty), eqs))

   529       end;

   530     val stmtgen = case Code.get_datatype_of_constr thy c

   531      of SOME tyco => stmt_datatypecons tyco

   532       | NONE => (case AxClass.class_of_param thy c

   533          of SOME class => stmt_classparam class

   534           | NONE => stmt_fun)

   535   in

   536     ensure_stmt stmtgen c'

   537   end

   538 and exprgen_term thy algbr funcgr (Const (c, ty)) =

   539       exprgen_app thy algbr funcgr ((c, ty), [])

   540   | exprgen_term thy algbr funcgr (Free (v, _)) =

   541       pair (IVar v)

   542   | exprgen_term thy algbr funcgr (Abs (abs as (_, ty, _))) =

   543       let

   544         val (v, t) = Syntax.variant_abs abs;

   545       in

   546         exprgen_typ thy algbr funcgr ty

   547         ##>> exprgen_term thy algbr funcgr t

   548         #>> (fn (ty, t) => (v, ty) `|-> t)

   549       end

   550   | exprgen_term thy algbr funcgr (t as _ $ _) =

   551       case strip_comb t

   552        of (Const (c, ty), ts) =>

   553             exprgen_app thy algbr funcgr ((c, ty), ts)

   554         | (t', ts) =>

   555             exprgen_term thy algbr funcgr t'

   556             ##>> fold_map (exprgen_term thy algbr funcgr) ts

   557             #>> (fn (t, ts) => t `$$ ts)

   558 and exprgen_const thy algbr funcgr (c, ty) =

   559   ensure_const thy algbr funcgr c

   560   ##>> exprgen_dict_parms thy algbr funcgr (c, ty)

   561   ##>> fold_map (exprgen_typ thy algbr funcgr) ((fst o Term.strip_type) ty)

   562   #>> (fn ((c, iss), tys) => IConst (c, (iss, tys)))

   563 and exprgen_app_default thy algbr funcgr (c_ty, ts) =

   564   exprgen_const thy algbr funcgr c_ty

   565   ##>> fold_map (exprgen_term thy algbr funcgr) ts

   566   #>> (fn (t, ts) => t `$$ ts)

   567 and exprgen_case thy algbr funcgr n cases (app as ((c, ty), ts)) =

   568   let

   569     val (tys, _) =

   570       (chop (1 + (if null cases then 1 else length cases)) o fst o strip_type) ty;

   571     val dt = nth ts n;

   572     val dty = nth tys n;

   573     fun is_undefined (Const (c, _)) = Code.is_undefined thy c

   574       | is_undefined _ = false;

   575     fun mk_case (co, n) t =

   576       let

   577         val (vs, body) = Term.strip_abs_eta n t;

   578         val selector = list_comb (Const (co, map snd vs ---> dty), map Free vs);

   579       in if is_undefined body then NONE else SOME (selector, body) end;

   580     fun mk_ds [] =

   581           let

   582             val ([v_ty], body) = Term.strip_abs_eta 1 (the_single (nth_drop n ts))

   583           in [(Free v_ty, body)] end

   584       | mk_ds cases = map_filter (uncurry mk_case)

   585           (AList.make (CodeUnit.no_args thy) cases ~~ nth_drop n ts);

   586   in

   587     exprgen_term thy algbr funcgr dt

   588     ##>> exprgen_typ thy algbr funcgr dty

   589     ##>> fold_map (fn (pat, body) => exprgen_term thy algbr funcgr pat

   590           ##>> exprgen_term thy algbr funcgr body) (mk_ds cases)

   591     ##>> exprgen_app_default thy algbr funcgr app

   592     #>> (fn (((dt, dty), ds), t0) => ICase (((dt, dty), ds), t0))

   593   end

   594 and exprgen_app thy algbr funcgr ((c, ty), ts) = case Code.get_case_data thy c

   595  of SOME (n, cases) => let val i = 1 + (if null cases then 1 else length cases) in

   596       if length ts < i then

   597         let

   598           val k = length ts;

   599           val tys = (curry Library.take (i - k) o curry Library.drop k o fst o strip_type) ty;

   600           val ctxt = (fold o fold_aterms)

   601             (fn Free (v, _) => Name.declare v | _ => I) ts Name.context;

   602           val vs = Name.names ctxt "a" tys;

   603         in

   604           fold_map (exprgen_typ thy algbr funcgr) tys

   605           ##>> exprgen_case thy algbr funcgr n cases ((c, ty), ts @ map Free vs)

   606           #>> (fn (tys, t) => map2 (fn (v, _) => pair v) vs tys `|--> t)

   607         end

   608       else if length ts > i then

   609         exprgen_case thy algbr funcgr n cases ((c, ty), Library.take (i, ts))

   610         ##>> fold_map (exprgen_term thy algbr funcgr) (Library.drop (i, ts))

   611         #>> (fn (t, ts) => t `$$ ts)

   612       else

   613         exprgen_case thy algbr funcgr n cases ((c, ty), ts)

   614       end

   615   | NONE => exprgen_app_default thy algbr funcgr ((c, ty), ts);

   617 fun ensure_value thy algbr funcgr t =

   618   let

   619     val ty = fastype_of t;

   620     val vs = fold_term_types (K (fold_atyps (insert (eq_fst op =)

   621       o dest_TFree))) t [];

   622     val stmt_value =

   623       fold_map (exprgen_tyvar_sort thy algbr funcgr) vs

   624       ##>> exprgen_typ thy algbr funcgr ty

   625       ##>> exprgen_term thy algbr funcgr t

   626       #>> (fn ((vs, ty), t) => Fun ((vs, ty), [(([], t), Drule.dummy_thm)]));

   627   in

   628     ensure_stmt stmt_value CodeName.value_name

   629   end;

   631 fun add_value_stmt (t, ty) code =

   632   code

   633   |> Graph.new_node (CodeName.value_name, Fun (([], ty), [(([], t), Drule.dummy_thm)]))

   634   |> fold (curry Graph.add_edge CodeName.value_name) (Graph.keys code);

   636 end; (*struct*)

   639 structure BasicCodeThingol: BASIC_CODE_THINGOL = CodeThingol;

author	haftmann
	Thu, 13 Dec 2007 07:09:09 +0100
changeset 25621	97ebdbdb0299
parent 25597	34860182b250
child 25969	d3f8ab2726ed
permissions	-rw-r--r--