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