libguile/dynwind.c

   1 /* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2008, 2010, 2011 Free Software Foundation, Inc.
   2  *
   3  * This library is free software; you can redistribute it and/or
   4  * modify it under the terms of the GNU Lesser General Public License
   5  * as published by the Free Software Foundation; either version 3 of
   6  * the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful, but
   9  * WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  16  * 02110-1301 USA
  17  */
  18
  19
  20 \f
  21
  22 #ifdef HAVE_CONFIG_H
  23 # include <config.h>
  24 #endif
  25
  26 #include <assert.h>
  27
  28 #include "libguile/_scm.h"
  29 #include "libguile/control.h"
  30 #include "libguile/eval.h"
  31 #include "libguile/alist.h"
  32 #include "libguile/fluids.h"
  33 #include "libguile/ports.h"
  34 #include "libguile/smob.h"
  35
  36 #include "libguile/dynwind.h"
  37 \f
  38
  39 /* {Dynamic wind}
  40
  41    Things that can be on the wind list:
  42
  43    #<frame>
  44    #<winder>
  45    #<with-fluids>
  46    #<prompt>
  47    (enter-proc . leave-proc)     dynamic-wind
  48
  49 */
  50
  51
  52
  53 SCM
  54 scm_dynamic_wind (SCM in_guard, SCM thunk, SCM out_guard)
  55 #define FUNC_NAME "dynamic-wind"
  56 {
  57   SCM ans, old_winds;
  58   SCM_ASSERT (scm_is_true (scm_thunk_p (out_guard)),
  59               out_guard,
  60               SCM_ARG3, FUNC_NAME);
  61   scm_call_0 (in_guard);
  62   old_winds = scm_i_dynwinds ();
  63   scm_i_set_dynwinds (scm_acons (in_guard, out_guard, old_winds));
  64   ans = scm_call_0 (thunk);
  65   scm_i_set_dynwinds (old_winds);
  66   scm_call_0 (out_guard);
  67   return ans;
  68 }
  69 #undef FUNC_NAME
  70
  71 /* Frames and winders. */
  72
  73 static scm_t_bits tc16_frame;
  74 #define FRAME_P(f)     SCM_SMOB_PREDICATE (tc16_frame, (f))
  75
  76 #define FRAME_F_REWINDABLE    (1 << 0)
  77 #define FRAME_REWINDABLE_P(f) (SCM_SMOB_FLAGS(f) & FRAME_F_REWINDABLE)
  78
  79 static scm_t_bits tc16_winder;
  80 #define WINDER_P(w)     SCM_SMOB_PREDICATE (tc16_winder, (w))
  81 #define WINDER_PROC(w)  ((void (*)(void *))SCM_SMOB_DATA (w))
  82 #define WINDER_DATA(w)  ((void *)SCM_SMOB_DATA_2 (w))
  83
  84 #define WINDER_F_EXPLICIT    (1 << 0)
  85 #define WINDER_F_REWIND      (1 << 1)
  86 #define WINDER_F_MARK        (1 << 2)
  87 #define WINDER_EXPLICIT_P(w) (SCM_SMOB_FLAGS(w) & WINDER_F_EXPLICIT)
  88 #define WINDER_REWIND_P(w)   (SCM_SMOB_FLAGS(w) & WINDER_F_REWIND)
  89 #define WINDER_MARK_P(w)     (SCM_SMOB_FLAGS(w) & WINDER_F_MARK)
  90
  91 void
  92 scm_dynwind_begin (scm_t_dynwind_flags flags)
  93 {
  94   SCM f;
  95   SCM_NEWSMOB (f, tc16_frame, 0);
  96   if (flags & SCM_F_DYNWIND_REWINDABLE)
  97     SCM_SET_SMOB_FLAGS (f, FRAME_F_REWINDABLE);
  98   scm_i_set_dynwinds (scm_cons (f, scm_i_dynwinds ()));
  99 }
 100
 101 void
 102 scm_dynwind_end (void)
 103 {
 104   SCM winds;
 105
 106   /* Unwind upto and including the next frame entry.  We can only
 107      encounter #<winder> entries on the way.
 108    */
 109
 110   winds = scm_i_dynwinds ();
 111   while (scm_is_pair (winds))
 112     {
 113       SCM entry = SCM_CAR (winds);
 114       winds = SCM_CDR (winds);
 115
 116       scm_i_set_dynwinds (winds);
 117
 118       if (FRAME_P (entry))
 119         return;
 120
 121       assert (WINDER_P (entry));
 122       if (!WINDER_REWIND_P (entry) && WINDER_EXPLICIT_P (entry))
 123         WINDER_PROC(entry) (WINDER_DATA (entry));
 124     }
 125
 126   assert (0);
 127 }
 128
 129 void
 130 scm_dynwind_unwind_handler (void (*proc) (void *), void *data,
 131                             scm_t_wind_flags flags)
 132 {
 133   SCM w;
 134   SCM_NEWSMOB2 (w, tc16_winder, (scm_t_bits) proc, (scm_t_bits) data);
 135   if (flags & SCM_F_WIND_EXPLICITLY)
 136     SCM_SET_SMOB_FLAGS (w, WINDER_F_EXPLICIT);
 137   scm_i_set_dynwinds (scm_cons (w, scm_i_dynwinds ()));
 138 }
 139
 140 void
 141 scm_dynwind_rewind_handler (void (*proc) (void *), void *data,
 142                             scm_t_wind_flags flags)
 143 {
 144   SCM w;
 145   SCM_NEWSMOB2 (w, tc16_winder, (scm_t_bits) proc, (scm_t_bits) data);
 146   SCM_SET_SMOB_FLAGS (w, WINDER_F_REWIND);
 147   scm_i_set_dynwinds (scm_cons (w, scm_i_dynwinds ()));
 148   if (flags & SCM_F_WIND_EXPLICITLY)
 149     proc (data);
 150 }
 151
 152 void
 153 scm_dynwind_unwind_handler_with_scm (void (*proc) (SCM), SCM data,
 154                                      scm_t_wind_flags flags)
 155 {
 156   SCM w;
 157   scm_t_bits fl = ((flags&SCM_F_WIND_EXPLICITLY)? WINDER_F_EXPLICIT : 0);
 158   SCM_NEWSMOB2 (w, tc16_winder, (scm_t_bits) proc, SCM_UNPACK (data));
 159   SCM_SET_SMOB_FLAGS (w, fl | WINDER_F_MARK);
 160   scm_i_set_dynwinds (scm_cons (w, scm_i_dynwinds ()));
 161 }
 162
 163 void
 164 scm_dynwind_rewind_handler_with_scm (void (*proc) (SCM), SCM data,
 165                                      scm_t_wind_flags flags)
 166 {
 167   SCM w;
 168   SCM_NEWSMOB2 (w, tc16_winder, (scm_t_bits) proc, SCM_UNPACK (data));
 169   SCM_SET_SMOB_FLAGS (w, WINDER_F_REWIND | WINDER_F_MARK);
 170   scm_i_set_dynwinds (scm_cons (w, scm_i_dynwinds ()));
 171   if (flags & SCM_F_WIND_EXPLICITLY)
 172     proc (data);
 173 }
 174
 175 void
 176 scm_dynwind_free (void *mem)
 177 {
 178   scm_dynwind_unwind_handler (free, mem, SCM_F_WIND_EXPLICITLY);
 179 }
 180
 181 #ifdef GUILE_DEBUG
 182 SCM_DEFINE (scm_wind_chain, "wind-chain", 0, 0, 0,
 183             (),
 184             "Return the current wind chain. The wind chain contains all\n"
 185             "information required by @code{dynamic-wind} to call its\n"
 186             "argument thunks when entering/exiting its scope.")
 187 #define FUNC_NAME s_scm_wind_chain
 188 {
 189   return scm_i_dynwinds ();
 190 }
 191 #undef FUNC_NAME
 192 #endif
 193
 194 void
 195 scm_swap_bindings (SCM vars, SCM vals)
 196 {
 197   SCM tmp;
 198   while (SCM_NIMP (vals))
 199     {
 200       tmp = SCM_VARIABLE_REF (SCM_CAR (vars));
 201       SCM_VARIABLE_SET (SCM_CAR (vars), SCM_CAR (vals));
 202       SCM_SETCAR (vals, tmp);
 203       vars = SCM_CDR (vars);
 204       vals = SCM_CDR (vals);
 205     }
 206 }
 207
 208 void
 209 scm_dowinds (SCM to, long delta)
 210 {
 211   scm_i_dowinds (to, delta, NULL, NULL);
 212 }
 213
 214 void
 215 scm_i_dowinds (SCM to, long delta, void (*turn_func) (void *), void *data)
 216 {
 217  tail:
 218   if (scm_is_eq (to, scm_i_dynwinds ()))
 219     {
 220       if (turn_func)
 221         turn_func (data);
 222     }
 223   else if (delta < 0)
 224     {
 225       SCM wind_elt;
 226
 227       scm_i_dowinds (SCM_CDR (to), 1 + delta, turn_func, data);
 228       wind_elt = SCM_CAR (to);
 229
 230       if (FRAME_P (wind_elt))
 231         {
 232           if (!FRAME_REWINDABLE_P (wind_elt))
 233             scm_misc_error ("dowinds",
 234                             "cannot invoke continuation from this context",
 235                             SCM_EOL);
 236         }
 237       else if (WINDER_P (wind_elt))
 238         {
 239           if (WINDER_REWIND_P (wind_elt))
 240             WINDER_PROC (wind_elt) (WINDER_DATA (wind_elt));
 241         }
 242       else if (SCM_WITH_FLUIDS_P (wind_elt))
 243         {
 244           scm_i_swap_with_fluids (wind_elt,
 245                                   SCM_I_CURRENT_THREAD->dynamic_state);
 246         }
 247       else if (SCM_PROMPT_P (wind_elt))
 248         ; /* pass -- see vm_reinstate_partial_continuation */
 249       else if (scm_is_pair (wind_elt))
 250         scm_call_0 (SCM_CAR (wind_elt));
 251       else
 252         /* trash on the wind list */
 253         abort ();
 254
 255       scm_i_set_dynwinds (to);
 256     }
 257   else
 258     {
 259       SCM wind;
 260       SCM wind_elt;
 261
 262       wind = scm_i_dynwinds ();
 263       wind_elt = SCM_CAR (wind);
 264       scm_i_set_dynwinds (SCM_CDR (wind));
 265
 266       if (FRAME_P (wind_elt))
 267         {
 268           /* Nothing to do. */
 269         }
 270       else if (WINDER_P (wind_elt))
 271         {
 272           if (!WINDER_REWIND_P (wind_elt))
 273             WINDER_PROC (wind_elt) (WINDER_DATA (wind_elt));
 274         }
 275       else if (SCM_WITH_FLUIDS_P (wind_elt))
 276         {
 277           scm_i_swap_with_fluids (wind_elt,
 278                                   SCM_I_CURRENT_THREAD->dynamic_state);
 279         }
 280       else if (SCM_PROMPT_P (wind_elt))
 281         ; /* pass -- though we could invalidate the prompt */
 282       else if (scm_is_pair (wind_elt))
 283         scm_call_0 (SCM_CDR (wind_elt));
 284       else
 285         /* trash on the wind list */
 286         abort ();
 287
 288       delta--;
 289       goto tail;                /* scm_dowinds(to, delta-1); */
 290     }
 291 }
 292
 293 void
 294 scm_init_dynwind ()
 295 {
 296   tc16_frame = scm_make_smob_type ("frame", 0);
 297
 298   tc16_winder = scm_make_smob_type ("winder", 0);
 299
 300 #include "libguile/dynwind.x"
 301 }
 302
 303 /*
 304   Local Variables:
 305   c-file-style: "gnu"
 306   End:
 307 */