src/HOLCF/Tools/cont_proc.ML
changeset 40327 1dfdbd66093a
parent 40326 73d45866dbda
equal deleted inserted replaced
40326:73d45866dbda 40327:1dfdbd66093a
    19 
    19 
    20 val cont_K = @{thm cont_const};
    20 val cont_K = @{thm cont_const};
    21 val cont_I = @{thm cont_id};
    21 val cont_I = @{thm cont_id};
    22 val cont_A = @{thm cont2cont_APP};
    22 val cont_A = @{thm cont2cont_APP};
    23 val cont_L = @{thm cont2cont_LAM};
    23 val cont_L = @{thm cont2cont_LAM};
    24 val cont_R = @{thm cont_Rep_CFun2};
    24 val cont_R = @{thm cont_Rep_cfun2};
    25 
    25 
    26 (* checks whether a term contains no dangling bound variables *)
    26 (* checks whether a term contains no dangling bound variables *)
    27 fun is_closed_term t = not (Term.loose_bvar (t, 0));
    27 fun is_closed_term t = not (Term.loose_bvar (t, 0));
    28 
    28 
    29 (* checks whether a term is written entirely in the LCF sublanguage *)
    29 (* checks whether a term is written entirely in the LCF sublanguage *)
    30 fun is_lcf_term (Const (@{const_name Rep_CFun}, _) $ t $ u) =
    30 fun is_lcf_term (Const (@{const_name Rep_cfun}, _) $ t $ u) =
    31       is_lcf_term t andalso is_lcf_term u
    31       is_lcf_term t andalso is_lcf_term u
    32   | is_lcf_term (Const (@{const_name Abs_CFun}, _) $ Abs (_, _, t)) =
    32   | is_lcf_term (Const (@{const_name Abs_cfun}, _) $ Abs (_, _, t)) =
    33       is_lcf_term t
    33       is_lcf_term t
    34   | is_lcf_term (Const (@{const_name Abs_CFun}, _) $ t) =
    34   | is_lcf_term (Const (@{const_name Abs_cfun}, _) $ t) =
    35       is_lcf_term (Term.incr_boundvars 1 t $ Bound 0)
    35       is_lcf_term (Term.incr_boundvars 1 t $ Bound 0)
    36   | is_lcf_term (Bound _) = true
    36   | is_lcf_term (Bound _) = true
    37   | is_lcf_term t = is_closed_term t;
    37   | is_lcf_term t = is_closed_term t;
    38 
    38 
    39 (*
    39 (*
    65     in (map (fn y => SOME (k y RS Lx)) ys, x') end;
    65     in (map (fn y => SOME (k y RS Lx)) ys, x') end;
    66 
    66 
    67   (* first list: cont thm for each dangling bound variable *)
    67   (* first list: cont thm for each dangling bound variable *)
    68   (* second list: cont thm for each LAM in t *)
    68   (* second list: cont thm for each LAM in t *)
    69   (* if b = false, only return cont thm for outermost LAMs *)
    69   (* if b = false, only return cont thm for outermost LAMs *)
    70   fun cont_thms1 b (Const (@{const_name Rep_CFun}, _) $ f $ t) =
    70   fun cont_thms1 b (Const (@{const_name Rep_cfun}, _) $ f $ t) =
    71     let
    71     let
    72       val (cs1,ls1) = cont_thms1 b f;
    72       val (cs1,ls1) = cont_thms1 b f;
    73       val (cs2,ls2) = cont_thms1 b t;
    73       val (cs2,ls2) = cont_thms1 b t;
    74     in (zip cs1 cs2, if b then ls1 @ ls2 else []) end
    74     in (zip cs1 cs2, if b then ls1 @ ls2 else []) end
    75     | cont_thms1 b (Const (@{const_name Abs_CFun}, _) $ Abs (_, _, t)) =
    75     | cont_thms1 b (Const (@{const_name Abs_cfun}, _) $ Abs (_, _, t)) =
    76     let
    76     let
    77       val (cs, ls) = cont_thms1 b t;
    77       val (cs, ls) = cont_thms1 b t;
    78       val (cs', l) = lam cs;
    78       val (cs', l) = lam cs;
    79     in (cs', l::ls) end
    79     in (cs', l::ls) end
    80     | cont_thms1 b (Const (@{const_name Abs_CFun}, _) $ t) =
    80     | cont_thms1 b (Const (@{const_name Abs_cfun}, _) $ t) =
    81     let
    81     let
    82       val t' = Term.incr_boundvars 1 t $ Bound 0;
    82       val t' = Term.incr_boundvars 1 t $ Bound 0;
    83       val (cs, ls) = cont_thms1 b t';
    83       val (cs, ls) = cont_thms1 b t';
    84       val (cs', l) = lam cs;
    84       val (cs', l) = lam cs;
    85     in (cs', l::ls) end
    85     in (cs', l::ls) end
   107         [] => no_tac
   107         [] => no_tac
   108       | (c::cs) => rtac c i;
   108       | (c::cs) => rtac c i;
   109 
   109 
   110     fun cont_tac_of_term (Const (@{const_name cont}, _) $ f) =
   110     fun cont_tac_of_term (Const (@{const_name cont}, _) $ f) =
   111       let
   111       let
   112         val f' = Const (@{const_name Abs_CFun}, dummyT) $ f;
   112         val f' = Const (@{const_name Abs_cfun}, dummyT) $ f;
   113       in
   113       in
   114         if is_lcf_term f'
   114         if is_lcf_term f'
   115         then new_cont_tac f'
   115         then new_cont_tac f'
   116         else REPEAT_ALL_NEW (resolve_tac rules)
   116         else REPEAT_ALL_NEW (resolve_tac rules)
   117       end
   117       end