* Made scm_dynthrow static.
[bpt/guile.git] / libguile / continuations.c
1 /* Copyright (C) 1995,1996,1998 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, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
17 *
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
20 *
21 * The exception is that, if you link the GUILE library with other files
22 * to produce an executable, this does not by itself cause the
23 * resulting executable to be covered by the GNU General Public License.
24 * Your use of that executable is in no way restricted on account of
25 * linking the GUILE library code into it.
26 *
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
29 *
30 * This exception applies only to the code released by the
31 * Free Software Foundation under the name GUILE. If you copy
32 * code from other Free Software Foundation releases into a copy of
33 * GUILE, as the General Public License permits, the exception does
34 * not apply to the code that you add in this way. To avoid misleading
35 * anyone as to the status of such modified files, you must delete
36 * this exception notice from them.
37 *
38 * If you write modifications of your own for GUILE, it is your choice
39 * whether to permit this exception to apply to your modifications.
40 * If you do not wish that, delete this exception notice. */
41
42 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
43 gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
44
45 \f
46
47 #include <stdio.h>
48 #include "_scm.h"
49 #include "root.h"
50 #include "stackchk.h"
51 #ifdef DEBUG_EXTENSIONS
52 #include "debug.h"
53 #endif
54 #include "dynwind.h"
55
56 #include "continuations.h"
57
58 \f
59
60 /* {Continuations}
61 */
62
63 static char s_cont[] = "continuation";
64
65 static void scm_dynthrow (SCM, SCM);
66
67
68 #ifndef CHEAP_CONTINUATIONS
69
70
71 SCM
72 scm_make_cont (SCM *answer)
73 {
74 long j;
75 SCM cont;
76 SCM_STACKITEM * src;
77 SCM_STACKITEM * dst;
78
79 SCM_NEWCELL (cont);
80 *answer = cont;
81 SCM_ENTER_A_SECTION;
82 SCM_FLUSH_REGISTER_WINDOWS;
83 j = scm_stack_size (SCM_BASE (scm_rootcont));
84 SCM_SET_CONTREGS (cont,
85 scm_must_malloc (sizeof (scm_contregs)
86 + j * sizeof (SCM_STACKITEM),
87 s_cont));
88 SCM_DYNENV (cont) = scm_dynwinds;
89 SCM_THROW_VALUE (cont) = SCM_EOL;
90 src = SCM_BASE (cont) = SCM_BASE (scm_rootcont);
91 SCM_SEQ (cont) = SCM_SEQ (scm_rootcont);
92 SCM_SETLENGTH (cont, j, scm_tc7_contin);
93 SCM_EXIT_A_SECTION;
94 #ifndef SCM_STACK_GROWS_UP
95 src -= SCM_LENGTH (cont);
96 #endif /* ndef SCM_STACK_GROWS_UP */
97 dst = (SCM_STACKITEM *) (SCM_CHARS (cont) + sizeof (scm_contregs));
98
99 /* memcpy should be safe: src and dst will never overlap */
100 memcpy (dst, src, sizeof (SCM_STACKITEM) * SCM_LENGTH (cont));
101
102 #ifdef DEBUG_EXTENSIONS
103 SCM_DFRAME (cont) = scm_last_debug_frame;
104 #endif
105
106 return cont;
107 }
108
109
110 /* Grow the stack by a fixed amount to provide space to copy in the
111 * continuation. Possibly this function has to be called several times
112 * recursively before enough space is available. Make sure the compiler does
113 * not optimize the growth array away by storing it's address into a global
114 * variable.
115 */
116
117 scm_bits_t scm_i_dummy;
118
119 static void
120 grow_stack (SCM cont, SCM val)
121 {
122 scm_bits_t growth[100];
123
124 scm_i_dummy = (scm_bits_t) growth;
125 scm_dynthrow (cont, val);
126 }
127
128
129 /* Copy the continuation stack into the current stack. Calling functions from
130 * within this function is safe, since only stack frames below this function's
131 * own frame are overwritten. Thus, memcpy can be used for best performance.
132 */
133 static void
134 copy_stack_and_call (SCM cont, SCM val,
135 SCM_STACKITEM * src, SCM_STACKITEM * dst)
136 {
137 /* memcpy should be safe: src and dst will never overlap */
138 memcpy (dst, src, sizeof (SCM_STACKITEM) * SCM_LENGTH (cont));
139
140 #ifdef DEBUG_EXTENSIONS
141 scm_last_debug_frame = SCM_DFRAME (cont);
142 #endif
143
144 SCM_THROW_VALUE (cont) = val;
145 longjmp (SCM_JMPBUF (cont), 1);
146 }
147
148
149 /* Call grow_stack until the stack space is large enough, then, as the current
150 * stack frame might get overwritten, let copy_stack_and_call perform the
151 * actual copying and continuation calling.
152 */
153 static void
154 scm_dynthrow (SCM cont, SCM val)
155 {
156 SCM_STACKITEM * src;
157 SCM_STACKITEM * dst = SCM_BASE (scm_rootcont);
158 SCM_STACKITEM stack_top_element;
159
160 #ifdef SCM_STACK_GROWS_UP
161 if (SCM_PTR_GE (dst + SCM_LENGTH (cont), & stack_top_element))
162 grow_stack (cont, val);
163 #else
164 dst -= SCM_LENGTH (cont);
165 if (SCM_PTR_LE (dst, & stack_top_element))
166 grow_stack (cont, val);
167 #endif /* def SCM_STACK_GROWS_UP */
168 SCM_FLUSH_REGISTER_WINDOWS;
169 src = (SCM_STACKITEM *) (SCM_CHARS (cont) + sizeof (scm_contregs));
170 copy_stack_and_call (cont, val, src, dst);
171 }
172
173
174 #else /* ifndef CHEAP_CONTINUATIONS */
175
176 /* Dirk:FIXME:: It seems that nobody has ever tried to use this code, since it
177 * contains syntactic errors and thus would not have compiled anyway.
178 */
179
180
181 SCM
182 scm_make_cont (SCM *answer)
183 {
184 SCM cont;
185
186 SCM_NEWCELL (cont);
187 *answer = cont;
188 SCM_ENTER_A_SECTION;
189 SCM_SET_CONTREGS (cont, scm_must_malloc (sizeof (scm_contregs), s_cont));
190 SCM_DYNENV (cont) = scm_dynwinds;
191 SCM_THROW_VALUE = SCM_EOL;
192 SCM_BASE (cont) = SCM_BASE (rootcont);
193 SCM_SEQ (cont) = SCM_SEQ (rootcont);
194 SCM_SETCAR (cont, scm_tc7_contin);
195 SCM_EXIT_A_SECTION;
196
197 #ifdef DEBUG_EXTENSIONS
198 SCM_DFRAME (cont) = scm_last_debug_frame;
199 #endif
200
201 return cont;
202 }
203
204
205 static void
206 scm_dynthrow (SCM cont, SCM val)
207 {
208 #ifdef DEBUG_EXTENSIONS
209 scm_last_debug_frame = SCM_DFRAME (cont);
210 #endif
211 SCM_THROW_VALUE (cont) = val;
212 longjmp (SCM_JMPBUF (cont), 1);
213 }
214
215
216 #endif
217
218
219 SCM
220 scm_call_continuation (SCM cont, SCM val)
221 {
222 if ((SCM_SEQ (cont) != SCM_SEQ (scm_rootcont))
223 || (SCM_BASE (cont) != SCM_BASE (scm_rootcont)))
224 /* base compare not needed */
225 scm_wta (cont, "continuation from wrong top level", s_cont);
226
227 scm_dowinds (SCM_DYNENV (cont),
228 scm_ilength (scm_dynwinds) - scm_ilength (SCM_DYNENV (cont)));
229
230 scm_dynthrow (cont, val);
231 return SCM_UNSPECIFIED; /* not reached */
232 }
233
234
235 void
236 scm_init_continuations ()
237 {
238 #include "continuations.x"
239 }
240
241
242 /*
243 Local Variables:
244 c-file-style: "gnu"
245 End:
246 */