libguile/dynwind.c

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