From d7609e853c71d26495e74bdadf1d2aea6d64627d Mon Sep 17 00:00:00 2001 From: "Guillermo J. Rozas" Date: Tue, 23 Feb 1993 02:38:48 +0000 Subject: [PATCH] Add C_call_scheme. --- v7/src/microcode/boot.c | 16 +++++++- v7/src/microcode/interp.c | 77 +++++++++++++++++++++++++++++++-------- v7/src/microcode/utils.c | 58 ++++++++++++++++++++++++++++- v8/src/microcode/interp.c | 77 +++++++++++++++++++++++++++++++-------- 4 files changed, 192 insertions(+), 36 deletions(-) diff --git a/v7/src/microcode/boot.c b/v7/src/microcode/boot.c index c57a634ea..6b1d7a33a 100644 --- a/v7/src/microcode/boot.c +++ b/v7/src/microcode/boot.c @@ -1,8 +1,8 @@ /* -*-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 @@ -389,6 +389,9 @@ DEFUN (Start_Scheme, (Start_Prim, File_Name), Enter_Interpreter (); } +extern void EXFUN (Interpret, (Boolean)); +extern SCHEME_OBJECT EXFUN (Re_Enter_Interpreter, (void)); + static void DEFUN_VOID (Enter_Interpreter) { @@ -396,6 +399,15 @@ 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); +} /* Garbage collection debugging utilities. */ diff --git a/v7/src/microcode/interp.c b/v7/src/microcode/interp.c index eae8a3dd4..eada68a6b 100644 --- a/v7/src/microcode/interp.c +++ b/v7/src/microcode/interp.c @@ -1,8 +1,8 @@ /* -*-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 @@ -45,6 +45,8 @@ MIT in each case. */ #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 @@ -393,13 +395,33 @@ if (GC_Check(Amount)) \ 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 ()); @@ -417,17 +439,28 @@ DEFUN_VOID (abort_to_interpreter_argument) { return (interpreter_throw_argument); } + +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 @@ -472,14 +505,10 @@ Repeat_Dispatch: 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(); @@ -667,7 +696,7 @@ Eval_Non_Trapping: case TC_BROKEN_HEART: Export_Registers(); - Microcode_Termination(TERM_BROKEN_HEART); + Microcode_Termination (TERM_BROKEN_HEART); /* Interpret() continues on the next page */ @@ -968,7 +997,7 @@ Pop_Return_Non_Trapping: { 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"); @@ -1118,9 +1147,25 @@ Pop_Return_Non_Trapping: 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. */ @@ -1370,7 +1415,7 @@ external_assignment_return: case RC_HALT: Export_Registers(); - Microcode_Termination(TERM_TERM_HANDLER); + Microcode_Termination (TERM_TERM_HANDLER); case RC_HARDWARE_TRAP: { diff --git a/v7/src/microcode/utils.c b/v7/src/microcode/utils.c index ed7780cb7..967d3bb84 100644 --- a/v7/src/microcode/utils.c +++ b/v7/src/microcode/utils.c @@ -1,8 +1,8 @@ /* -*-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 @@ -1026,3 +1026,57 @@ DEFUN_VOID (Compiler_Get_Fixed_Objects) 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); +} diff --git a/v8/src/microcode/interp.c b/v8/src/microcode/interp.c index eae8a3dd4..eada68a6b 100644 --- a/v8/src/microcode/interp.c +++ b/v8/src/microcode/interp.c @@ -1,8 +1,8 @@ /* -*-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 @@ -45,6 +45,8 @@ MIT in each case. */ #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 @@ -393,13 +395,33 @@ if (GC_Check(Amount)) \ 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 ()); @@ -417,17 +439,28 @@ DEFUN_VOID (abort_to_interpreter_argument) { return (interpreter_throw_argument); } + +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 @@ -472,14 +505,10 @@ Repeat_Dispatch: 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(); @@ -667,7 +696,7 @@ Eval_Non_Trapping: case TC_BROKEN_HEART: Export_Registers(); - Microcode_Termination(TERM_BROKEN_HEART); + Microcode_Termination (TERM_BROKEN_HEART); /* Interpret() continues on the next page */ @@ -968,7 +997,7 @@ Pop_Return_Non_Trapping: { 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"); @@ -1118,9 +1147,25 @@ Pop_Return_Non_Trapping: 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. */ @@ -1370,7 +1415,7 @@ external_assignment_return: case RC_HALT: Export_Registers(); - Microcode_Termination(TERM_TERM_HANDLER); + Microcode_Termination (TERM_TERM_HANDLER); case RC_HARDWARE_TRAP: { -- 2.25.1