1 /* Copyright (C) 1995,1996 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, 675 Mass Ave, Cambridge, MA 02139, USA.
17 * As a special exception, the Free Software Foundation gives permission
18 * for additional uses of the text contained in its release of GUILE.
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.
26 * This exception does not however invalidate any other reasons why
27 * the executable file might be covered by the GNU General Public License.
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.
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.
56 SCM scm_sys_protects
[SCM_NUM_PROTECTS
];
61 struct scm_root_state
*scm_root
;
66 static SCM mark_root
SCM_P ((SCM
));
72 scm_root_state
*s
= SCM_ROOT_STATE (root
);
73 SCM_SETGC8MARK (root
);
74 scm_gc_mark (s
->rootcont
);
75 scm_gc_mark (s
->dynwinds
);
76 scm_gc_mark (s
->continuation_stack
);
77 scm_gc_mark (s
->continuation_stack_ptr
);
78 scm_gc_mark (s
->progargs
);
79 scm_gc_mark (s
->exitval
);
80 scm_gc_mark (s
->cur_inp
);
81 scm_gc_mark (s
->cur_outp
);
82 scm_gc_mark (s
->cur_errp
);
83 scm_gc_mark (s
->def_inp
);
84 scm_gc_mark (s
->def_outp
);
85 scm_gc_mark (s
->def_errp
);
86 scm_gc_mark (s
->top_level_lookup_closure_var
);
87 scm_gc_mark (s
->system_transformer
);
88 return SCM_ROOT_STATE (root
) -> parent
;
91 static scm_sizet free_root
SCM_P ((SCM
));
97 scm_must_free ((char *) SCM_ROOT_STATE (root
));
98 return sizeof (scm_root_state
);
101 static int print_root
SCM_P ((SCM exp
, SCM port
, scm_print_state
*pstate
));
104 print_root (exp
, port
, pstate
)
107 scm_print_state
*pstate
;
109 scm_gen_puts (scm_regular_string
, "#<root ", port
);
110 scm_intprint(SCM_SEQ (SCM_ROOT_STATE (exp
) -> rootcont
), 16, port
);
111 scm_gen_putc('>', port
);
115 static scm_smobfuns root_smob
=
126 scm_make_root (parent
)
130 scm_root_state
*root_state
;
132 root_state
= (scm_root_state
*) scm_must_malloc (sizeof (scm_root_state
),
134 if (SCM_NIMP (parent
) && SCM_ROOTP (parent
))
136 memcpy (root_state
, SCM_ROOT_STATE (parent
), sizeof (scm_root_state
));
137 root_state
->parent
= parent
;
141 root_state
->parent
= SCM_BOOL_F
;
145 SCM_SETCAR (root
, scm_tc16_root
);
146 SCM_SETCDR (root
, root_state
);
147 root_state
->handle
= root
;
152 /* {call-with-dynamic-root}
154 * Suspending the current thread to evaluate a thunk on the
155 * same C stack but under a new root.
157 * Calls to call-with-dynamic-root return exactly once (unless
158 * the process is somehow exitted).
162 SCM scm_exitval
; /* INUM with return value */
164 static int n_dynamic_roots
= 0;
166 static SCM cwdr
SCM_P ((SCM thunk
, SCM a1
, SCM args
, SCM handler
, SCM_STACKITEM
*stack_start
));
168 /* This is the basic code for new root creation.
170 * WARNING! The order of actions in this routine is in many ways
171 * critical. E. g., it is essential that an error doesn't leave Guile
172 * in a messed up state.
176 cwdr (proc
, a1
, args
, handler
, stack_start
)
181 SCM_STACKITEM
*stack_start
;
183 int old_ints_disabled
= scm_ints_disabled
;
184 SCM old_rootcont
, old_winds
;
187 /* Create a fresh root continuation.
191 SCM_NEWCELL (new_rootcont
);
193 SCM_SETJMPBUF (new_rootcont
,
194 scm_must_malloc ((long) sizeof (scm_contregs
),
195 "inferior root continuation"));
196 SCM_SETCAR (new_rootcont
, scm_tc7_contin
);
197 SCM_DYNENV (new_rootcont
) = SCM_EOL
;
198 SCM_BASE (new_rootcont
) = stack_start
;
199 SCM_SEQ (new_rootcont
) = ++n_dynamic_roots
;
200 #ifdef DEBUG_EXTENSIONS
201 SCM_DFRAME (new_rootcont
) = 0;
203 old_rootcont
= scm_rootcont
;
204 scm_rootcont
= new_rootcont
;
208 /* Exit caller's dynamic state.
210 old_winds
= scm_dynwinds
;
211 scm_dowinds (SCM_EOL
, scm_ilength (scm_dynwinds
));
212 #ifdef DEBUG_EXTENSIONS
213 SCM_DFRAME (old_rootcont
) = scm_last_debug_frame
;
214 scm_last_debug_frame
= 0;
217 /* Catch all errors. */
218 answer
= scm_catch_apply (SCM_BOOL_T
, proc
, a1
, args
, handler
);
220 scm_dowinds (old_winds
, - scm_ilength (old_winds
));
222 #ifdef DEBUG_EXTENSIONS
223 scm_last_debug_frame
= SCM_DFRAME (old_rootcont
);
225 scm_rootcont
= old_rootcont
;
227 scm_ints_disabled
= old_ints_disabled
;
232 SCM_PROC(s_call_with_dynamic_root
, "call-with-dynamic-root", 2, 0, 0, scm_call_with_dynamic_root
);
234 scm_call_with_dynamic_root (thunk
, handler
)
238 SCM_STACKITEM stack_place
;
240 return cwdr (thunk
, SCM_EOL
, SCM_EOL
, handler
, &stack_place
);
243 SCM_PROC(s_dynamic_root
, "dynamic-root", 0, 0, 0, scm_dynamic_root
);
247 return scm_ulong2num (SCM_SEQ (scm_root
->rootcont
));
251 scm_apply_with_dynamic_root (proc
, a1
, args
, handler
)
257 SCM_STACKITEM stack_place
;
258 return cwdr (proc
, a1
, args
, handler
, &stack_place
);
263 /* Call thunk(closure) underneath a top-level error handler.
264 * If an error occurs, pass the exitval through err_filter and return it.
265 * If no error occurs, return the value of thunk.
270 typedef int setjmp_type
;
272 typedef long setjmp_type
;
278 scm_call_catching_errors (thunk
, err_filter
, closure
)
285 #ifdef DEBUG_EXTENSIONS
286 SCM_DFRAME (scm_rootcont
) = scm_last_debug_frame
;
288 i
= setjmp (SCM_JMPBUF (scm_rootcont
));
289 scm_stack_checking_enabled_p
= SCM_STACK_CHECKING_P
;
292 scm_gc_heap_lock
= 0;
293 answer
= thunk (closure
);
297 scm_gc_heap_lock
= 1;
298 answer
= err_filter (scm_exitval
, closure
);
306 scm_tc16_root
= scm_newsmob (&root_smob
);