1 /* Copyright (C) 1995,1996,1998 Free Software Foundation, Inc.
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)
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.
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
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
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.
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
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.
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. */
42 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
43 gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
51 #ifdef DEBUG_EXTENSIONS
56 #include "continuations.h"
63 static char s_cont
[] = "continuation";
65 static void scm_dynthrow (SCM
, SCM
);
68 #ifndef CHEAP_CONTINUATIONS
72 scm_make_cont (SCM
*answer
)
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
),
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
);
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
));
99 /* memcpy should be safe: src and dst will never overlap */
100 memcpy (dst
, src
, sizeof (SCM_STACKITEM
) * SCM_LENGTH (cont
));
102 #ifdef DEBUG_EXTENSIONS
103 SCM_DFRAME (cont
) = scm_last_debug_frame
;
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
117 scm_bits_t scm_i_dummy
;
120 grow_stack (SCM cont
, SCM val
)
122 scm_bits_t growth
[100];
124 scm_i_dummy
= (scm_bits_t
) growth
;
125 scm_dynthrow (cont
, val
);
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.
134 copy_stack_and_call (SCM cont
, SCM val
,
135 SCM_STACKITEM
* src
, SCM_STACKITEM
* dst
)
137 /* memcpy should be safe: src and dst will never overlap */
138 memcpy (dst
, src
, sizeof (SCM_STACKITEM
) * SCM_LENGTH (cont
));
140 #ifdef DEBUG_EXTENSIONS
141 scm_last_debug_frame
= SCM_DFRAME (cont
);
144 SCM_THROW_VALUE (cont
) = val
;
145 longjmp (SCM_JMPBUF (cont
), 1);
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.
154 scm_dynthrow (SCM cont
, SCM val
)
157 SCM_STACKITEM
* dst
= SCM_BASE (scm_rootcont
);
158 SCM_STACKITEM stack_top_element
;
160 #ifdef SCM_STACK_GROWS_UP
161 if (SCM_PTR_GE (dst
+ SCM_LENGTH (cont
), & stack_top_element
))
162 grow_stack (cont
, val
);
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
);
174 #else /* ifndef CHEAP_CONTINUATIONS */
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.
182 scm_make_cont (SCM
*answer
)
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
);
197 #ifdef DEBUG_EXTENSIONS
198 SCM_DFRAME (cont
) = scm_last_debug_frame
;
206 scm_dynthrow (SCM cont
, SCM val
)
208 #ifdef DEBUG_EXTENSIONS
209 scm_last_debug_frame
= SCM_DFRAME (cont
);
211 SCM_THROW_VALUE (cont
) = val
;
212 longjmp (SCM_JMPBUF (cont
), 1);
220 scm_call_continuation (SCM cont
, SCM val
)
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
);
227 scm_dowinds (SCM_DYNENV (cont
),
228 scm_ilength (scm_dynwinds
) - scm_ilength (SCM_DYNENV (cont
)));
230 scm_dynthrow (cont
, val
);
231 return SCM_UNSPECIFIED
; /* not reached */
236 scm_init_continuations ()
238 #include "continuations.x"