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