libguile/dynwind.c

   1 /* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 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 . lazy-catch)            lazy-catch
  42      tag is either a symbol or a boolean
  43
  44    ((fluid ...) . (value ...))   with-fluids
  45
  46 */
  47
  48
  49
  50 SCM_DEFINE (scm_dynamic_wind, "dynamic-wind", 3, 0, 0,
  51            (SCM in_guard, SCM thunk, SCM out_guard),
  52             "All three arguments must be 0-argument procedures.\n"
  53             "@var{in_guard} is called, then @var{thunk}, then\n"
  54             "@var{out_guard}.\n"
  55             "\n"
  56             "If, any time during the execution of @var{thunk}, the\n"
  57             "continuation of the @code{dynamic_wind} expression is escaped\n"
  58             "non-locally, @var{out_guard} is called.  If the continuation of\n"
  59             "the dynamic-wind is re-entered, @var{in_guard} is called.  Thus\n"
  60             "@var{in_guard} and @var{out_guard} may be called any number of\n"
  61             "times.\n"
  62             "@lisp\n"
  63             "(define x 'normal-binding)\n"
  64             "@result{} x\n"
  65             "(define a-cont  (call-with-current-continuation\n"
  66             "             (lambda (escape)\n"
  67             "                (let ((old-x x))\n"
  68             "                  (dynamic-wind\n"
  69             "                     ;; in-guard:\n"
  70             "                     ;;\n"
  71             "                     (lambda () (set! x 'special-binding))\n"
  72             "\n"
  73             "                     ;; thunk\n"
  74             "                     ;;\n"
  75             "                     (lambda () (display x) (newline)\n"
  76             "                                (call-with-current-continuation escape)\n"
  77             "                                (display x) (newline)\n"
  78             "                                x)\n"
  79             "\n"
  80             "                     ;; out-guard:\n"
  81             "                     ;;\n"
  82             "                     (lambda () (set! x old-x)))))))\n"
  83             "\n"
  84             ";; Prints:\n"
  85             "special-binding\n"
  86             ";; Evaluates to:\n"
  87             "@result{} a-cont\n"
  88             "x\n"
  89             "@result{} normal-binding\n"
  90             "(a-cont #f)\n"
  91             ";; Prints:\n"
  92             "special-binding\n"
  93             ";; Evaluates to:\n"
  94             "@result{} a-cont  ;; the value of the (define a-cont...)\n"
  95             "x\n"
  96             "@result{} normal-binding\n"
  97             "a-cont\n"
  98             "@result{} special-binding\n"
  99             "@end lisp")
 100 #define FUNC_NAME s_scm_dynamic_wind
 101 {
 102   SCM ans;
 103   SCM_ASSERT (SCM_NFALSEP (scm_thunk_p (out_guard)),
 104               out_guard,
 105               SCM_ARG3, FUNC_NAME);
 106   scm_call_0 (in_guard);
 107   scm_dynwinds = scm_acons (in_guard, out_guard, scm_dynwinds);
 108   ans = scm_call_0 (thunk);
 109   scm_dynwinds = SCM_CDR (scm_dynwinds);
 110   scm_call_0 (out_guard);
 111   return ans;
 112 }
 113 #undef FUNC_NAME
 114
 115 SCM
 116 scm_internal_dynamic_wind (scm_t_guard before,
 117                            scm_t_inner inner,
 118                            scm_t_guard after,
 119                            void *inner_data,
 120                            void *guard_data)
 121 {
 122   SCM ans;
 123
 124   scm_begin_frame (SCM_F_FRAME_REWINDABLE);
 125   scm_on_rewind (before, guard_data, SCM_F_WIND_EXPLICITLY);
 126   scm_on_unwind (after, guard_data, SCM_F_WIND_EXPLICITLY);
 127   ans = inner (inner_data);
 128   scm_end_frame ();
 129   return ans;
 130 }
 131
 132 /* Frames and winders. */
 133
 134 static scm_t_bits tc16_frame;
 135 #define FRAME_P(f)     SCM_SMOB_PREDICATE (tc16_frame, (f))
 136
 137 #define FRAME_F_REWINDABLE    (1 << 16)
 138 #define FRAME_REWINDABLE_P(f) (SCM_CELL_WORD_0(f) & FRAME_F_REWINDABLE)
 139
 140 static scm_t_bits tc16_winder;
 141 #define WINDER_P(w)    SCM_SMOB_PREDICATE (tc16_winder, (w))
 142 #define WINDER_PROC(w) ((void (*)(void *))SCM_CELL_WORD_1 (w))
 143 #define WINDER_DATA(w) ((void *)SCM_CELL_WORD_2 (w))
 144
 145 #define WINDER_F_EXPLICIT    (1 << 16)
 146 #define WINDER_F_REWIND      (1 << 17)
 147 #define WINDER_F_MARK        (1 << 18)
 148 #define WINDER_EXPLICIT_P(w) (SCM_CELL_WORD_0(w) & WINDER_F_EXPLICIT)
 149 #define WINDER_REWIND_P(w)   (SCM_CELL_WORD_0(w) & WINDER_F_REWIND)
 150 #define WINDER_MARK_P(w)     (SCM_CELL_WORD_0(w) & WINDER_F_MARK)
 151
 152 void
 153 scm_begin_frame (scm_t_frame_flags flags)
 154 {
 155   SCM f;
 156   scm_t_bits fl = ((flags&SCM_F_FRAME_REWINDABLE)? FRAME_F_REWINDABLE : 0);
 157   SCM_NEWSMOB (f, tc16_frame | fl, 0);
 158   scm_dynwinds = scm_cons (f, scm_dynwinds);
 159 }
 160
 161 void
 162 scm_end_frame (void)
 163 {
 164   long delta;
 165   SCM to;
 166
 167   /* Unwind upto and including the next frame entry.
 168    */
 169
 170   for (to = scm_dynwinds, delta = 1;
 171        SCM_CONSP (to);
 172        to = SCM_CDR (to), delta++)
 173     {
 174       if (FRAME_P (SCM_CAR (to)))
 175         {
 176           scm_i_dowinds (SCM_CDR (to), delta, 1, NULL, NULL);
 177           return;
 178         }
 179     }
 180
 181   assert (0);
 182 }
 183
 184 static SCM
 185 winder_mark (SCM w)
 186 {
 187   if (WINDER_MARK_P (w))
 188     return WINDER_DATA (w);
 189   return SCM_BOOL_F;
 190 }
 191
 192 void
 193 scm_on_unwind (void (*proc) (void *), void *data,
 194                scm_t_wind_flags flags)
 195 {
 196   SCM w;
 197   scm_t_bits fl = ((flags&SCM_F_WIND_EXPLICITLY)? WINDER_F_EXPLICIT : 0);
 198   SCM_NEWSMOB2 (w, tc16_winder | fl,
 199                 (scm_t_bits) proc, (scm_t_bits) data);
 200   scm_dynwinds = scm_cons (w, scm_dynwinds);
 201 }
 202
 203 void
 204 scm_on_rewind (void (*proc) (void *), void *data,
 205                scm_t_wind_flags flags)
 206 {
 207   SCM w;
 208   SCM_NEWSMOB2 (w, tc16_winder | WINDER_F_REWIND,
 209                 (scm_t_bits) proc, (scm_t_bits) data);
 210   scm_dynwinds = scm_cons (w, scm_dynwinds);
 211   if (flags & SCM_F_WIND_EXPLICITLY)
 212     proc (data);
 213 }
 214
 215 void
 216 scm_on_unwind_with_scm (void (*proc) (SCM), SCM data,
 217                         scm_t_wind_flags flags)
 218 {
 219   SCM w;
 220   scm_t_bits fl = ((flags&SCM_F_WIND_EXPLICITLY)? WINDER_F_EXPLICIT : 0);
 221   SCM_NEWSMOB2 (w, tc16_winder | fl | WINDER_F_MARK,
 222                 (scm_t_bits) proc, SCM_UNPACK (data));
 223   scm_dynwinds = scm_cons (w, scm_dynwinds);
 224 }
 225
 226 void
 227 scm_on_rewind_with_scm (void (*proc) (SCM), SCM data,
 228                         scm_t_wind_flags flags)
 229 {
 230   SCM w;
 231   SCM_NEWSMOB2 (w, tc16_winder | WINDER_F_REWIND | WINDER_F_MARK,
 232                 (scm_t_bits) proc, SCM_UNPACK (data));
 233   scm_dynwinds = scm_cons (w, scm_dynwinds);
 234   if (flags & SCM_F_WIND_EXPLICITLY)
 235     proc (data);
 236 }
 237
 238 #ifdef GUILE_DEBUG
 239 SCM_DEFINE (scm_wind_chain, "wind-chain", 0, 0, 0,
 240             (),
 241             "Return the current wind chain. The wind chain contains all\n"
 242             "information required by @code{dynamic-wind} to call its\n"
 243             "argument thunks when entering/exiting its scope.")
 244 #define FUNC_NAME s_scm_wind_chain
 245 {
 246   return scm_dynwinds;
 247 }
 248 #undef FUNC_NAME
 249 #endif
 250
 251 void
 252 scm_swap_bindings (SCM vars, SCM vals)
 253 {
 254   SCM tmp;
 255   while (SCM_NIMP (vals))
 256     {
 257       tmp = SCM_VARIABLE_REF (SCM_CAR (vars));
 258       SCM_VARIABLE_SET (SCM_CAR (vars), SCM_CAR (vals));
 259       SCM_SETCAR (vals, tmp);
 260       vars = SCM_CDR (vars);
 261       vals = SCM_CDR (vals);
 262     }
 263 }
 264
 265 void
 266 scm_dowinds (SCM to, long delta)
 267 {
 268   scm_i_dowinds (to, delta, 0, NULL, NULL);
 269 }
 270
 271 void
 272 scm_i_dowinds (SCM to, long delta, int explicit,
 273                void (*turn_func) (void *), void *data)
 274 {
 275  tail:
 276   if (SCM_EQ_P (to, scm_dynwinds))
 277     {
 278       if (turn_func)
 279         turn_func (data);
 280     }
 281   else if (delta < 0)
 282     {
 283       SCM wind_elt;
 284       SCM wind_key;
 285
 286       scm_i_dowinds (SCM_CDR (to), 1 + delta, explicit,
 287                      turn_func, data);
 288       wind_elt = SCM_CAR (to);
 289
 290 #if 0
 291       if (SCM_INUMP (wind_elt))
 292         {
 293           scm_cross_dynwind_binding_scope (wind_elt, 0);
 294         }
 295       else
 296 #endif
 297         {
 298           if (FRAME_P (wind_elt))
 299             {
 300               if (!FRAME_REWINDABLE_P (wind_elt))
 301                 scm_misc_error ("dowinds",
 302                                 "cannot invoke continuation from this context",
 303                                 SCM_EOL);
 304             }
 305           else if (WINDER_P (wind_elt))
 306             {
 307               if (WINDER_REWIND_P (wind_elt))
 308                 {
 309                   void (*proc) (void *) = WINDER_PROC (wind_elt);
 310                   void *data = WINDER_DATA (wind_elt);
 311                   proc (data);
 312                 }
 313             }
 314           else
 315             {
 316               wind_key = SCM_CAR (wind_elt);
 317               /* key = #t | symbol | thunk | list of variables | list of fluids */
 318               if (SCM_NIMP (wind_key))
 319                 {
 320                   if (SCM_CONSP (wind_key))
 321                     {
 322                       if (SCM_VARIABLEP (SCM_CAR (wind_key)))
 323                         scm_swap_bindings (wind_key, SCM_CDR (wind_elt));
 324                       else if (SCM_FLUIDP (SCM_CAR (wind_key)))
 325                         scm_i_swap_fluids (wind_key, SCM_CDR (wind_elt));
 326                     }
 327                   else if (SCM_TYP3 (wind_key) == scm_tc3_closure)
 328                     scm_call_0 (wind_key);
 329                 }
 330             }
 331         }
 332       scm_dynwinds = to;
 333     }
 334   else
 335     {
 336       SCM wind_elt;
 337       SCM wind_key;
 338
 339       wind_elt = SCM_CAR (scm_dynwinds);
 340       scm_dynwinds = SCM_CDR (scm_dynwinds);
 341
 342 #if 0
 343       if (SCM_INUMP (wind_elt))
 344         {
 345           scm_cross_dynwind_binding_scope (wind_elt, 0);
 346         }
 347       else
 348 #endif
 349         {
 350           if (FRAME_P (wind_elt))
 351             {
 352               /* Nothing to do. */
 353             }
 354           else if (WINDER_P (wind_elt))
 355             {
 356               if (!WINDER_REWIND_P (wind_elt)
 357                   && (!explicit || WINDER_EXPLICIT_P (wind_elt)))
 358                 {
 359                   void (*proc) (void *) = WINDER_PROC (wind_elt);
 360                   void *data = WINDER_DATA (wind_elt);
 361                   proc (data);
 362                 }
 363             }
 364           else
 365             {
 366               wind_key = SCM_CAR (wind_elt);
 367               if (SCM_NIMP (wind_key))
 368                 {
 369                   if (SCM_CONSP (wind_key))
 370                     {
 371                       if (SCM_VARIABLEP (SCM_CAR (wind_key)))
 372                         scm_swap_bindings (wind_key, SCM_CDR (wind_elt));
 373                       else if (SCM_FLUIDP (SCM_CAR (wind_key)))
 374                         scm_i_swap_fluids_reverse (wind_key,
 375                                                    SCM_CDR (wind_elt));
 376                     }
 377                   else if (SCM_TYP3 (wind_key) == scm_tc3_closure)
 378                     scm_call_0 (SCM_CDR (wind_elt));
 379                 }
 380             }
 381         }
 382       delta--;
 383       goto tail;                /* scm_dowinds(to, delta-1); */
 384     }
 385 }
 386
 387 void
 388 scm_init_dynwind ()
 389 {
 390   tc16_frame = scm_make_smob_type ("frame", 0);
 391
 392   tc16_winder = scm_make_smob_type ("winder", 0);
 393   scm_set_smob_mark (tc16_winder, winder_mark);
 394
 395 #include "libguile/dynwind.x"
 396 }
 397
 398 /*
 399   Local Variables:
 400   c-file-style: "gnu"
 401   End:
 402 */