libguile/continuations.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 /* {Continuations}
  49  */
  50
  51 static char s_cont[] = "continuation";
  52
  53 #ifdef __STDC__
  54 SCM
  55 scm_make_cont (SCM * answer)
  56 #else
  57 SCM
  58 scm_make_cont (answer)
  59      SCM * answer;
  60 #endif
  61 {
  62   long j;
  63   SCM cont;
  64
  65 #ifdef CHEAP_CONTINUATIONS
  66   SCM_NEWCELL (cont);
  67   *answer = cont;
  68   SCM_DEFER_INTS;
  69   SCM_SETJMPBUF (cont, scm_must_malloc ((long) sizeof (regs), s_cont));
  70   SCM_CAR (cont) = scm_tc7_contin;
  71   SCM_DYNENV (cont) = scm_dynwinds;
  72   SCM_THROW_VALUE = SCM_EOL;
  73   SCM_BASE (cont) = SCM_BASE (rootcont);
  74   SCM_SEQ (cont) = SCM_SEQ (rootcont);
  75   SCM_ALLOW_INTS;
  76 #else
  77   register SCM_STACKITEM *src, *dst;
  78
  79 #if 0
  80   {
  81     SCM winds;
  82
  83     for (winds = scm_dynwinds; winds != SCM_EOL; winds = SCM_CDR (winds))
  84       {
  85         if (SCM_INUMP (SCM_CAR (winds)))
  86           {
  87             scm_relocate_chunk_to_heap (SCM_CAR (winds));
  88           }
  89       }
  90   }
  91 #endif
  92
  93   SCM_NEWCELL (cont);
  94   *answer = cont;
  95   SCM_DEFER_INTS;
  96   SCM_FLUSH_REGISTER_WINDOWS;
  97   j = scm_stack_size (SCM_BASE (scm_rootcont));
  98   SCM_SETJMPBUF (cont,
  99              scm_must_malloc ((long) (sizeof (regs) + j * sizeof (SCM_STACKITEM)),
 100                               s_cont));
 101   SCM_SETLENGTH (cont, j, scm_tc7_contin);
 102   SCM_DYNENV (cont) = scm_dynwinds;
 103   SCM_THROW_VALUE (cont) = SCM_EOL;
 104   src = SCM_BASE (cont) = SCM_BASE (scm_rootcont);
 105   SCM_SEQ (cont) = SCM_SEQ (scm_rootcont);
 106   SCM_ALLOW_INTS;
 107 #ifndef SCM_STACK_GROWS_UP
 108   src -= SCM_LENGTH (cont);
 109 #endif /* ndef SCM_STACK_GROWS_UP */
 110   dst = (SCM_STACKITEM *) (SCM_CHARS (cont) + sizeof (regs));
 111   for (j = SCM_LENGTH (cont); 0 <= --j;)
 112     *dst++ = *src++;
 113 #endif /* def CHEAP_CONTINUATIONS */
 114 #ifdef DEBUG_EXTENSIONS
 115   SCM_DFRAME (cont) = last_debug_info_frame;
 116 #endif
 117   return cont;
 118 }
 119
 120
 121 void scm_dynthrow SCM_P ((SCM *a));
 122
 123 /* Grow the stack so that there is room */
 124 /* to copy in the continuation.  Then */
 125 #ifndef CHEAP_CONTINUATIONS
 126 #ifdef __STDC__
 127 static void
 128 grow_throw (SCM *a)
 129 #else
 130 static void
 131 grow_throw (a)
 132      SCM *a;
 133 #endif
 134 {                               /* retry the throw. */
 135   SCM growth[100];
 136   growth[0] = a[0];
 137   growth[1] = a[1];
 138   growth[2] = a[2] + 1;
 139   growth[3] = (SCM) a;
 140   scm_dynthrow (growth);
 141 }
 142 #endif /* ndef CHEAP_CONTINUATIONS */
 143
 144 #ifdef __STDC__
 145 void
 146 scm_dynthrow (SCM *a)
 147 #else
 148 void
 149 scm_dynthrow (a)
 150      SCM *a;
 151 #endif
 152 {
 153   SCM cont = a[0], val = a[1];
 154 #ifndef CHEAP_CONTINUATIONS
 155   register long j;
 156   register SCM_STACKITEM *src, *dst = SCM_BASE (scm_rootcont);
 157 #ifdef SCM_STACK_GROWS_UP
 158   if (a[2] && (a - ((SCM *) a[3]) < 100))
 159 #else
 160   if (a[2] && (((SCM *) a[3]) - a < 100))
 161 #endif
 162     fputs ("grow_throw: check if SCM growth[100]; being optimized out\n",
 163            stderr);
 164   /* if (a[2]) fprintf(stderr, " ct = %ld, dist = %ld\n",
 165                           a[2], (((SCM *)a[3]) - a)); */
 166 #ifdef SCM_STACK_GROWS_UP
 167   if (SCM_PTR_GE (dst + SCM_LENGTH (cont), (SCM_STACKITEM *) & a))
 168     grow_throw (a);
 169 #else
 170   dst -= SCM_LENGTH (cont);
 171   if (SCM_PTR_LE (dst, (SCM_STACKITEM *) & a))
 172     grow_throw (a);
 173 #endif /* def SCM_STACK_GROWS_UP */
 174   SCM_FLUSH_REGISTER_WINDOWS;
 175   src = (SCM_STACKITEM *) (SCM_CHARS (cont) + sizeof (regs));
 176   for (j = SCM_LENGTH (cont); 0 <= --j;)
 177     *dst++ = *src++;
 178 #ifdef sparc                    /* clear out stack up to this stackframe */
 179   /* maybe this would help, maybe not */
 180 /*      bzero((void *)&a, sizeof(SCM_STACKITEM) * (((SCM_STACKITEM *)&a) -
 181                                                (dst - SCM_LENGTH(cont)))) */
 182 #endif
 183 #endif /* ndef CHEAP_CONTINUATIONS */
 184 #ifdef DEBUG_EXTENSIONS
 185   last_debug_info_frame = SCM_DFRAME (cont);
 186 #endif
 187   SCM_THROW_VALUE(cont) = val;
 188   longjmp (SCM_JMPBUF (cont), 1);
 189 }
 190
 191 #ifdef __STDC__
 192 SCM
 193 scm_call_continuation (SCM cont, SCM val)
 194 #else
 195 SCM
 196 scm_call_continuation (cont, val)
 197      SCM cont;
 198      SCM val;
 199 #endif
 200 {
 201   SCM a[3];
 202   a[0] = cont;
 203   a[1] = val;
 204   a[2] = 0;
 205   if (   (SCM_SEQ (cont) != SCM_SEQ (scm_rootcont))
 206       || (SCM_BASE (cont) != SCM_BASE (scm_rootcont)))  /* base compare not needed */
 207     scm_wta (cont, "continuation from wrong top level", s_cont);
 208
 209   scm_dowinds (SCM_DYNENV (cont),
 210                scm_ilength (scm_dynwinds) - scm_ilength (SCM_DYNENV (cont)));
 211
 212   scm_dynthrow (a);
 213   return SCM_UNSPECIFIED; /* not reached */
 214 }
 215
 216
 217 #ifdef __STDC__
 218 void
 219 scm_init_continuations (void)
 220 #else
 221 void
 222 scm_init_continuations ()
 223 #endif
 224 {
 225 #include "continuations.x"
 226 }
 227