/* -*-C-*-
-$Id: boot.c,v 9.75 1992/11/23 04:00:50 gjr Exp $
+$Id: boot.c,v 9.76 1993/02/23 02:38:48 gjr Exp $
-Copyright (c) 1988-1992 Massachusetts Institute of Technology
+Copyright (c) 1988-1993 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
Enter_Interpreter ();
}
+extern void EXFUN (Interpret, (Boolean));
+extern SCHEME_OBJECT EXFUN (Re_Enter_Interpreter, (void));
+
static void
DEFUN_VOID (Enter_Interpreter)
{
fprintf (stderr, "\nThe interpreter returned to top level!\n");
Microcode_Termination (TERM_EXIT);
}
+
+/* This must be used with care, and only synchronously. */
+
+SCHEME_OBJECT
+DEFUN_VOID (Re_Enter_Interpreter)
+{
+ Interpret (true);
+ return (Val);
+}
\f
/* Garbage collection debugging utilities. */
/* -*-C-*-
-$Id: interp.c,v 9.72 1992/12/09 23:38:37 cph Exp $
+$Id: interp.c,v 9.73 1993/02/23 02:38:43 gjr Exp $
-Copyright (c) 1988-1992 Massachusetts Institute of Technology
+Copyright (c) 1988-1993 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
#include "zones.h"
#include "prmcon.h"
+extern void EXFUN (Interpret, (Boolean));
+
extern PTR EXFUN (obstack_chunk_alloc, (unsigned int size));
extern void EXFUN (free, (PTR ptr));
#define obstack_chunk_free free
The EVAL/APPLY ying/yang
*/
-static PTR interpreter_catch_dstack_position;
-static jmp_buf interpreter_catch_env;
-static int interpreter_throw_argument;
+typedef struct interpreter_state_s * interpreter_state_t;
+
+struct interpreter_state_s
+{
+ unsigned int nesting_level;
+ PTR dstack_position;
+ jmp_buf catch_env;
+ int throw_argument;
+ interpreter_state_t previous_state;
+};
+
+#define interpreter_catch_dstack_position interpreter_state->dstack_position
+#define interpreter_catch_env interpreter_state->catch_env
+#define interpreter_throw_argument interpreter_state->throw_argument
+#define NULL_INTERPRETER_STATE ((interpreter_state_t) NULL)
+
+static interpreter_state_t interpreter_state = NULL_INTERPRETER_STATE;
void
DEFUN (abort_to_interpreter, (argument), int argument)
{
+ if (interpreter_state == NULL_INTERPRETER_STATE)
+ {
+ fprintf (stderr, "abort_to_interpreter: Interpreter not set up.\n");
+ termination_init_error ();
+ }
+
interpreter_throw_argument = argument;
{
long old_mask = (FETCH_INTERRUPT_MASK ());
{
return (interpreter_throw_argument);
}
+\f
+extern void EXFUN (Interpret, (Boolean));
void
-DEFUN (Interpret, (dumped_p), Boolean dumped_p)
+DEFUN (Interpret, (pop_return_p), Boolean pop_return_p)
{
long Which_Way;
fast SCHEME_OBJECT * Reg_Block, * Reg_Stack_Pointer, * Reg_History;
-
+ struct interpreter_state_s new_state_s;
+ interpreter_state_t new_state = & new_state_s;
extern long enter_compiled_expression();
extern long apply_compiled_procedure();
extern long return_to_compiled_code();
+ new_state->previous_state = interpreter_state;
+ new_state->nesting_level =
+ ((interpreter_state == NULL_INTERPRETER_STATE)
+ ? 0
+ : (1 + (interpreter_state->nesting_level)));
+
+ interpreter_state = new_state;
+
Reg_Block = &Registers[0];
/* Primitives jump back here for errors, requests to evaluate an
goto Eval_Non_Trapping;
case 0: /* first time */
- if (dumped_p)
- {
+ if (pop_return_p)
goto Pop_Return;
- }
else
- {
break; /* fall into eval */
- }
case PRIM_POP_RETURN:
PROCEED_AFTER_PRIMITIVE();
case TC_BROKEN_HEART:
Export_Registers();
- Microcode_Termination(TERM_BROKEN_HEART);
+ Microcode_Termination (TERM_BROKEN_HEART);
/* Interpret() continues on the next page */
\f
{ STACK_PUSH (Val); /* For possible stack trace */
Save_Cont();
Export_Registers();
- Microcode_Termination(TERM_BAD_STACK);
+ Microcode_Termination (TERM_BAD_STACK);
}
if (Eval_Debug)
{ Print_Return("Pop_Return, return code");
Reduces_To_Nth(OR_ALTERNATIVE);
case RC_END_OF_COMPUTATION:
+ {
/* Signals bottom of stack */
+
+ interpreter_state_t previous_state;
+
+ previous_state = interpreter_state->previous_state;
Export_Registers();
- termination_end_of_computation ();
+ if (previous_state == NULL_INTERPRETER_STATE)
+ {
+ termination_end_of_computation ();
+ /*NOTREACHED*/
+ }
+ else
+ {
+ dstack_position = interpreter_catch_dstack_position;
+ interpreter_state = previous_state;
+ return;
+ }
+ }
case RC_EVAL_ERROR:
/* Should be called RC_REDO_EVALUATION. */
\f
case RC_HALT:
Export_Registers();
- Microcode_Termination(TERM_TERM_HANDLER);
+ Microcode_Termination (TERM_TERM_HANDLER);
case RC_HARDWARE_TRAP:
{
/* -*-C-*-
-$Id: utils.c,v 9.55 1992/11/24 01:07:30 gjr Exp $
+$Id: utils.c,v 9.56 1993/02/23 02:38:36 gjr Exp $
-Copyright (c) 1987-1992 Massachusetts Institute of Technology
+Copyright (c) 1987-1993 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
return (SHARP_F);
}
}
+
+extern SCHEME_OBJECT EXFUN (Re_Enter_Interpreter, (void));
+extern SCHEME_OBJECT EXFUN (C_call_scheme,
+ (SCHEME_OBJECT, long, SCHEME_OBJECT *));
+
+SCHEME_OBJECT
+DEFUN (C_call_scheme, (proc, nargs, argvec),
+ SCHEME_OBJECT proc
+ AND long nargs
+ AND SCHEME_OBJECT * argvec)
+{
+ SCHEME_OBJECT primitive, prim_lexpr, * sp, result;
+
+ primitive = (Regs [REGBLOCK_PRIMITIVE]);
+ prim_lexpr = (Regs [REGBLOCK_LEXPR_ACTUALS]);
+
+ if (! (PRIMITIVE_P (primitive)))
+ {
+ abort_to_interpreter (ERR_CANNOT_RECURSE);
+ /*NOTREACHED*/
+ }
+ sp = Stack_Pointer;
+
+ Will_Push ((2 * CONTINUATION_SIZE) + (nargs + STACK_ENV_EXTRA_SLOTS + 1));
+ {
+ long i;
+
+ Store_Return (RC_END_OF_COMPUTATION);
+ Store_Expression (primitive);
+ Save_Cont ();
+
+ for (i = nargs; --i >= 0; )
+ STACK_PUSH (argvec[i]);
+ STACK_PUSH (proc);
+ STACK_PUSH (STACK_FRAME_HEADER + nargs);
+
+ Store_Return (RC_INTERNAL_APPLY);
+ Store_Expression (SHARP_F);
+ Save_Cont ();
+ }
+ Pushed ();
+ result = (Re_Enter_Interpreter ());
+
+ if (Stack_Pointer != sp)
+ {
+ signal_error_from_primitive (ERR_STACK_HAS_SLIPPED);
+ /*NOTREACHED*/
+ }
+
+ Regs [REGBLOCK_LEXPR_ACTUALS] = prim_lexpr;
+ Regs [REGBLOCK_PRIMITIVE] = primitive;
+
+ return (result);
+}
/* -*-C-*-
-$Id: interp.c,v 9.72 1992/12/09 23:38:37 cph Exp $
+$Id: interp.c,v 9.73 1993/02/23 02:38:43 gjr Exp $
-Copyright (c) 1988-1992 Massachusetts Institute of Technology
+Copyright (c) 1988-1993 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
#include "zones.h"
#include "prmcon.h"
+extern void EXFUN (Interpret, (Boolean));
+
extern PTR EXFUN (obstack_chunk_alloc, (unsigned int size));
extern void EXFUN (free, (PTR ptr));
#define obstack_chunk_free free
The EVAL/APPLY ying/yang
*/
-static PTR interpreter_catch_dstack_position;
-static jmp_buf interpreter_catch_env;
-static int interpreter_throw_argument;
+typedef struct interpreter_state_s * interpreter_state_t;
+
+struct interpreter_state_s
+{
+ unsigned int nesting_level;
+ PTR dstack_position;
+ jmp_buf catch_env;
+ int throw_argument;
+ interpreter_state_t previous_state;
+};
+
+#define interpreter_catch_dstack_position interpreter_state->dstack_position
+#define interpreter_catch_env interpreter_state->catch_env
+#define interpreter_throw_argument interpreter_state->throw_argument
+#define NULL_INTERPRETER_STATE ((interpreter_state_t) NULL)
+
+static interpreter_state_t interpreter_state = NULL_INTERPRETER_STATE;
void
DEFUN (abort_to_interpreter, (argument), int argument)
{
+ if (interpreter_state == NULL_INTERPRETER_STATE)
+ {
+ fprintf (stderr, "abort_to_interpreter: Interpreter not set up.\n");
+ termination_init_error ();
+ }
+
interpreter_throw_argument = argument;
{
long old_mask = (FETCH_INTERRUPT_MASK ());
{
return (interpreter_throw_argument);
}
+\f
+extern void EXFUN (Interpret, (Boolean));
void
-DEFUN (Interpret, (dumped_p), Boolean dumped_p)
+DEFUN (Interpret, (pop_return_p), Boolean pop_return_p)
{
long Which_Way;
fast SCHEME_OBJECT * Reg_Block, * Reg_Stack_Pointer, * Reg_History;
-
+ struct interpreter_state_s new_state_s;
+ interpreter_state_t new_state = & new_state_s;
extern long enter_compiled_expression();
extern long apply_compiled_procedure();
extern long return_to_compiled_code();
+ new_state->previous_state = interpreter_state;
+ new_state->nesting_level =
+ ((interpreter_state == NULL_INTERPRETER_STATE)
+ ? 0
+ : (1 + (interpreter_state->nesting_level)));
+
+ interpreter_state = new_state;
+
Reg_Block = &Registers[0];
/* Primitives jump back here for errors, requests to evaluate an
goto Eval_Non_Trapping;
case 0: /* first time */
- if (dumped_p)
- {
+ if (pop_return_p)
goto Pop_Return;
- }
else
- {
break; /* fall into eval */
- }
case PRIM_POP_RETURN:
PROCEED_AFTER_PRIMITIVE();
case TC_BROKEN_HEART:
Export_Registers();
- Microcode_Termination(TERM_BROKEN_HEART);
+ Microcode_Termination (TERM_BROKEN_HEART);
/* Interpret() continues on the next page */
\f
{ STACK_PUSH (Val); /* For possible stack trace */
Save_Cont();
Export_Registers();
- Microcode_Termination(TERM_BAD_STACK);
+ Microcode_Termination (TERM_BAD_STACK);
}
if (Eval_Debug)
{ Print_Return("Pop_Return, return code");
Reduces_To_Nth(OR_ALTERNATIVE);
case RC_END_OF_COMPUTATION:
+ {
/* Signals bottom of stack */
+
+ interpreter_state_t previous_state;
+
+ previous_state = interpreter_state->previous_state;
Export_Registers();
- termination_end_of_computation ();
+ if (previous_state == NULL_INTERPRETER_STATE)
+ {
+ termination_end_of_computation ();
+ /*NOTREACHED*/
+ }
+ else
+ {
+ dstack_position = interpreter_catch_dstack_position;
+ interpreter_state = previous_state;
+ return;
+ }
+ }
case RC_EVAL_ERROR:
/* Should be called RC_REDO_EVALUATION. */
\f
case RC_HALT:
Export_Registers();
- Microcode_Termination(TERM_TERM_HANDLER);
+ Microcode_Termination (TERM_TERM_HANDLER);
case RC_HARDWARE_TRAP:
{
projects / mit-scheme.git / commitdiff