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 static SCM
 190 winder_mark (SCM w)
 191 {
 192   if (WINDER_MARK_P (w))
 193     return SCM_PACK (WINDER_DATA (w));
 194   return SCM_BOOL_F;
 195 }
 196
 197 void
 198 scm_dynwind_unwind_handler (void (*proc) (void *), void *data,
 199                             scm_t_wind_flags flags)
 200 {
 201   SCM w;
 202   SCM_NEWSMOB2 (w, tc16_winder, (scm_t_bits) proc, (scm_t_bits) data);
 203   if (flags & SCM_F_WIND_EXPLICITLY)
 204     SCM_SET_SMOB_FLAGS (w, WINDER_F_EXPLICIT);
 205   scm_i_set_dynwinds (scm_cons (w, scm_i_dynwinds ()));
 206 }
 207
 208 void
 209 scm_dynwind_rewind_handler (void (*proc) (void *), void *data,
 210                             scm_t_wind_flags flags)
 211 {
 212   SCM w;
 213   SCM_NEWSMOB2 (w, tc16_winder, (scm_t_bits) proc, (scm_t_bits) data);
 214   SCM_SET_SMOB_FLAGS (w, WINDER_F_REWIND);
 215   scm_i_set_dynwinds (scm_cons (w, scm_i_dynwinds ()));
 216   if (flags & SCM_F_WIND_EXPLICITLY)
 217     proc (data);
 218 }
 219
 220 void
 221 scm_dynwind_unwind_handler_with_scm (void (*proc) (SCM), SCM data,
 222                                      scm_t_wind_flags flags)
 223 {
 224   SCM w;
 225   scm_t_bits fl = ((flags&SCM_F_WIND_EXPLICITLY)? WINDER_F_EXPLICIT : 0);
 226   SCM_NEWSMOB2 (w, tc16_winder, (scm_t_bits) proc, SCM_UNPACK (data));
 227   SCM_SET_SMOB_FLAGS (w, fl | WINDER_F_MARK);
 228   scm_i_set_dynwinds (scm_cons (w, scm_i_dynwinds ()));
 229 }
 230
 231 void
 232 scm_dynwind_rewind_handler_with_scm (void (*proc) (SCM), SCM data,
 233                                      scm_t_wind_flags flags)
 234 {
 235   SCM w;
 236   SCM_NEWSMOB2 (w, tc16_winder, (scm_t_bits) proc, SCM_UNPACK (data));
 237   SCM_SET_SMOB_FLAGS (w, WINDER_F_REWIND | WINDER_F_MARK);
 238   scm_i_set_dynwinds (scm_cons (w, scm_i_dynwinds ()));
 239   if (flags & SCM_F_WIND_EXPLICITLY)
 240     proc (data);
 241 }
 242
 243 void
 244 scm_dynwind_free (void *mem)
 245 {
 246   scm_dynwind_unwind_handler (free, mem, SCM_F_WIND_EXPLICITLY);
 247 }
 248
 249 #ifdef GUILE_DEBUG
 250 SCM_DEFINE (scm_wind_chain, "wind-chain", 0, 0, 0,
 251             (),
 252             "Return the current wind chain. The wind chain contains all\n"
 253             "information required by @code{dynamic-wind} to call its\n"
 254             "argument thunks when entering/exiting its scope.")
 255 #define FUNC_NAME s_scm_wind_chain
 256 {
 257   return scm_i_dynwinds ();
 258 }
 259 #undef FUNC_NAME
 260 #endif
 261
 262 void
 263 scm_swap_bindings (SCM vars, SCM vals)
 264 {
 265   SCM tmp;
 266   while (SCM_NIMP (vals))
 267     {
 268       tmp = SCM_VARIABLE_REF (SCM_CAR (vars));
 269       SCM_VARIABLE_SET (SCM_CAR (vars), SCM_CAR (vals));
 270       SCM_SETCAR (vals, tmp);
 271       vars = SCM_CDR (vars);
 272       vals = SCM_CDR (vals);
 273     }
 274 }
 275
 276 void
 277 scm_dowinds (SCM to, long delta)
 278 {
 279   scm_i_dowinds (to, delta, NULL, NULL);
 280 }
 281
 282 void
 283 scm_i_dowinds (SCM to, long delta, void (*turn_func) (void *), void *data)
 284 {
 285  tail:
 286   if (scm_is_eq (to, scm_i_dynwinds ()))
 287     {
 288       if (turn_func)
 289         turn_func (data);
 290     }
 291   else if (delta < 0)
 292     {
 293       SCM wind_elt;
 294       SCM wind_key;
 295
 296       scm_i_dowinds (SCM_CDR (to), 1 + delta, turn_func, data);
 297       wind_elt = SCM_CAR (to);
 298
 299       if (FRAME_P (wind_elt))
 300         {
 301           if (!FRAME_REWINDABLE_P (wind_elt))
 302             scm_misc_error ("dowinds",
 303                             "cannot invoke continuation from this context",
 304                             SCM_EOL);
 305         }
 306       else if (WINDER_P (wind_elt))
 307         {
 308           if (WINDER_REWIND_P (wind_elt))
 309             WINDER_PROC (wind_elt) (WINDER_DATA (wind_elt));
 310         }
 311       else
 312         {
 313           wind_key = SCM_CAR (wind_elt);
 314           /* key = #t | symbol | thunk | list of variables */
 315           if (SCM_NIMP (wind_key))
 316             {
 317               if (scm_is_pair (wind_key))
 318                 {
 319                   if (SCM_VARIABLEP (SCM_CAR (wind_key)))
 320                     scm_swap_bindings (wind_key, SCM_CDR (wind_elt));
 321                 }
 322               else if (SCM_TYP3 (wind_key) == scm_tc3_closure)
 323                 scm_call_0 (wind_key);
 324             }
 325         }
 326
 327       scm_i_set_dynwinds (to);
 328     }
 329   else
 330     {
 331       SCM wind;
 332       SCM wind_elt;
 333       SCM wind_key;
 334
 335       wind = scm_i_dynwinds ();
 336       wind_elt = SCM_CAR (wind);
 337       scm_i_set_dynwinds (SCM_CDR (wind));
 338
 339       if (FRAME_P (wind_elt))
 340         {
 341           /* Nothing to do. */
 342         }
 343       else if (WINDER_P (wind_elt))
 344         {
 345           if (!WINDER_REWIND_P (wind_elt))
 346             WINDER_PROC (wind_elt) (WINDER_DATA (wind_elt));
 347         }
 348       else
 349         {
 350           wind_key = SCM_CAR (wind_elt);
 351           if (SCM_NIMP (wind_key))
 352             {
 353               if (scm_is_pair (wind_key))
 354                 {
 355                   if (SCM_VARIABLEP (SCM_CAR (wind_key)))
 356                     scm_swap_bindings (wind_key, SCM_CDR (wind_elt));
 357                 }
 358               else if (SCM_TYP3 (wind_key) == scm_tc3_closure)
 359                 scm_call_0 (SCM_CDR (wind_elt));
 360             }
 361         }
 362
 363       delta--;
 364       goto tail;                /* scm_dowinds(to, delta-1); */
 365     }
 366 }
 367
 368 void
 369 scm_init_dynwind ()
 370 {
 371   tc16_frame = scm_make_smob_type ("frame", 0);
 372
 373   tc16_winder = scm_make_smob_type ("winder", 0);
 374   scm_set_smob_mark (tc16_winder, winder_mark);
 375
 376 #include "libguile/dynwind.x"
 377 }
 378
 379 /*
 380   Local Variables:
 381   c-file-style: "gnu"
 382   End:
 383 */