src/HOL/Imperative_HOL/Heap_Monad.thy
changeset 31724 9b5a128cdb5c
parent 31205 98370b26c2ce
child 31871 cc1486840914
equal deleted inserted replaced
31723:f5cafe803b55 31724:9b5a128cdb5c
   316       val dummy_name = "";
   316       val dummy_name = "";
   317       val dummy_type = ITyVar dummy_name;
   317       val dummy_type = ITyVar dummy_name;
   318       val dummy_case_term = IVar dummy_name;
   318       val dummy_case_term = IVar dummy_name;
   319       (*assumption: dummy values are not relevant for serialization*)
   319       (*assumption: dummy values are not relevant for serialization*)
   320       val unitt = IConst (unit', (([], []), []));
   320       val unitt = IConst (unit', (([], []), []));
   321       fun dest_abs ((v, ty) `|-> t, _) = ((v, ty), t)
   321       fun dest_abs ((v, ty) `|=> t, _) = ((v, ty), t)
   322         | dest_abs (t, ty) =
   322         | dest_abs (t, ty) =
   323             let
   323             let
   324               val vs = Code_Thingol.fold_varnames cons t [];
   324               val vs = Code_Thingol.fold_varnames cons t [];
   325               val v = Name.variant vs "x";
   325               val v = Name.variant vs "x";
   326               val ty' = (hd o fst o Code_Thingol.unfold_fun) ty;
   326               val ty' = (hd o fst o Code_Thingol.unfold_fun) ty;
   335       and tr_bind'' t = case Code_Thingol.unfold_app t
   335       and tr_bind'' t = case Code_Thingol.unfold_app t
   336            of (IConst (c, (_, ty1 :: ty2 :: _)), [x1, x2]) => if c = bind'
   336            of (IConst (c, (_, ty1 :: ty2 :: _)), [x1, x2]) => if c = bind'
   337                 then tr_bind' [(x1, ty1), (x2, ty2)]
   337                 then tr_bind' [(x1, ty1), (x2, ty2)]
   338                 else force t
   338                 else force t
   339             | _ => force t;
   339             | _ => force t;
   340     in (dummy_name, dummy_type) `|-> ICase (((IVar dummy_name, dummy_type),
   340     in (dummy_name, dummy_type) `|=> ICase (((IVar dummy_name, dummy_type),
   341       [(unitt, tr_bind' ts)]), dummy_case_term) end
   341       [(unitt, tr_bind' ts)]), dummy_case_term) end
   342   and imp_monad_bind' bind' return' unit' (const as (c, (_, tys))) ts = if c = bind' then case (ts, tys)
   342   and imp_monad_bind' bind' return' unit' (const as (c, (_, tys))) ts = if c = bind' then case (ts, tys)
   343      of ([t1, t2], ty1 :: ty2 :: _) => imp_monad_bind'' bind' return' unit' [(t1, ty1), (t2, ty2)]
   343      of ([t1, t2], ty1 :: ty2 :: _) => imp_monad_bind'' bind' return' unit' [(t1, ty1), (t2, ty2)]
   344       | ([t1, t2, t3], ty1 :: ty2 :: _) => imp_monad_bind'' bind' return' unit' [(t1, ty1), (t2, ty2)] `$ t3
   344       | ([t1, t2, t3], ty1 :: ty2 :: _) => imp_monad_bind'' bind' return' unit' [(t1, ty1), (t2, ty2)] `$ t3
   345       | (ts, _) => imp_monad_bind bind' return' unit' (eta_expand 2 (const, ts))
   345       | (ts, _) => imp_monad_bind bind' return' unit' (eta_expand 2 (const, ts))
   347   and imp_monad_bind bind' return' unit' (IConst const) = imp_monad_bind' bind' return' unit' const []
   347   and imp_monad_bind bind' return' unit' (IConst const) = imp_monad_bind' bind' return' unit' const []
   348     | imp_monad_bind bind' return' unit' (t as IVar _) = t
   348     | imp_monad_bind bind' return' unit' (t as IVar _) = t
   349     | imp_monad_bind bind' return' unit' (t as _ `$ _) = (case unfold_app t
   349     | imp_monad_bind bind' return' unit' (t as _ `$ _) = (case unfold_app t
   350        of (IConst const, ts) => imp_monad_bind' bind' return' unit' const ts
   350        of (IConst const, ts) => imp_monad_bind' bind' return' unit' const ts
   351         | (t, ts) => imp_monad_bind bind' return' unit' t `$$ map (imp_monad_bind bind' return' unit') ts)
   351         | (t, ts) => imp_monad_bind bind' return' unit' t `$$ map (imp_monad_bind bind' return' unit') ts)
   352     | imp_monad_bind bind' return' unit' (v_ty `|-> t) = v_ty `|-> imp_monad_bind bind' return' unit' t
   352     | imp_monad_bind bind' return' unit' (v_ty `|=> t) = v_ty `|=> imp_monad_bind bind' return' unit' t
   353     | imp_monad_bind bind' return' unit' (ICase (((t, ty), pats), t0)) = ICase
   353     | imp_monad_bind bind' return' unit' (ICase (((t, ty), pats), t0)) = ICase
   354         (((imp_monad_bind bind' return' unit' t, ty), (map o pairself) (imp_monad_bind bind' return' unit') pats), imp_monad_bind bind' return' unit' t0);
   354         (((imp_monad_bind bind' return' unit' t, ty), (map o pairself) (imp_monad_bind bind' return' unit') pats), imp_monad_bind bind' return' unit' t0);
   355 
   355 
   356   fun imp_program naming = (Graph.map_nodes o map_terms_stmt)
   356   fun imp_program naming = (Graph.map_nodes o map_terms_stmt)
   357     (imp_monad_bind (lookup naming @{const_name bindM})
   357     (imp_monad_bind (lookup naming @{const_name bindM})