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 */
  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;
 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   scm_dynwinds = scm_acons (in_guard, out_guard, scm_dynwinds);
 106   ans = scm_call_0 (thunk);
 107   scm_dynwinds = SCM_CDR (scm_dynwinds);
 108   scm_call_0 (out_guard);
 109   return ans;
 110 }
 111 #undef FUNC_NAME
 112
 113 SCM
 114 scm_internal_dynamic_wind (scm_t_guard before,
 115                            scm_t_inner inner,
 116                            scm_t_guard after,
 117                            void *inner_data,
 118                            void *guard_data)
 119 {
 120   SCM ans;
 121
 122   scm_frame_begin (SCM_F_FRAME_REWINDABLE);
 123   scm_frame_rewind_handler (before, guard_data, SCM_F_WIND_EXPLICITLY);
 124   scm_frame_unwind_handler (after, guard_data, SCM_F_WIND_EXPLICITLY);
 125   ans = inner (inner_data);
 126   scm_frame_end ();
 127   return ans;
 128 }
 129
 130 /* Frames and winders. */
 131
 132 static scm_t_bits tc16_frame;
 133 #define FRAME_P(f)     SCM_SMOB_PREDICATE (tc16_frame, (f))
 134
 135 #define FRAME_F_REWINDABLE    (1 << 0)
 136 #define FRAME_REWINDABLE_P(f) (SCM_SMOB_FLAGS(f) & FRAME_F_REWINDABLE)
 137
 138 static scm_t_bits tc16_winder;
 139 #define WINDER_P(w)     SCM_SMOB_PREDICATE (tc16_winder, (w))
 140 #define WINDER_PROC(w)  ((void (*)(void *))SCM_SMOB_DATA (w))
 141 #define WINDER_DATA(w)  ((void *)SCM_SMOB_DATA_2 (w))
 142
 143 #define WINDER_F_EXPLICIT    (1 << 0)
 144 #define WINDER_F_REWIND      (1 << 1)
 145 #define WINDER_F_MARK        (1 << 2)
 146 #define WINDER_EXPLICIT_P(w) (SCM_SMOB_FLAGS(w) & WINDER_F_EXPLICIT)
 147 #define WINDER_REWIND_P(w)   (SCM_SMOB_FLAGS(w) & WINDER_F_REWIND)
 148 #define WINDER_MARK_P(w)     (SCM_SMOB_FLAGS(w) & WINDER_F_MARK)
 149
 150 void
 151 scm_frame_begin (scm_t_frame_flags flags)
 152 {
 153   SCM f;
 154   SCM_NEWSMOB (f, tc16_frame, 0);
 155   if (flags & SCM_F_FRAME_REWINDABLE)
 156     SCM_SET_SMOB_FLAGS (f, FRAME_F_REWINDABLE);
 157   scm_dynwinds = scm_cons (f, scm_dynwinds);
 158 }
 159
 160 void
 161 scm_frame_end (void)
 162 {
 163   /* Unwind upto and including the next frame entry.  We can only
 164      encounter #<winder> entries on the way.
 165    */
 166
 167   while (scm_is_pair (scm_dynwinds))
 168     {
 169       SCM entry = SCM_CAR (scm_dynwinds);
 170       scm_dynwinds = SCM_CDR (scm_dynwinds);
 171
 172       if (FRAME_P (entry))
 173         return;
 174
 175       assert (WINDER_P (entry));
 176       if (!WINDER_REWIND_P (entry) && WINDER_EXPLICIT_P (entry))
 177         WINDER_PROC(entry) (WINDER_DATA (entry));
 178     }
 179
 180   assert (0);
 181 }
 182
 183 static SCM
 184 winder_mark (SCM w)
 185 {
 186   if (WINDER_MARK_P (w))
 187     return SCM_PACK (WINDER_DATA (w));
 188   return SCM_BOOL_F;
 189 }
 190
 191 void
 192 scm_frame_unwind_handler (void (*proc) (void *), void *data,
 193                           scm_t_wind_flags flags)
 194 {
 195   SCM w;
 196   SCM_NEWSMOB2 (w, tc16_winder, (scm_t_bits) proc, (scm_t_bits) data);
 197   if (flags & SCM_F_WIND_EXPLICITLY)
 198     SCM_SET_SMOB_FLAGS (w, WINDER_F_EXPLICIT);
 199   scm_dynwinds = scm_cons (w, scm_dynwinds);
 200 }
 201
 202 void
 203 scm_frame_rewind_handler (void (*proc) (void *), void *data,
 204                           scm_t_wind_flags flags)
 205 {
 206   SCM w;
 207   SCM_NEWSMOB2 (w, tc16_winder, (scm_t_bits) proc, (scm_t_bits) data);
 208   SCM_SET_SMOB_FLAGS (w, WINDER_F_REWIND);
 209   scm_dynwinds = scm_cons (w, scm_dynwinds);
 210   if (flags & SCM_F_WIND_EXPLICITLY)
 211     proc (data);
 212 }
 213
 214 void
 215 scm_frame_unwind_handler_with_scm (void (*proc) (SCM), SCM data,
 216                                    scm_t_wind_flags flags)
 217 {
 218   SCM w;
 219   scm_t_bits fl = ((flags&SCM_F_WIND_EXPLICITLY)? WINDER_F_EXPLICIT : 0);
 220   SCM_NEWSMOB2 (w, tc16_winder, (scm_t_bits) proc, SCM_UNPACK (data));
 221   SCM_SET_SMOB_FLAGS (w, fl | WINDER_F_MARK);
 222   scm_dynwinds = scm_cons (w, scm_dynwinds);
 223 }
 224
 225 void
 226 scm_frame_rewind_handler_with_scm (void (*proc) (SCM), SCM data,
 227                                    scm_t_wind_flags flags)
 228 {
 229   SCM w;
 230   SCM_NEWSMOB2 (w, tc16_winder, (scm_t_bits) proc, SCM_UNPACK (data));
 231   SCM_SET_SMOB_FLAGS (w, WINDER_F_REWIND | WINDER_F_MARK);
 232   scm_dynwinds = scm_cons (w, scm_dynwinds);
 233   if (flags & SCM_F_WIND_EXPLICITLY)
 234     proc (data);
 235 }
 236
 237 void
 238 scm_frame_free (void *mem)
 239 {
 240   scm_frame_unwind_handler (free, mem, SCM_F_WIND_EXPLICITLY);
 241 }
 242
 243 #ifdef GUILE_DEBUG
 244 SCM_DEFINE (scm_wind_chain, "wind-chain", 0, 0, 0,
 245             (),
 246             "Return the current wind chain. The wind chain contains all\n"
 247             "information required by @code{dynamic-wind} to call its\n"
 248             "argument thunks when entering/exiting its scope.")
 249 #define FUNC_NAME s_scm_wind_chain
 250 {
 251   return scm_dynwinds;
 252 }
 253 #undef FUNC_NAME
 254 #endif
 255
 256 void
 257 scm_swap_bindings (SCM vars, SCM vals)
 258 {
 259   SCM tmp;
 260   while (SCM_NIMP (vals))
 261     {
 262       tmp = SCM_VARIABLE_REF (SCM_CAR (vars));
 263       SCM_VARIABLE_SET (SCM_CAR (vars), SCM_CAR (vals));
 264       SCM_SETCAR (vals, tmp);
 265       vars = SCM_CDR (vars);
 266       vals = SCM_CDR (vals);
 267     }
 268 }
 269
 270 void
 271 scm_dowinds (SCM to, long delta)
 272 {
 273   scm_i_dowinds (to, delta, NULL, NULL);
 274 }
 275
 276 void
 277 scm_i_dowinds (SCM to, long delta, void (*turn_func) (void *), void *data)
 278 {
 279  tail:
 280   if (scm_is_eq (to, scm_dynwinds))
 281     {
 282       if (turn_func)
 283         turn_func (data);
 284     }
 285   else if (delta < 0)
 286     {
 287       SCM wind_elt;
 288       SCM wind_key;
 289
 290       scm_i_dowinds (SCM_CDR (to), 1 + delta, turn_func, data);
 291       wind_elt = SCM_CAR (to);
 292
 293       if (FRAME_P (wind_elt))
 294         {
 295           if (!FRAME_REWINDABLE_P (wind_elt))
 296             scm_misc_error ("dowinds",
 297                             "cannot invoke continuation from this context",
 298                             SCM_EOL);
 299         }
 300       else if (WINDER_P (wind_elt))
 301         {
 302           if (WINDER_REWIND_P (wind_elt))
 303             WINDER_PROC (wind_elt) (WINDER_DATA (wind_elt));
 304         }
 305       else
 306         {
 307           wind_key = SCM_CAR (wind_elt);
 308           /* key = #t | symbol | thunk | list of variables */
 309           if (SCM_NIMP (wind_key))
 310             {
 311               if (scm_is_pair (wind_key))
 312                 {
 313                   if (SCM_VARIABLEP (SCM_CAR (wind_key)))
 314                     scm_swap_bindings (wind_key, SCM_CDR (wind_elt));
 315                 }
 316               else if (SCM_TYP3 (wind_key) == scm_tc3_closure)
 317                 scm_call_0 (wind_key);
 318             }
 319         }
 320
 321       scm_dynwinds = to;
 322     }
 323   else
 324     {
 325       SCM wind_elt;
 326       SCM wind_key;
 327
 328       wind_elt = SCM_CAR (scm_dynwinds);
 329       scm_dynwinds = SCM_CDR (scm_dynwinds);
 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   scm_set_smob_mark (tc16_winder, winder_mark);
 367
 368 #include "libguile/dynwind.x"
 369 }
 370
 371 /*
 372   Local Variables:
 373   c-file-style: "gnu"
 374   End:
 375 */