libguile/dynwind.c

   1 /* Copyright (C) 1995,1996,1998,1999,2000,2001 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 "libguile/_scm.h"
  22 #include "libguile/eval.h"
  23 #include "libguile/alist.h"
  24 #include "libguile/fluids.h"
  25 #include "libguile/ports.h"
  26 #include "libguile/smob.h"
  27
  28 #include "libguile/dynwind.h"
  29 \f
  30
  31 /* {Dynamic wind}
  32
  33    Things that can be on the wind list:
  34
  35    (enter-proc . leave-proc)     dynamic-wind
  36    (tag . jmpbuf)                catch
  37    (tag . lazy-catch)            lazy-catch
  38      tag is either a symbol or a boolean
  39
  40    ((fluid ...) . (value ...))   with-fluids
  41
  42 */
  43
  44
  45
  46 SCM_DEFINE (scm_dynamic_wind, "dynamic-wind", 3, 0, 0,
  47            (SCM in_guard, SCM thunk, SCM out_guard),
  48             "All three arguments must be 0-argument procedures.\n"
  49             "@var{in_guard} is called, then @var{thunk}, then\n"
  50             "@var{out_guard}.\n"
  51             "\n"
  52             "If, any time during the execution of @var{thunk}, the\n"
  53             "continuation of the @code{dynamic_wind} expression is escaped\n"
  54             "non-locally, @var{out_guard} is called.  If the continuation of\n"
  55             "the dynamic-wind is re-entered, @var{in_guard} is called.  Thus\n"
  56             "@var{in_guard} and @var{out_guard} may be called any number of\n"
  57             "times.\n"
  58             "@lisp\n"
  59             "(define x 'normal-binding)\n"
  60             "@result{} x\n"
  61             "(define a-cont  (call-with-current-continuation\n"
  62             "             (lambda (escape)\n"
  63             "                (let ((old-x x))\n"
  64             "                  (dynamic-wind\n"
  65             "                     ;; in-guard:\n"
  66             "                     ;;\n"
  67             "                     (lambda () (set! x 'special-binding))\n"
  68             "\n"
  69             "                     ;; thunk\n"
  70             "                     ;;\n"
  71             "                     (lambda () (display x) (newline)\n"
  72             "                                (call-with-current-continuation escape)\n"
  73             "                                (display x) (newline)\n"
  74             "                                x)\n"
  75             "\n"
  76             "                     ;; out-guard:\n"
  77             "                     ;;\n"
  78             "                     (lambda () (set! x old-x)))))))\n"
  79             "\n"
  80             ";; Prints:\n"
  81             "special-binding\n"
  82             ";; Evaluates to:\n"
  83             "@result{} a-cont\n"
  84             "x\n"
  85             "@result{} normal-binding\n"
  86             "(a-cont #f)\n"
  87             ";; Prints:\n"
  88             "special-binding\n"
  89             ";; Evaluates to:\n"
  90             "@result{} a-cont  ;; the value of the (define a-cont...)\n"
  91             "x\n"
  92             "@result{} normal-binding\n"
  93             "a-cont\n"
  94             "@result{} special-binding\n"
  95             "@end lisp")
  96 #define FUNC_NAME s_scm_dynamic_wind
  97 {
  98   SCM ans;
  99   SCM_ASSERT (SCM_NFALSEP (scm_thunk_p (out_guard)),
 100               out_guard,
 101               SCM_ARG3, FUNC_NAME);
 102   scm_call_0 (in_guard);
 103   scm_dynwinds = scm_acons (in_guard, out_guard, scm_dynwinds);
 104   ans = scm_call_0 (thunk);
 105   scm_dynwinds = SCM_CDR (scm_dynwinds);
 106   scm_call_0 (out_guard);
 107   return ans;
 108 }
 109 #undef FUNC_NAME
 110
 111 /* The implementation of a C-callable dynamic-wind,
 112  * scm_internal_dynamic_wind, requires packaging of C pointers in a
 113  * smob.  Objects of this type are pushed onto the dynwind chain.
 114  */
 115
 116 #define SCM_GUARDSP(obj) SCM_TYP16_PREDICATE (tc16_guards, obj)
 117 #define SCM_BEFORE_GUARD(obj) ((scm_t_guard) SCM_CELL_WORD (obj, 1))
 118 #define SCM_AFTER_GUARD(obj) ((scm_t_guard) SCM_CELL_WORD (obj, 2))
 119 #define SCM_GUARD_DATA(obj) ((void *) SCM_CELL_WORD (obj, 3))
 120
 121 static scm_t_bits tc16_guards;
 122
 123 static int
 124 guards_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
 125 {
 126   scm_puts ("#<guards ", port);
 127   scm_intprint (SCM_UNPACK (SCM_CDR (exp)), 16, port);
 128   scm_putc ('>', port);
 129   return 1;
 130 }
 131
 132 SCM
 133 scm_internal_dynamic_wind (scm_t_guard before,
 134                            scm_t_inner inner,
 135                            scm_t_guard after,
 136                            void *inner_data,
 137                            void *guard_data)
 138 {
 139   SCM guards, ans;
 140   before (guard_data);
 141   SCM_NEWSMOB3 (guards, tc16_guards, (scm_t_bits) before,
 142                 (scm_t_bits) after, (scm_t_bits) guard_data);
 143   scm_dynwinds = scm_acons (guards, SCM_BOOL_F, scm_dynwinds);
 144   ans = inner (inner_data);
 145   scm_dynwinds = SCM_CDR (scm_dynwinds);
 146   after (guard_data);
 147   return ans;
 148 }
 149
 150 #ifdef GUILE_DEBUG
 151 SCM_DEFINE (scm_wind_chain, "wind-chain", 0, 0, 0,
 152             (),
 153             "Return the current wind chain. The wind chain contains all\n"
 154             "information required by @code{dynamic-wind} to call its\n"
 155             "argument thunks when entering/exiting its scope.")
 156 #define FUNC_NAME s_scm_wind_chain
 157 {
 158   return scm_dynwinds;
 159 }
 160 #undef FUNC_NAME
 161 #endif
 162
 163 void
 164 scm_swap_bindings (SCM vars, SCM vals)
 165 {
 166   SCM tmp;
 167   while (SCM_NIMP (vals))
 168     {
 169       tmp = SCM_VARIABLE_REF (SCM_CAR (vars));
 170       SCM_VARIABLE_SET (SCM_CAR (vars), SCM_CAR (vals));
 171       SCM_SETCAR (vals, tmp);
 172       vars = SCM_CDR (vars);
 173       vals = SCM_CDR (vals);
 174     }
 175 }
 176
 177 void
 178 scm_dowinds (SCM to, long delta)
 179 {
 180  tail:
 181   if (SCM_EQ_P (to, scm_dynwinds));
 182   else if (delta < 0)
 183     {
 184       SCM wind_elt;
 185       SCM wind_key;
 186
 187       scm_dowinds (SCM_CDR (to), 1 + delta);
 188       wind_elt = SCM_CAR (to);
 189 #if 0
 190       if (SCM_INUMP (wind_elt))
 191         {
 192           scm_cross_dynwind_binding_scope (wind_elt, 0);
 193         }
 194       else
 195 #endif
 196         {
 197           wind_key = SCM_CAR (wind_elt);
 198           /* key = #t | symbol | thunk | list of variables | list of fluids */
 199           if (SCM_NIMP (wind_key))
 200             {
 201               if (SCM_CONSP (wind_key))
 202                 {
 203                   if (SCM_VARIABLEP (SCM_CAR (wind_key)))
 204                     scm_swap_bindings (wind_key, SCM_CDR (wind_elt));
 205                   else if (SCM_FLUIDP (SCM_CAR (wind_key)))
 206                     scm_swap_fluids (wind_key, SCM_CDR (wind_elt));
 207                 }
 208               else if (SCM_GUARDSP (wind_key))
 209                 SCM_BEFORE_GUARD (wind_key) (SCM_GUARD_DATA (wind_key));
 210               else if (SCM_TYP3 (wind_key) == scm_tc3_closure)
 211                 scm_call_0 (wind_key);
 212             }
 213         }
 214       scm_dynwinds = to;
 215     }
 216   else
 217     {
 218       SCM from;
 219       SCM wind_elt;
 220       SCM wind_key;
 221
 222       from = SCM_CDR (SCM_CAR (scm_dynwinds));
 223       wind_elt = SCM_CAR (scm_dynwinds);
 224       scm_dynwinds = SCM_CDR (scm_dynwinds);
 225 #if 0
 226       if (SCM_INUMP (wind_elt))
 227         {
 228           scm_cross_dynwind_binding_scope (wind_elt, 0);
 229         }
 230       else
 231 #endif
 232         {
 233           wind_key = SCM_CAR (wind_elt);
 234           if (SCM_NIMP (wind_key))
 235             {
 236               if (SCM_CONSP (wind_key))
 237                 {
 238                   if (SCM_VARIABLEP (SCM_CAR (wind_key)))
 239                     scm_swap_bindings (wind_key, SCM_CDR (wind_elt));
 240                   else if (SCM_FLUIDP (SCM_CAR (wind_key)))
 241                     scm_swap_fluids_reverse (wind_key, SCM_CDR (wind_elt));
 242                 }
 243               else if (SCM_GUARDSP (wind_key))
 244                 SCM_AFTER_GUARD (wind_key) (SCM_GUARD_DATA (wind_key));
 245               else if (SCM_TYP3 (wind_key) == scm_tc3_closure)
 246                 scm_call_0 (from);
 247             }
 248         }
 249       delta--;
 250       goto tail;                /* scm_dowinds(to, delta-1); */
 251     }
 252 }
 253
 254
 255
 256 void
 257 scm_init_dynwind ()
 258 {
 259   tc16_guards = scm_make_smob_type ("guards", 0);
 260   scm_set_smob_print (tc16_guards, guards_print);
 261 #include "libguile/dynwind.x"
 262 }
 263
 264 /*
 265   Local Variables:
 266   c-file-style: "gnu"
 267   End:
 268 */