libguile/dynwind.c

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