libguile/throw.c

   1 /*      Copyright (C) 1995,1996 Free Software Foundation, Inc.
   2  *
   3  * This program is free software; you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation; either version 2, or (at your option)
   6  * any later version.
   7  *
   8  * This program 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
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this software; see the file COPYING.  If not, write to
  15  * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  16  *
  17  * As a special exception, the Free Software Foundation gives permission
  18  * for additional uses of the text contained in its release of GUILE.
  19  *
  20  * The exception is that, if you link the GUILE library with other files
  21  * to produce an executable, this does not by itself cause the
  22  * resulting executable to be covered by the GNU General Public License.
  23  * Your use of that executable is in no way restricted on account of
  24  * linking the GUILE library code into it.
  25  *
  26  * This exception does not however invalidate any other reasons why
  27  * the executable file might be covered by the GNU General Public License.
  28  *
  29  * This exception applies only to the code released by the
  30  * Free Software Foundation under the name GUILE.  If you copy
  31  * code from other Free Software Foundation releases into a copy of
  32  * GUILE, as the General Public License permits, the exception does
  33  * not apply to the code that you add in this way.  To avoid misleading
  34  * anyone as to the status of such modified files, you must delete
  35  * this exception notice from them.
  36  *
  37  * If you write modifications of your own for GUILE, it is your choice
  38  * whether to permit this exception to apply to your modifications.
  39  * If you do not wish that, delete this exception notice.
  40  */
  41 \f
  42
  43 #include <stdio.h>
  44 #include "_scm.h"
  45
  46 \f
  47
  48
  49 /* {Catch and Throw}
  50  */
  51 static int scm_tc16_jmpbuffer;
  52
  53 SCM scm_bad_throw_vcell;
  54
  55 #define SCM_JMPBUFP(O) (SCM_TYP16(O) == scm_tc16_jmpbuffer)
  56 #define JBACTIVE(O) (SCM_CAR (O) & (1L << 16L))
  57 #define ACTIVATEJB(O)  (SCM_CAR (O) |= (1L << 16L))
  58 #define DEACTIVATEJB(O)  (SCM_CAR (O) &= ~(1L << 16L))
  59
  60 #ifdef DEBUG_EXTENSIONS
  61 #define JBSCM_DFRAME(O) ((debug_frame*)SCM_CAR (SCM_CDR (O)) )
  62 #define JBJMPBUF(O) ((jmp_buf*)SCM_CDR (SCM_CDR (O)) )
  63 #define SETJBSCM_DFRAME(O,X) SCM_CAR(SCM_CDR (O)) = (SCM)(X)
  64 #define SETJBJMPBUF(O,X) SCM_SETCDR(SCM_CDR (O), X)
  65 #else
  66 #define JBJMPBUF(O) ((jmp_buf*)SCM_CDR (O) )
  67 #define SETJBJMPBUF SCM_SETCDR
  68 #endif
  69
  70 #ifdef __STDC__
  71 static int
  72 printjb (SCM exp, SCM port, int writing)
  73 #else
  74 static int
  75 printjb (exp, port, writing)
  76      SCM exp;
  77      SCM port;
  78      int writing;
  79 #endif
  80 {
  81   scm_gen_puts (scm_regular_string, "#<jmpbuffer ", port);
  82   scm_gen_puts (scm_regular_string, JBACTIVE(exp) ? "(active) " : "(inactive) ", port);
  83   scm_intprint((SCM) JBJMPBUF(exp), 16, port);
  84   scm_gen_putc ('>', port);
  85   return 1 ;
  86 }
  87
  88 /* !!! The mark function needs to be different for
  89  * debugging support.           A. Green
  90  */
  91 static scm_smobfuns jbsmob = {scm_mark0, scm_free0, printjb, 0};
  92
  93 #ifdef __STDC__
  94 static SCM
  95 make_jmpbuf (void)
  96 #else
  97 static SCM
  98 make_jmpbuf ()
  99 #endif
 100 {
 101   SCM answer;
 102   SCM_NEWCELL (answer);
 103 #ifdef DEBUG_EXTENSIONS
 104   SCM_NEWCELL (SCM_CDR (answer));
 105 #endif
 106   SCM_DEFER_INTS;
 107   {
 108     SCM_CAR(answer) = scm_tc16_jmpbuffer;
 109     SETJBJMPBUF(answer, (jmp_buf *)0);
 110     DEACTIVATEJB(answer);
 111   }
 112   SCM_ALLOW_INTS;
 113   return answer;
 114 }
 115
 116
 117 struct jmp_buf_and_retval       /* use only on the stack, in scm_catch */
 118 {
 119   jmp_buf buf;                  /* must be first */
 120   SCM throw_tag;
 121   SCM retval;
 122 };
 123
 124 SCM_PROC(s_catch, "catch", 3, 0, 0, scm_catch);
 125 #ifdef __STDC__
 126 SCM
 127 scm_catch (SCM tag, SCM thunk, SCM handler)
 128 #else
 129 SCM
 130 scm_catch (tag, thunk, handler)
 131      SCM tag;
 132      SCM thunk;
 133      SCM handler;
 134 #endif
 135 {
 136   struct jmp_buf_and_retval jbr;
 137   SCM jmpbuf;
 138   SCM answer;
 139
 140   SCM_ASSERT ((tag == SCM_BOOL_F) || (SCM_NIMP(tag) && SCM_SYMBOLP(tag)) || (tag == SCM_BOOL_T),
 141           tag, SCM_ARG1, s_catch);
 142   jmpbuf = make_jmpbuf ();
 143   answer = SCM_EOL;
 144   scm_dynwinds = scm_acons (tag, jmpbuf, scm_dynwinds);
 145   SETJBJMPBUF(jmpbuf, &jbr.buf);
 146 #ifdef DEBUG_EXTENSIONS
 147   SETJBSCM_DFRAME(jmpbuf, last_debug_info_frame);
 148 #endif
 149   if (setjmp (jbr.buf))
 150     {
 151       SCM throw_tag;
 152       SCM throw_args;
 153
 154       SCM_DEFER_INTS;
 155       DEACTIVATEJB (jmpbuf);
 156       scm_dynwinds = SCM_CDR (scm_dynwinds);
 157       SCM_ALLOW_INTS;
 158       throw_args = jbr.retval;
 159       throw_tag = jbr.throw_tag;
 160       jbr.throw_tag = SCM_EOL;
 161       jbr.retval = SCM_EOL;
 162       answer = scm_apply (handler, scm_cons (throw_tag, throw_args), SCM_EOL);
 163     }
 164   else
 165     {
 166       ACTIVATEJB (jmpbuf);
 167       answer = scm_apply (thunk,
 168                           ((tag == SCM_BOOL_F) ? scm_cons (jmpbuf, SCM_EOL) : SCM_EOL),
 169                           SCM_EOL);
 170       SCM_DEFER_INTS;
 171       DEACTIVATEJB (jmpbuf);
 172       scm_dynwinds = SCM_CDR (scm_dynwinds);
 173       SCM_ALLOW_INTS;
 174     }
 175   return answer;
 176 }
 177
 178
 179 static char s_throw[];
 180 #ifdef __STDC__
 181 SCM
 182 scm_ithrow (SCM key, SCM args, int noreturn)
 183 #else
 184 SCM
 185 scm_ithrow (key, args, noreturn)
 186      SCM key;
 187      SCM args;
 188      int noreturn;
 189 #endif
 190 {
 191   SCM jmpbuf;
 192   SCM wind_goal;
 193
 194   if (SCM_NIMP (key) && SCM_JMPBUFP (key))
 195     {
 196       jmpbuf = key;
 197       if (noreturn)
 198         {
 199           SCM_ASSERT (JBACTIVE (jmpbuf), jmpbuf,
 200                   "throw to dynamically inactive catch",
 201                   s_throw);
 202         }
 203       else if (!JBACTIVE (jmpbuf))
 204         return SCM_UNSPECIFIED;
 205     }
 206   else
 207     {
 208       SCM dynpair;
 209       SCM hook;
 210
 211       if (noreturn)
 212         {
 213           SCM_ASSERT (SCM_NIMP (key) && SCM_SYMBOLP (key), key, SCM_ARG1, s_throw);
 214         }
 215       else if (!(SCM_NIMP (key) && SCM_SYMBOLP (key)))
 216         return SCM_UNSPECIFIED;
 217
 218       dynpair = scm_sloppy_assq (key, scm_dynwinds);
 219
 220       if (dynpair == SCM_BOOL_F)
 221         dynpair = scm_sloppy_assq (SCM_BOOL_T, scm_dynwinds);
 222
 223       hook = SCM_CDR (scm_bad_throw_vcell);
 224       if ((dynpair == SCM_BOOL_F)
 225           && (SCM_BOOL_T == scm_procedure_p (hook)))
 226         {
 227           SCM answer;
 228           answer = scm_apply (hook, scm_cons (key, args), SCM_EOL);
 229         }
 230
 231       if (dynpair != SCM_BOOL_F)
 232         jmpbuf = SCM_CDR (dynpair);
 233       else
 234         {
 235           if (!noreturn)
 236             return SCM_UNSPECIFIED;
 237           else
 238             {
 239               scm_exitval = scm_cons (key, args);
 240               scm_dowinds (SCM_EOL, scm_ilength (scm_dynwinds));
 241               longjmp (SCM_JMPBUF (scm_rootcont), 1);
 242             }
 243         }
 244     }
 245 #ifdef DEBUG_EXTENSIONS
 246   last_debug_info_frame = JBSCM_DFRAME (jmpbuf);
 247 #endif
 248   for (wind_goal = scm_dynwinds;
 249        SCM_CDAR (wind_goal) != jmpbuf;
 250        wind_goal = SCM_CDR (wind_goal))
 251     ;
 252   {
 253     struct jmp_buf_and_retval * jbr;
 254     jbr = (struct jmp_buf_and_retval *)JBJMPBUF (jmpbuf);
 255     jbr->throw_tag = key;
 256     jbr->retval = args;
 257   }
 258   scm_dowinds (wind_goal, scm_ilength (scm_dynwinds) - scm_ilength (wind_goal));
 259   longjmp (*JBJMPBUF (jmpbuf), 1);
 260 }
 261
 262
 263 SCM_PROC(s_throw, "throw", 1, 0, 1, scm_throw);
 264 #ifdef __STDC__
 265 SCM
 266 scm_throw (SCM key, SCM args)
 267 #else
 268 SCM
 269 scm_throw (key, args)
 270      SCM key;
 271      SCM args;
 272 #endif
 273 {
 274   scm_ithrow (key, args, 1);
 275   return SCM_BOOL_F;  /* never really returns */
 276 }
 277
 278
 279 #ifdef __STDC__
 280 void
 281 scm_init_throw (void)
 282 #else
 283 void
 284 scm_init_throw ()
 285 #endif
 286 {
 287   scm_tc16_jmpbuffer = scm_newsmob (&jbsmob);
 288   scm_bad_throw_vcell = scm_sysintern ("%%bad-throw", SCM_BOOL_F);
 289 #include "throw.x"
 290 }
 291