libguile/dynwind.c

   1 /* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006 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
   5  * License as published by the Free Software Foundation; either
   6  * version 2.1 of the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful,
   9  * but 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 02110-1301 USA
  16  */
  17
  18
  19 \f
  20
  21 #include <assert.h>
  22
  23 #include "libguile/_scm.h"
  24 #include "libguile/eval.h"
  25 #include "libguile/alist.h"
  26 #include "libguile/fluids.h"
  27 #include "libguile/ports.h"
  28 #include "libguile/smob.h"
  29
  30 #include "libguile/dynwind.h"
  31 \f
  32
  33 /* {Dynamic wind}
  34
  35    Things that can be on the wind list:
  36
  37    #<frame>
  38    #<winder>
  39    (enter-proc . leave-proc)     dynamic-wind
  40    (tag . jmpbuf)                catch
  41    (tag . pre-unwind-data)       throw-handler / lazy-catch
  42      tag is either a symbol or a boolean
  43
  44 */
  45
  46
  47
  48 SCM_DEFINE (scm_dynamic_wind, "dynamic-wind", 3, 0, 0,
  49            (SCM in_guard, SCM thunk, SCM out_guard),
  50             "All three arguments must be 0-argument procedures.\n"
  51             "@var{in_guard} is called, then @var{thunk}, then\n"
  52             "@var{out_guard}.\n"
  53             "\n"
  54             "If, any time during the execution of @var{thunk}, the\n"
  55             "continuation of the @code{dynamic_wind} expression is escaped\n"
  56             "non-locally, @var{out_guard} is called.  If the continuation of\n"
  57             "the dynamic-wind is re-entered, @var{in_guard} is called.  Thus\n"
  58             "@var{in_guard} and @var{out_guard} may be called any number of\n"
  59             "times.\n"
  60             "@lisp\n"
  61             "(define x 'normal-binding)\n"
  62             "@result{} x\n"
  63             "(define a-cont  (call-with-current-continuation\n"
  64             "             (lambda (escape)\n"
  65             "                (let ((old-x x))\n"
  66             "                  (dynamic-wind\n"
  67             "                     ;; in-guard:\n"
  68             "                     ;;\n"
  69             "                     (lambda () (set! x 'special-binding))\n"
  70             "\n"
  71             "                     ;; thunk\n"
  72             "                     ;;\n"
  73             "                     (lambda () (display x) (newline)\n"
  74             "                                (call-with-current-continuation escape)\n"
  75             "                                (display x) (newline)\n"
  76             "                                x)\n"
  77             "\n"
  78             "                     ;; out-guard:\n"
  79             "                     ;;\n"
  80             "                     (lambda () (set! x old-x)))))))\n"
  81             "\n"
  82             ";; Prints:\n"
  83             "special-binding\n"
  84             ";; Evaluates to:\n"
  85             "@result{} a-cont\n"
  86             "x\n"
  87             "@result{} normal-binding\n"
  88             "(a-cont #f)\n"
  89             ";; Prints:\n"
  90             "special-binding\n"
  91             ";; Evaluates to:\n"
  92             "@result{} a-cont  ;; the value of the (define a-cont...)\n"
  93             "x\n"
  94             "@result{} normal-binding\n"
  95             "a-cont\n"
  96             "@result{} special-binding\n"
  97             "@end lisp")
  98 #define FUNC_NAME s_scm_dynamic_wind
  99 {
 100   SCM ans, old_winds;
 101   SCM_ASSERT (scm_is_true (scm_thunk_p (out_guard)),
 102               out_guard,
 103               SCM_ARG3, FUNC_NAME);
 104   scm_call_0 (in_guard);
 105   old_winds = scm_i_dynwinds ();
 106   scm_i_set_dynwinds (scm_acons (in_guard, out_guard, old_winds));
 107   ans = scm_call_0 (thunk);
 108   scm_i_set_dynwinds (old_winds);
 109   scm_call_0 (out_guard);
 110   return ans;
 111 }
 112 #undef FUNC_NAME
 113
 114 SCM
 115 scm_internal_dynamic_wind (scm_t_guard before,
 116                            scm_t_inner inner,
 117                            scm_t_guard after,
 118                            void *inner_data,
 119                            void *guard_data)
 120 {
 121   SCM ans;
 122
 123   scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
 124   scm_dynwind_rewind_handler (before, guard_data, SCM_F_WIND_EXPLICITLY);
 125   scm_dynwind_unwind_handler (after, guard_data, SCM_F_WIND_EXPLICITLY);
 126   ans = inner (inner_data);
 127   scm_dynwind_end ();
 128   return ans;
 129 }
 130
 131 /* Frames and winders. */
 132
 133 static scm_t_bits tc16_frame;
 134 #define FRAME_P(f)     SCM_SMOB_PREDICATE (tc16_frame, (f))
 135
 136 #define FRAME_F_REWINDABLE    (1 << 0)
 137 #define FRAME_REWINDABLE_P(f) (SCM_SMOB_FLAGS(f) & FRAME_F_REWINDABLE)
 138
 139 static scm_t_bits tc16_winder;
 140 #define WINDER_P(w)     SCM_SMOB_PREDICATE (tc16_winder, (w))
 141 #define WINDER_PROC(w)  ((void (*)(void *))SCM_SMOB_DATA (w))
 142 #define WINDER_DATA(w)  ((void *)SCM_SMOB_DATA_2 (w))
 143
 144 #define WINDER_F_EXPLICIT    (1 << 0)
 145 #define WINDER_F_REWIND      (1 << 1)
 146 #define WINDER_F_MARK        (1 << 2)
 147 #define WINDER_EXPLICIT_P(w) (SCM_SMOB_FLAGS(w) & WINDER_F_EXPLICIT)
 148 #define WINDER_REWIND_P(w)   (SCM_SMOB_FLAGS(w) & WINDER_F_REWIND)
 149 #define WINDER_MARK_P(w)     (SCM_SMOB_FLAGS(w) & WINDER_F_MARK)
 150
 151 void
 152 scm_dynwind_begin (scm_t_dynwind_flags flags)
 153 {
 154   SCM f;
 155   SCM_NEWSMOB (f, tc16_frame, 0);
 156   if (flags & SCM_F_DYNWIND_REWINDABLE)
 157     SCM_SET_SMOB_FLAGS (f, FRAME_F_REWINDABLE);
 158   scm_i_set_dynwinds (scm_cons (f, scm_i_dynwinds ()));
 159 }
 160
 161 void
 162 scm_dynwind_end (void)
 163 {
 164   SCM winds;
 165
 166   /* Unwind upto and including the next frame entry.  We can only
 167      encounter #<winder> entries on the way.
 168    */
 169
 170   winds = scm_i_dynwinds ();
 171   while (scm_is_pair (winds))
 172     {
 173       SCM entry = SCM_CAR (winds);
 174       winds = SCM_CDR (winds);
 175
 176       scm_i_set_dynwinds (winds);
 177
 178       if (FRAME_P (entry))
 179         return;
 180
 181       assert (WINDER_P (entry));
 182       if (!WINDER_REWIND_P (entry) && WINDER_EXPLICIT_P (entry))
 183         WINDER_PROC(entry) (WINDER_DATA (entry));
 184     }
 185
 186   assert (0);
 187 }
 188
 189 void
 190 scm_dynwind_unwind_handler (void (*proc) (void *), void *data,
 191                             scm_t_wind_flags flags)
 192 {
 193   SCM w;
 194   SCM_NEWSMOB2 (w, tc16_winder, (scm_t_bits) proc, (scm_t_bits) data);
 195   if (flags & SCM_F_WIND_EXPLICITLY)
 196     SCM_SET_SMOB_FLAGS (w, WINDER_F_EXPLICIT);
 197   scm_i_set_dynwinds (scm_cons (w, scm_i_dynwinds ()));
 198 }
 199
 200 void
 201 scm_dynwind_rewind_handler (void (*proc) (void *), void *data,
 202                             scm_t_wind_flags flags)
 203 {
 204   SCM w;
 205   SCM_NEWSMOB2 (w, tc16_winder, (scm_t_bits) proc, (scm_t_bits) data);
 206   SCM_SET_SMOB_FLAGS (w, WINDER_F_REWIND);
 207   scm_i_set_dynwinds (scm_cons (w, scm_i_dynwinds ()));
 208   if (flags & SCM_F_WIND_EXPLICITLY)
 209     proc (data);
 210 }
 211
 212 void
 213 scm_dynwind_unwind_handler_with_scm (void (*proc) (SCM), SCM data,
 214                                      scm_t_wind_flags flags)
 215 {
 216   SCM w;
 217   scm_t_bits fl = ((flags&SCM_F_WIND_EXPLICITLY)? WINDER_F_EXPLICIT : 0);
 218   SCM_NEWSMOB2 (w, tc16_winder, (scm_t_bits) proc, SCM_UNPACK (data));
 219   SCM_SET_SMOB_FLAGS (w, fl | WINDER_F_MARK);
 220   scm_i_set_dynwinds (scm_cons (w, scm_i_dynwinds ()));
 221 }
 222
 223 void
 224 scm_dynwind_rewind_handler_with_scm (void (*proc) (SCM), SCM data,
 225                                      scm_t_wind_flags flags)
 226 {
 227   SCM w;
 228   SCM_NEWSMOB2 (w, tc16_winder, (scm_t_bits) proc, SCM_UNPACK (data));
 229   SCM_SET_SMOB_FLAGS (w, WINDER_F_REWIND | WINDER_F_MARK);
 230   scm_i_set_dynwinds (scm_cons (w, scm_i_dynwinds ()));
 231   if (flags & SCM_F_WIND_EXPLICITLY)
 232     proc (data);
 233 }
 234
 235 void
 236 scm_dynwind_free (void *mem)
 237 {
 238   scm_dynwind_unwind_handler (free, mem, SCM_F_WIND_EXPLICITLY);
 239 }
 240
 241 #ifdef GUILE_DEBUG
 242 SCM_DEFINE (scm_wind_chain, "wind-chain", 0, 0, 0,
 243             (),
 244             "Return the current wind chain. The wind chain contains all\n"
 245             "information required by @code{dynamic-wind} to call its\n"
 246             "argument thunks when entering/exiting its scope.")
 247 #define FUNC_NAME s_scm_wind_chain
 248 {
 249   return scm_i_dynwinds ();
 250 }
 251 #undef FUNC_NAME
 252 #endif
 253
 254 void
 255 scm_swap_bindings (SCM vars, SCM vals)
 256 {
 257   SCM tmp;
 258   while (SCM_NIMP (vals))
 259     {
 260       tmp = SCM_VARIABLE_REF (SCM_CAR (vars));
 261       SCM_VARIABLE_SET (SCM_CAR (vars), SCM_CAR (vals));
 262       SCM_SETCAR (vals, tmp);
 263       vars = SCM_CDR (vars);
 264       vals = SCM_CDR (vals);
 265     }
 266 }
 267
 268 void
 269 scm_dowinds (SCM to, long delta)
 270 {
 271   scm_i_dowinds (to, delta, NULL, NULL);
 272 }
 273
 274 void
 275 scm_i_dowinds (SCM to, long delta, void (*turn_func) (void *), void *data)
 276 {
 277  tail:
 278   if (scm_is_eq (to, scm_i_dynwinds ()))
 279     {
 280       if (turn_func)
 281         turn_func (data);
 282     }
 283   else if (delta < 0)
 284     {
 285       SCM wind_elt;
 286       SCM wind_key;
 287
 288       scm_i_dowinds (SCM_CDR (to), 1 + delta, turn_func, data);
 289       wind_elt = SCM_CAR (to);
 290
 291       if (FRAME_P (wind_elt))
 292         {
 293           if (!FRAME_REWINDABLE_P (wind_elt))
 294             scm_misc_error ("dowinds",
 295                             "cannot invoke continuation from this context",
 296                             SCM_EOL);
 297         }
 298       else if (WINDER_P (wind_elt))
 299         {
 300           if (WINDER_REWIND_P (wind_elt))
 301             WINDER_PROC (wind_elt) (WINDER_DATA (wind_elt));
 302         }
 303       else
 304         {
 305           wind_key = SCM_CAR (wind_elt);
 306           /* key = #t | symbol | thunk | list of variables */
 307           if (SCM_NIMP (wind_key))
 308             {
 309               if (scm_is_pair (wind_key))
 310                 {
 311                   if (SCM_VARIABLEP (SCM_CAR (wind_key)))
 312                     scm_swap_bindings (wind_key, SCM_CDR (wind_elt));
 313                 }
 314               else if (SCM_TYP3 (wind_key) == scm_tc3_closure)
 315                 scm_call_0 (wind_key);
 316             }
 317         }
 318
 319       scm_i_set_dynwinds (to);
 320     }
 321   else
 322     {
 323       SCM wind;
 324       SCM wind_elt;
 325       SCM wind_key;
 326
 327       wind = scm_i_dynwinds ();
 328       wind_elt = SCM_CAR (wind);
 329       scm_i_set_dynwinds (SCM_CDR (wind));
 330
 331       if (FRAME_P (wind_elt))
 332         {
 333           /* Nothing to do. */
 334         }
 335       else if (WINDER_P (wind_elt))
 336         {
 337           if (!WINDER_REWIND_P (wind_elt))
 338             WINDER_PROC (wind_elt) (WINDER_DATA (wind_elt));
 339         }
 340       else
 341         {
 342           wind_key = SCM_CAR (wind_elt);
 343           if (SCM_NIMP (wind_key))
 344             {
 345               if (scm_is_pair (wind_key))
 346                 {
 347                   if (SCM_VARIABLEP (SCM_CAR (wind_key)))
 348                     scm_swap_bindings (wind_key, SCM_CDR (wind_elt));
 349                 }
 350               else if (SCM_TYP3 (wind_key) == scm_tc3_closure)
 351                 scm_call_0 (SCM_CDR (wind_elt));
 352             }
 353         }
 354
 355       delta--;
 356       goto tail;                /* scm_dowinds(to, delta-1); */
 357     }
 358 }
 359
 360 void
 361 scm_init_dynwind ()
 362 {
 363   tc16_frame = scm_make_smob_type ("frame", 0);
 364
 365   tc16_winder = scm_make_smob_type ("winder", 0);
 366
 367 #include "libguile/dynwind.x"
 368 }
 369
 370 /*
 371   Local Variables:
 372   c-file-style: "gnu"
 373   End:
 374 */