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 #ifndef DEBUG_EXTENSIONS
  61 #define JBJMPBUF(O) ((jmp_buf*)SCM_CDR (O) )
  62 #define SETJBJMPBUF SCM_SETCDR
  63 #else
  64 #define JBSCM_DFRAME(O) ((scm_debug_frame*)SCM_CAR (SCM_CDR (O)) )
  65 #define JBJMPBUF(O) ((jmp_buf*)SCM_CDR (SCM_CDR (O)) )
  66 #define SETJBSCM_DFRAME(O,X) SCM_CAR(SCM_CDR (O)) = (SCM)(X)
  67 #define SETJBJMPBUF(O,X) SCM_SETCDR(SCM_CDR (O), X)
  68
  69 #ifdef __STDC__
  70 static scm_sizet
  71 freejb (SCM jbsmob)
  72 #else
  73 static scm_sizet
  74 freejb (jbsmob)
  75      SCM jbsmob;
  76 #endif
  77 {
  78   scm_must_free ((char *) SCM_CDR (jbsmob));
  79   return sizeof (scm_cell);
  80 }
  81 #endif
  82
  83 #ifdef __STDC__
  84 static int
  85 printjb (SCM exp, SCM port, int writing)
  86 #else
  87 static int
  88 printjb (exp, port, writing)
  89      SCM exp;
  90      SCM port;
  91      int writing;
  92 #endif
  93 {
  94   scm_gen_puts (scm_regular_string, "#<jmpbuffer ", port);
  95   scm_gen_puts (scm_regular_string, JBACTIVE(exp) ? "(active) " : "(inactive) ", port);
  96   scm_intprint((SCM) JBJMPBUF(exp), 16, port);
  97   scm_gen_putc ('>', port);
  98   return 1 ;
  99 }
 100
 101 static scm_smobfuns jbsmob = {
 102   scm_mark0,
 103 #ifdef DEBUG_EXTENSIONS
 104   freejb,
 105 #else
 106   scm_free0,
 107 #endif
 108   printjb,
 109   0
 110 };
 111
 112 #ifdef __STDC__
 113 static SCM
 114 make_jmpbuf (void)
 115 #else
 116 static SCM
 117 make_jmpbuf ()
 118 #endif
 119 {
 120   SCM answer;
 121   SCM_NEWCELL (answer);
 122   SCM_DEFER_INTS;
 123   {
 124 #ifdef DEBUG_EXTENSIONS
 125     char *mem = scm_must_malloc (sizeof (scm_cell), "jb");
 126     SCM_SETCDR (answer, (SCM) mem);
 127 #endif
 128     SCM_CAR(answer) = scm_tc16_jmpbuffer;
 129     SETJBJMPBUF(answer, (jmp_buf *)0);
 130     DEACTIVATEJB(answer);
 131   }
 132   SCM_ALLOW_INTS;
 133   return answer;
 134 }
 135
 136
 137 struct jmp_buf_and_retval       /* use only on the stack, in scm_catch */
 138 {
 139   jmp_buf buf;                  /* must be first */
 140   SCM throw_tag;
 141   SCM retval;
 142 };
 143
 144 SCM_PROC(s_catch, "catch", 3, 0, 0, scm_catch);
 145 #ifdef __STDC__
 146 SCM
 147 scm_catch (SCM tag, SCM thunk, SCM handler)
 148 #else
 149 SCM
 150 scm_catch (tag, thunk, handler)
 151      SCM tag;
 152      SCM thunk;
 153      SCM handler;
 154 #endif
 155 {
 156   struct jmp_buf_and_retval jbr;
 157   SCM jmpbuf;
 158   SCM answer;
 159
 160   SCM_ASSERT ((tag == SCM_BOOL_F) || (SCM_NIMP(tag) && SCM_SYMBOLP(tag)) || (tag == SCM_BOOL_T),
 161           tag, SCM_ARG1, s_catch);
 162   jmpbuf = make_jmpbuf ();
 163   answer = SCM_EOL;
 164   scm_dynwinds = scm_acons (tag, jmpbuf, scm_dynwinds);
 165   SETJBJMPBUF(jmpbuf, &jbr.buf);
 166 #ifdef DEBUG_EXTENSIONS
 167   SETJBSCM_DFRAME(jmpbuf, last_debug_info_frame);
 168 #endif
 169   if (setjmp (jbr.buf))
 170     {
 171       SCM throw_tag;
 172       SCM throw_args;
 173
 174       SCM_DEFER_INTS;
 175       DEACTIVATEJB (jmpbuf);
 176       scm_dynwinds = SCM_CDR (scm_dynwinds);
 177       SCM_ALLOW_INTS;
 178       throw_args = jbr.retval;
 179       throw_tag = jbr.throw_tag;
 180       jbr.throw_tag = SCM_EOL;
 181       jbr.retval = SCM_EOL;
 182       answer = scm_apply (handler, scm_cons (throw_tag, throw_args), SCM_EOL);
 183     }
 184   else
 185     {
 186       ACTIVATEJB (jmpbuf);
 187       answer = scm_apply (thunk,
 188                           ((tag == SCM_BOOL_F) ? scm_cons (jmpbuf, SCM_EOL) : SCM_EOL),
 189                           SCM_EOL);
 190       SCM_DEFER_INTS;
 191       DEACTIVATEJB (jmpbuf);
 192       scm_dynwinds = SCM_CDR (scm_dynwinds);
 193       SCM_ALLOW_INTS;
 194     }
 195   return answer;
 196 }
 197
 198
 199 static char s_throw[];
 200 #ifdef __STDC__
 201 SCM
 202 scm_ithrow (SCM key, SCM args, int noreturn)
 203 #else
 204 SCM
 205 scm_ithrow (key, args, noreturn)
 206      SCM key;
 207      SCM args;
 208      int noreturn;
 209 #endif
 210 {
 211   SCM jmpbuf;
 212   SCM wind_goal;
 213
 214   if (SCM_NIMP (key) && SCM_JMPBUFP (key))
 215     {
 216       jmpbuf = key;
 217       if (noreturn)
 218         {
 219           SCM_ASSERT (JBACTIVE (jmpbuf), jmpbuf,
 220                   "throw to dynamically inactive catch",
 221                   s_throw);
 222         }
 223       else if (!JBACTIVE (jmpbuf))
 224         return SCM_UNSPECIFIED;
 225     }
 226   else
 227     {
 228       SCM dynpair;
 229       SCM hook;
 230
 231       if (noreturn)
 232         {
 233           SCM_ASSERT (SCM_NIMP (key) && SCM_SYMBOLP (key), key, SCM_ARG1, s_throw);
 234         }
 235       else if (!(SCM_NIMP (key) && SCM_SYMBOLP (key)))
 236         return SCM_UNSPECIFIED;
 237
 238       dynpair = scm_sloppy_assq (key, scm_dynwinds);
 239
 240       if (dynpair == SCM_BOOL_F)
 241         dynpair = scm_sloppy_assq (SCM_BOOL_T, scm_dynwinds);
 242
 243       hook = SCM_CDR (scm_bad_throw_vcell);
 244       if ((dynpair == SCM_BOOL_F)
 245           && (SCM_BOOL_T == scm_procedure_p (hook)))
 246         {
 247           SCM answer;
 248           answer = scm_apply (hook, scm_cons (key, args), SCM_EOL);
 249         }
 250
 251       if (dynpair != SCM_BOOL_F)
 252         jmpbuf = SCM_CDR (dynpair);
 253       else
 254         {
 255           if (!noreturn)
 256             return SCM_UNSPECIFIED;
 257           else
 258             {
 259               scm_exitval = scm_cons (key, args);
 260               scm_dowinds (SCM_EOL, scm_ilength (scm_dynwinds));
 261 #ifdef DEBUG_EXTENSIONS
 262               last_debug_info_frame = SCM_DFRAME (scm_rootcont);
 263 #endif
 264               longjmp (SCM_JMPBUF (scm_rootcont), 1);
 265             }
 266         }
 267     }
 268   for (wind_goal = scm_dynwinds;
 269        SCM_CDAR (wind_goal) != jmpbuf;
 270        wind_goal = SCM_CDR (wind_goal))
 271     ;
 272   {
 273     struct jmp_buf_and_retval * jbr;
 274     jbr = (struct jmp_buf_and_retval *)JBJMPBUF (jmpbuf);
 275     jbr->throw_tag = key;
 276     jbr->retval = args;
 277   }
 278   scm_dowinds (wind_goal, scm_ilength (scm_dynwinds) - scm_ilength (wind_goal));
 279 #ifdef DEBUG_EXTENSIONS
 280   last_debug_info_frame = JBSCM_DFRAME (jmpbuf);
 281 #endif
 282   longjmp (*JBJMPBUF (jmpbuf), 1);
 283 }
 284
 285
 286 SCM_PROC(s_throw, "throw", 1, 0, 1, scm_throw);
 287 #ifdef __STDC__
 288 SCM
 289 scm_throw (SCM key, SCM args)
 290 #else
 291 SCM
 292 scm_throw (key, args)
 293      SCM key;
 294      SCM args;
 295 #endif
 296 {
 297   scm_ithrow (key, args, 1);
 298   return SCM_BOOL_F;  /* never really returns */
 299 }
 300
 301
 302 #ifdef __STDC__
 303 void
 304 scm_init_throw (void)
 305 #else
 306 void
 307 scm_init_throw ()
 308 #endif
 309 {
 310   scm_tc16_jmpbuffer = scm_newsmob (&jbsmob);
 311   scm_bad_throw_vcell = scm_sysintern ("%%bad-throw", SCM_BOOL_F);
 312 #include "throw.x"
 313 }
 314