libguile/dynwind.c

   1 /* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2008, 2010, 2011, 2012 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/dynstack.h"
  30 #include "libguile/eval.h"
  31 #include "libguile/ports.h"
  32
  33 #include "libguile/dynwind.h"
  34
  35
  36 \f
  37
  38 SCM
  39 scm_dynamic_wind (SCM in_guard, SCM thunk, SCM out_guard)
  40 #define FUNC_NAME "dynamic-wind"
  41 {
  42   SCM ans;
  43   scm_i_thread *thread = SCM_I_CURRENT_THREAD;
  44
  45   SCM_ASSERT (scm_is_true (scm_thunk_p (out_guard)), out_guard,
  46               SCM_ARG3, FUNC_NAME);
  47
  48   scm_call_0 (in_guard);
  49   scm_dynstack_push_dynwind (&thread->dynstack, in_guard, out_guard);
  50
  51   ans = scm_call_0 (thunk);
  52
  53   scm_dynstack_pop (&thread->dynstack);
  54   scm_call_0 (out_guard);
  55
  56   return ans;
  57 }
  58 #undef FUNC_NAME
  59
  60
  61 void
  62 scm_dynwind_begin (scm_t_dynwind_flags flags)
  63 {
  64   scm_i_thread *thread = SCM_I_CURRENT_THREAD;
  65
  66   scm_dynstack_push_frame (&thread->dynstack, flags);
  67 }
  68
  69 void
  70 scm_dynwind_end (void)
  71 {
  72   scm_dynstack_unwind_frame (&SCM_I_CURRENT_THREAD->dynstack);
  73 }
  74
  75 void
  76 scm_dynwind_unwind_handler (void (*proc) (void *), void *data,
  77                             scm_t_wind_flags flags)
  78 {
  79   scm_i_thread *thread = SCM_I_CURRENT_THREAD;
  80   scm_t_dynstack *dynstack = &thread->dynstack;
  81
  82   scm_dynstack_push_unwinder (dynstack, flags, proc, data);
  83 }
  84
  85 void
  86 scm_dynwind_rewind_handler (void (*proc) (void *), void *data,
  87                             scm_t_wind_flags flags)
  88 {
  89   scm_i_thread *thread = SCM_I_CURRENT_THREAD;
  90   scm_t_dynstack *dynstack = &thread->dynstack;
  91
  92   scm_dynstack_push_rewinder (dynstack, 0, proc, data);
  93
  94   if (flags & SCM_F_WIND_EXPLICITLY)
  95     proc (data);
  96 }
  97
  98 void
  99 scm_dynwind_unwind_handler_with_scm (void (*proc) (SCM), SCM data,
 100                                      scm_t_wind_flags flags)
 101 {
 102   /* FIXME: This is not a safe cast.  */
 103   scm_dynwind_unwind_handler ((scm_t_guard) proc, SCM2PTR (data), flags);
 104 }
 105
 106 void
 107 scm_dynwind_rewind_handler_with_scm (void (*proc) (SCM), SCM data,
 108                                      scm_t_wind_flags flags)
 109 {
 110   /* FIXME: This is not a safe cast.  */
 111   scm_dynwind_rewind_handler ((scm_t_guard) proc, SCM2PTR (data), flags);
 112 }
 113
 114 void
 115 scm_dynwind_free (void *mem)
 116 {
 117   scm_dynwind_unwind_handler (free, mem, SCM_F_WIND_EXPLICITLY);
 118 }
 119
 120 void
 121 scm_swap_bindings (SCM vars, SCM vals)
 122 {
 123   SCM tmp;
 124   while (scm_is_pair (vals))
 125     {
 126       tmp = SCM_VARIABLE_REF (SCM_CAR (vars));
 127       SCM_VARIABLE_SET (SCM_CAR (vars), SCM_CAR (vals));
 128       SCM_SETCAR (vals, tmp);
 129       vars = SCM_CDR (vars);
 130       vals = SCM_CDR (vals);
 131     }
 132 }
 133
 134 void
 135 scm_init_dynwind ()
 136 {
 137 #include "libguile/dynwind.x"
 138 }
 139
 140 /*
 141   Local Variables:
 142   c-file-style: "gnu"
 143   End:
 144 */