/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchdmp.c,v 9.49 1990/04/01 20:22:33 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchdmp.c,v 9.50 1990/06/20 17:38:05 cph Exp $
Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
#include "scheme.h"
#include "prims.h"
+#include "osfile.h"
#include "trap.h"
#include "lookup.h" /* UNCOMPILED_VARIABLE */
#define In_Fasdump
#include "bchgcc.h"
#include "fasl.h"
+
+static Tchannel dump_channel;
+
+#define Write_Data(size, buffer) \
+ ((OS_channel_write_dump_file \
+ (dump_channel, (buffer), ((size) * (sizeof (SCHEME_OBJECT))))) \
+ / (sizeof (SCHEME_OBJECT)))
+
#include "dump.c"
extern SCHEME_OBJECT
}
else
{
- if (! (Open_Dump_File ((ARG_REF (2)), WRITE_FLAG)))
+ unsigned char * filename = (STRING_LOC ((ARG_REF (2)), 0));
+ dump_channel = (OS_open_dump_file (filename));
+ if (dump_channel == NO_CHANNEL)
error_bad_range_arg (2);
result = Write_File((Free - 1),
((long) (Free - Heap_Bottom)), Heap_Bottom,
table_start, table_length,
((long) (table_end - table_start)),
(compiler_utilities != SHARP_F), true);
- /* The and is short-circuit, so it must be done in this order. */
- result = ((Close_Dump_File ()) && result);
+ OS_channel_close_noerror (dump_channel);
if (!result)
- {
- result = ((OS_file_remove (STRING_ARG (2))) && result);
- }
+ OS_file_remove (filename);
}
Band_Dump_Exit_Hook ();
Free = saved_free;
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchgcc.h,v 9.36 1990/04/01 20:24:46 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchgcc.h,v 9.37 1990/06/20 17:38:12 cph Rel $
Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
promotional, or sales literature without prior written consent from
MIT in each case. */
+#include "oscond.h"
#include "gccode.h"
-#ifdef bsd
+#ifdef _BSD
#include <sys/file.h>
#else
#include <fcntl.h>
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchmmg.c,v 9.53 1990/04/09 14:46:40 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchmmg.c,v 9.54 1990/06/20 17:38:18 cph Exp $
Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
(void) mktemp(gc_default_file_name);
flags = GC_FILE_FLAGS;
-
- position = Parse_Option("-gcfile", Saved_argc, Saved_argv, true);
- if ((position != NOT_THERE) &&
- (position != (Saved_argc - 1)))
- {
- gc_file_name = Saved_argv[position + 1];
- }
- else
- {
- gc_file_name = gc_default_file_name;
- flags |= O_EXCL;
- }
-
- while(true)
+ gc_file_name = (string_option_argument ("-gcfile"));
+ if (gc_file_name == 0)
+ {
+ gc_file_name = gc_default_file_name;
+ flags |= O_EXCL;
+ }
+ while (1)
{
gc_file = open(gc_file_name, flags, GC_FILE_MASK);
if (gc_file != -1)
Saved_argv[0], gc_file_name);
exit(1);
}
-#ifdef hpux
+#ifdef _HPUX
if (gc_file_name == gc_default_file_name)
{
extern prealloc();
PRIMITIVE_CANONICALIZE_CONTEXT ();
new_gc_reserve = (arg_nonnegative_integer (1));
if (Free > Heap_Top)
- {
- Microcode_Termination(TERM_GC_OUT_OF_SPACE);
- /*NOTREACHED*/
- }
+ termination_gc_out_of_space ();
ENTER_CRITICAL_SECTION ("garbage collector");
gc_counter += 1;
GC_Reserve = new_gc_reserve;
GC(EMPTY_LIST);
CLEAR_INTERRUPT(INT_GC);
- Pop_Primitive_Frame(1);
+ POP_PRIMITIVE_FRAME (1);
GC_Daemon_Proc = Get_Fixed_Obj_Slot(GC_Daemon);
RENAME_CRITICAL_SECTION ("garbage collector daemon");
if (GC_Daemon_Proc == SHARP_F)
Store_Return(RC_NORMAL_GC_DONE);
Store_Expression(LONG_TO_UNSIGNED_FIXNUM(MemTop - Free));
Save_Cont();
- Push(GC_Daemon_Proc);
- Push(STACK_FRAME_HEADER);
+ STACK_PUSH (GC_Daemon_Proc);
+ STACK_PUSH (STACK_FRAME_HEADER);
Pushed();
PRIMITIVE_ABORT(PRIM_APPLY);
/* The following comment is by courtesy of LINT, your friendly sponsor. */
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchpur.c,v 9.49 1990/04/01 20:32:02 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchpur.c,v 9.50 1990/06/20 17:38:26 cph Rel $
Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
(*Free++) = purify_result;
(*Free++) = words_free;
}
- Pop_Primitive_Frame(3);
+ POP_PRIMITIVE_FRAME (3);
daemon = Get_Fixed_Obj_Slot(GC_Daemon);
if (daemon == SHARP_F)
{
Store_Expression(result);
Store_Return(RC_NORMAL_GC_DONE);
Save_Cont();
- Push(daemon);
- Push(STACK_FRAME_HEADER);
+ STACK_PUSH (daemon);
+ STACK_PUSH (STACK_FRAME_HEADER);
Pushed();
PRIMITIVE_ABORT(PRIM_APPLY);
/*NOTREACHED*/
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/bkpt.h,v 9.27 1989/09/20 23:06:22 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/bkpt.h,v 9.28 1990/06/20 17:38:32 cph Rel $
-Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
It "shadows" definitions in default.h */
#ifdef ENABLE_DEBUGGING_TOOLS
-\f
+
struct sp_record
-{ SCHEME_OBJECT *sp;
- struct sp_record *next;
+{
+ SCHEME_OBJECT * sp;
+ struct sp_record * next;
};
-typedef struct sp_record *sp_record_list;
-#define sp_nil ((sp_record_list) NULL)
+typedef struct sp_record * sp_record_list;
+
#define debug_maxslots 100
#define Eval_Ucode_Hook() \
{ \
- local_circle[local_slotno++] = Fetch_Expression(); \
- if (local_slotno >= debug_maxslots) local_slotno = 0; \
- if (local_nslots < debug_maxslots) local_nslots++; \
+ (local_circle [local_slotno++]) = (Fetch_Expression ()); \
+ if (local_slotno >= debug_maxslots) \
+ local_slotno = 0; \
+ if (local_nslots < debug_maxslots) \
+ local_nslots += 1; \
}
#define Pop_Return_Ucode_Hook() \
{ \
- if (SP_List != sp_nil) \
- { Export_Registers(); \
- Pop_Return_Break_Point(); \
- Import_Registers(); \
+ if (SP_List != 0) \
+ { \
+ Export_Registers (); \
+ Pop_Return_Break_Point (); \
+ Import_Registers (); \
} \
}
/* Not implemented yet */
#define Apply_Ucode_Hook()
-\f
-/* For performance metering we note the time spent handling each
- * primitive. This MIGHT help us figure out where all the time
- * goes. It should make the time zone kludge obselete someday.
- */
-
-#if false
-/* This code disabled by SAS 6/24/86 */
-struct
-{
- int nprims;
- int primtime[1];
-} perfinfo_data;
-
-void Clear_Perfinfo_Data()
-{ int i;
- perfinfo_data.nprims = MAX_PRIMITIVE + 1;
- for (i = 0; i <= MAX_PRIMITIVE; i++)
- {
- perfinfo_data.primtime[i] = 0;
- }
-}
-
-#define Metering_Apply_Primitive(Loc, prim)
-{
- long Start_Time;
-
- Start_Time = Sys_Clock();
- APPLY_PRIMITIVE(Loc, prim);
- perfinfo_data.primtime[PRIMITIVE_NUMBER(prim)] +=
- (Sys_Clock() - Start_Time);
- Set_Time_Zone(Zone_Working);
-}
-#endif
-#endif /* ifdef ENABLE_DEBUGGING_TOOLS */
+#endif /* ENABLE_DEBUGGING_TOOLS */
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/boot.c,v 9.60 1989/11/30 03:03:40 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/boot.c,v 9.61 1990/06/20 17:38:38 cph Exp $
-Copyright (c) 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
#include <ctype.h>
#endif
-#define STRING_SIZE 512
-#define BLOCKSIZE 1024
-#define blocks(n) ((n)*BLOCKSIZE)
-#define unblocks(n) (((n) + (BLOCKSIZE - 1)) / BLOCKSIZE)
-#define MIN_HEAP_DELTA 50
+extern PTR EXFUN (malloc, (unsigned int size));
+extern void EXFUN (free, (PTR ptr));
-/* Utilities for command line parsing */
+int Saved_argc;
+CONST char ** Saved_argv;
+CONST char * OS_Name;
+CONST char * OS_Variant;
+struct obstack scratch_obstack;
-#define upcase(c) ((islower(c)) ? (toupper(c)) : c)
-
-void
-uppercase(to_where, from_where)
- fast char *to_where, *from_where;
+PTR
+DEFUN (obstack_chunk_alloc, (size), unsigned int size)
{
- fast char c;
+ PTR result = (malloc (size));
+ if (result == 0)
+ {
+ fprintf (stderr, "\n%s: unable to allocate obstack chunk of %d bytes\n",
+ (Saved_argv[0]), size);
+ fflush (stderr);
+ Microcode_Termination (TERM_EXIT);
+ }
+ return (result);
+}
- while((c = *from_where++) != '\0')
- {
- *to_where++ = upcase(c);
- }
- *to_where = '\0';
- return;
+#define obstack_chunk_free free
+
+#ifndef ENTRY_HOOK
+#define ENTRY_HOOK()
+#endif
+
+/* Declare the outermost critical section. */
+DECLARE_CRITICAL_SECTION ();
+
+#define BLOCKS_TO_BYTES(n) ((n) * 1024)
+
+static void
+DEFUN (usage, (error_string), CONST char * error_string)
+{
+ fprintf (stderr, "%s: %s\n\n", (Saved_argv[0]), error_string);
+ fflush (stderr);
+ exit (1);
}
\f
-int
-Parse_Option(opt_key, nargs, args, casep)
- char *opt_key, **args;
- Boolean casep;
- int nargs;
-{
- int i;
- char key[STRING_SIZE], current[STRING_SIZE];
+/* Command Line Parsing */
- if (casep)
- {
- uppercase(key, opt_key);
- }
- else
- {
- strcpy(key, opt_key);
- }
- for(i = 0; i < nargs; i++)
- {
- if (casep)
- {
- uppercase(current, args[i]);
- }
- else
+static int
+DEFUN (string_compare_ci, (string1, string2),
+ CONST char * string1 AND
+ CONST char * string2)
+{
+ CONST char * scan1 = string1;
+ unsigned int length1 = (strlen (string1));
+ CONST char * scan2 = string2;
+ unsigned int length2 = (strlen (string2));
+ unsigned int length = ((length1 < length2) ? length1 : length2);
+ CONST char * end1 = (scan1 + length);
+ CONST char * end2 = (scan2 + length);
+ while ((scan1 < end1) && (scan2 < end2))
{
- strcpy(current, args[i]);
+ int c1 = (*scan1++);
+ int c2 = (*scan2++);
+ if (islower (c1))
+ {
+ if (! (islower (c2)))
+ c1 = (toupper (c1));
+ }
+ else
+ {
+ if (islower (c2))
+ c2 = (toupper (c2));
+ }
+ if (c1 != c2)
+ return ((c1 < c2) ? (-1) : 1);
}
- if (strcmp(key, current) == 0)
+ return
+ ((length1 == length2)
+ ? 0
+ : ((length1 < length2) ? (-1) : 1));
+}
+
+static int
+DEFUN (find_option_argument, (name), CONST char * name)
+{
+ CONST char ** scan = Saved_argv;
+ CONST char ** end = (scan + Saved_argc);
+ while (scan < end)
+ if ((string_compare_ci (name, (*scan++))) == 0)
+ return ((scan - Saved_argv) - 1);
+ return (-1);
+}
+
+int
+DEFUN (boolean_option_argument, (name), CONST char * name)
+{
+ return ((find_option_argument (name)) >= 0);
+}
+
+CONST char *
+DEFUN (string_option_argument, (name), CONST char * name)
+{
+ int position = (find_option_argument (name));
+ if (position == (Saved_argc - 1))
{
- return i;
+ fprintf (stderr, "%s: %s option requires an argument name\n\n",
+ (Saved_argv[0]), name);
+ fflush (stderr);
+ exit (1);
}
- }
- return NOT_THERE;
+ return ((position < 0) ? 0 : (Saved_argv [position + 1]));
}
long
-Def_Number(key, nargs, args, def)
- char *key, **args;
- long def;
- int nargs;
+DEFUN (numeric_option_argument, (name, defval),
+ CONST char * name AND
+ long defval)
{
- int position;
-
- position = Parse_Option(key, nargs, args, true);
- if ((position == NOT_THERE) || (position == (nargs-1)))
- {
- return def;
- }
- else
- {
- return atoi(args[position+1]);
- }
+ CONST char * option = (string_option_argument (name));
+ return ((option == 0) ? defval : (atoi (option)));
}
\f
/* Used to test whether it is a dumped executable version */
-
-extern Boolean Was_Scheme_Dumped;
Boolean Was_Scheme_Dumped = false;
-Boolean inhibit_termination_messages;
int Saved_Heap_Size;
int Saved_Stack_Size;
int Saved_Constant_Size;
-void
-usage(error_string)
- char *error_string;
+static void
+DEFUN (find_image_parameters, (file_name, cold_load_p, supplied_p),
+ CONST char ** file_name AND
+ Boolean * cold_load_p AND
+ Boolean * supplied_p)
{
- fprintf(stderr, "%s: %s\n\n", Saved_argv[0], error_string);
- exit(1);
-}
-\f
-void
-find_image_parameters(file_name, cold_load_p, supplied_p)
- char **file_name;
- Boolean *cold_load_p, *supplied_p;
-{
- int position;
- Boolean found_p;
-
- found_p = false;
- *supplied_p = false;
- *cold_load_p = false;
- *file_name = DEFAULT_BAND_NAME;
-
+ Boolean found_p = false;
+ (*supplied_p) = false;
+ (*cold_load_p) = false;
+ (*file_name) = DEFAULT_BAND_NAME;
if (!Was_Scheme_Dumped)
- {
- Heap_Size = HEAP_SIZE;
- Stack_Size = STACK_SIZE;
- Constant_Size = CONSTANT_SIZE;
- }
+ {
+ Heap_Size = HEAP_SIZE;
+ Stack_Size = STACK_SIZE;
+ Constant_Size = CONSTANT_SIZE;
+ }
else
- {
- Saved_Heap_Size = Heap_Size;
- Saved_Stack_Size = Stack_Size;
- Saved_Constant_Size = Constant_Size;
- }
-
+ {
+ Saved_Heap_Size = Heap_Size;
+ Saved_Stack_Size = Stack_Size;
+ Saved_Constant_Size = Constant_Size;
+ }
/* This does not set found_p because the image spec. can be
overridden by the options below. It just sets different
- defaults.
- */
-
- if ((position = Parse_Option("-compiler", Saved_argc, Saved_argv, true)) !=
- NOT_THERE)
- {
- *supplied_p = true;
- *file_name = DEFAULT_COMPILER_BAND;
- Heap_Size = COMPILER_HEAP_SIZE;
- Stack_Size = COMPILER_STACK_SIZE;
- Constant_Size = COMPILER_CONSTANT_SIZE;
- }
-\f
+ defaults. */
+ if (boolean_option_argument ("-compiler"))
+ {
+ (*supplied_p) = true;
+ (*file_name) = DEFAULT_COMPILER_BAND;
+ Heap_Size = COMPILER_HEAP_SIZE;
+ Stack_Size = COMPILER_STACK_SIZE;
+ Constant_Size = COMPILER_CONSTANT_SIZE;
+ }
/* Exclusive image specs. */
-
- if ((position = Parse_Option("-band", Saved_argc, Saved_argv, true)) !=
- NOT_THERE)
{
- if (position == (Saved_argc - 1))
- usage("-band option requires a file name");
- if (found_p)
- usage("Multiple image parameters specified!");
- found_p = true;
- *supplied_p = true;
- *file_name = Saved_argv[position + 1];
- }
-
- if ((position = Parse_Option("-fasl", Saved_argc, Saved_argv, true)) !=
- NOT_THERE)
- {
- if (position == (Saved_argc - 1))
- usage("-fasl option requires a file name");
- if (found_p)
- usage("Multiple image parameters specified!");
- found_p = true;
- *supplied_p = true;
- *cold_load_p = true;
- *file_name = Saved_argv[position + 1];
+ CONST char * band_name = (string_option_argument ("-band"));
+ if (band_name != 0)
+ {
+ if (found_p)
+ usage ("Multiple image parameters specified!");
+ found_p = true;
+ (*supplied_p) = true;
+ (*file_name) = band_name;
+ }
}
-
- Heap_Size =
- Def_Number("-heap", Saved_argc, Saved_argv, Heap_Size);
- Stack_Size =
- Def_Number("-stack", Saved_argc, Saved_argv, Stack_Size);
- Constant_Size =
- Def_Number("-constant", Saved_argc, Saved_argv, Constant_Size);
-
- if (Was_Scheme_Dumped &&
- ((Heap_Size != Saved_Heap_Size) ||
- (Stack_Size != Saved_Stack_Size) ||
- (Constant_Size != Saved_Constant_Size)))
{
- fprintf(stderr,
- "%s warning: Allocation parameters ignored.\n",
- Saved_argv[0]);
- Heap_Size = Saved_Heap_Size;
- Stack_Size = Saved_Stack_Size;
- Constant_Size = Saved_Constant_Size;
+ CONST char * fasl_name = (string_option_argument ("-fasl"));
+ if (fasl_name != 0)
+ {
+ if (found_p)
+ usage ("Multiple image parameters specified!");
+ found_p = true;
+ (*supplied_p) = true;
+ (*cold_load_p) = true;
+ (*file_name) = fasl_name;
+ }
}
- return;
+ Heap_Size = (numeric_option_argument ("-heap", Heap_Size));
+ Stack_Size = (numeric_option_argument ("-stack", Stack_Size));
+ Constant_Size = (numeric_option_argument ("-constant", Constant_Size));
+ if (Was_Scheme_Dumped
+ && ((Heap_Size != Saved_Heap_Size)
+ || (Stack_Size != Saved_Stack_Size)
+ || (Constant_Size != Saved_Constant_Size)))
+ {
+ fprintf (stderr, "%s warning: Allocation parameters ignored.\n",
+ (Saved_argv[0]));
+ fflush (stderr);
+ Heap_Size = Saved_Heap_Size;
+ Stack_Size = Saved_Stack_Size;
+ Constant_Size = Saved_Constant_Size;
+ }
}
\f
/* Exit is done in a different way on some operating systems (eg. VMS) */
forward void Start_Scheme ();
forward void Enter_Interpreter ();
-extern void Clear_Memory(), Setup_Memory(), Reset_Memory();
-extern void OS_initialize ();
-
-/*
- THE MAIN PROGRAM
- */
+extern void Clear_Memory ();
+extern void Setup_Memory ();
+PTR initial_C_stack_pointer;
main_type
main (argc, argv)
int argc;
- char ** argv;
+ CONST char ** argv;
{
Boolean cold_load_p, supplied_p;
- char *file_name;
+ CONST char * file_name;
extern void compiler_initialize ();
Init_Exit_Scheme();
- inhibit_termination_messages = false;
Saved_argc = argc;
Saved_argv = argv;
+ initial_C_stack_pointer = (&argc);
+ obstack_init (&scratch_obstack);
- find_image_parameters(&file_name, &cold_load_p, &supplied_p);
+ find_image_parameters (&file_name, &cold_load_p, &supplied_p);
if (Was_Scheme_Dumped)
{
if (!supplied_p)
{
printf ("Scheme Microcode Version %d.%d\n", VERSION, SUBVERSION);
- OS_initialize (true);
+ OS_initialize ();
Enter_Interpreter ();
}
else
{
- Clear_Memory ((blocks (Heap_Size)), (blocks (Stack_Size)),
- (blocks (Constant_Size)));
+ Clear_Memory ((BLOCKS_TO_BYTES (Heap_Size)),
+ (BLOCKS_TO_BYTES (Stack_Size)),
+ (BLOCKS_TO_BYTES (Constant_Size)));
/* We are reloading from scratch anyway. */
Was_Scheme_Dumped = false;
Start_Scheme ((cold_load_p ? BOOT_FASLOAD : BOOT_LOAD_BAND),
}
Command_Line_Hook();
- Setup_Memory ((blocks(Heap_Size)), (blocks(Stack_Size)),
- blocks(Constant_Size));
+ Setup_Memory ((BLOCKS_TO_BYTES (Heap_Size)),
+ (BLOCKS_TO_BYTES (Stack_Size)),
+ (BLOCKS_TO_BYTES (Constant_Size)));
compiler_initialize ((long) cold_load_p);
Start_Scheme ((cold_load_p ? BOOT_FASLOAD : BOOT_LOAD_BAND),
file_name);
/* Boot Scheme */
void
-Start_Scheme(Start_Prim, File_Name)
+Start_Scheme (Start_Prim, File_Name)
int Start_Prim;
- char *File_Name;
+ char * File_Name;
{
- extern SCHEME_OBJECT make_primitive();
+ extern SCHEME_OBJECT make_primitive ();
SCHEME_OBJECT FName, Init_Prog, *Fasload_Call, prim;
fast long i;
- Boolean I_Am_Master; /* Parallel processor test */
-
- I_Am_Master = (Start_Prim != BOOT_GET_WORK);
+ /* Parallel processor test */
+ Boolean I_Am_Master = (Start_Prim != BOOT_GET_WORK);
if (I_Am_Master)
- {
- printf("Scheme Microcode Version %d.%d\n", VERSION, SUBVERSION);
- }
- OS_initialize(I_Am_Master);
- if (I_Am_Master)
- {
- for (i = 0; i < FILE_CHANNELS; i++)
{
- Channels[i] = NULL;
+ fprintf (stdout, "Scheme Microcode Version %d.%d\n", VERSION, SUBVERSION);
+ fflush (stdout);
}
+ OS_initialize ();
+ if (I_Am_Master)
+ {
Current_State_Point = SHARP_F;
Fluid_Bindings = EMPTY_LIST;
- Photo_Open = false;
Init_Fixed_Objects ();
}
-\f
-/* The initial program to execute is one of
+
+ /* The initial program to execute is one of
(SCODE-EVAL (BINARY-FASLOAD <file-name>) SYSTEM-GLOBAL-ENVIRONMENT),
(LOAD-BAND <file-name>), or
((GET-WORK))
- depending on the value of Start_Prim.
-*/
-
+ depending on the value of Start_Prim. */
switch (Start_Prim)
{
case BOOT_FASLOAD: /* (SCODE-EVAL (BINARY-FASLOAD <file>) GLOBAL-ENV) */
/*NOTREACHED*/
}
-/* Start_Scheme continues on the next page */
-\f
-/* Start_Scheme, continued */
-
- /* Setup registers */
-
+ /* Setup registers */
INITIALIZE_INTERRUPTS();
Env = MAKE_OBJECT (GLOBAL_ENV, 0);
Trapping = false;
Return_Hook_Address = NULL;
- /* Give the interpreter something to chew on, and ... */
-
+ /* Give the interpreter something to chew on, and ... */
Will_Push (CONTINUATION_SIZE);
Store_Return (RC_END_OF_COMPUTATION);
Store_Expression (SHARP_F);
Store_Expression (Init_Prog);
- /* Go to it! */
-
+ /* Go to it! */
if ((Stack_Pointer <= Stack_Guard) || (Free > MemTop))
{
fprintf (stderr, "Configuration won't hold initial data.\n");
Microcode_Termination (TERM_EXIT);
}
- Entry_Hook();
+ ENTRY_HOOK ();
Enter_Interpreter();
/*NOTREACHED*/
}
void
Enter_Interpreter()
{
- jmp_buf Orig_Eval_Point;
- Back_To_Eval = ((jmp_buf *) Orig_Eval_Point);
Interpret (Was_Scheme_Dumped);
fprintf (stderr, "\nThe interpreter returned to top level!\n");
fflush (stderr);
/*NOTREACHED*/
}
\f
-void
-attempt_termination_backout (code)
- long code;
-{
- extern long death_blow;
- SCHEME_OBJECT Term_Vector;
- SCHEME_OBJECT Handler;
-
- if ((WITHIN_CRITICAL_SECTION_P ()) ||
- (code == TERM_HALT) ||
- (! (Valid_Fixed_Obj_Vector ())))
- return;
-
- Term_Vector = (Get_Fixed_Obj_Slot (Termination_Proc_Vector));
- if ((! (VECTOR_P (Term_Vector))) ||
- ((VECTOR_LENGTH (Term_Vector)) <= code))
- return;
-
- Handler = (VECTOR_REF (Term_Vector, code));
- if (Handler == SHARP_F)
- return;
-
- Will_Push (CONTINUATION_SIZE +
- STACK_ENV_EXTRA_SLOTS +
- ((code == TERM_NO_ERROR_HANDLER) ? 5 : 4));
- Store_Return (RC_HALT);
- Store_Expression (LONG_TO_UNSIGNED_FIXNUM (code));
- Save_Cont ();
- if (code == TERM_NO_ERROR_HANDLER)
- {
- Push (LONG_TO_UNSIGNED_FIXNUM (death_blow));
- }
- Push (Val); /* Arg 3 */
- Push (Fetch_Env ()); /* Arg 2 */
- Push (Fetch_Expression ()); /* Arg 1 */
- Push (Handler); /* The handler function */
- Push (STACK_FRAME_HEADER + ((code == TERM_NO_ERROR_HANDLER) ? 4 : 3));
- Pushed ();
- longjmp ((*Back_To_Eval), PRIM_NO_TRAP_APPLY);
- /*NOTREACHED*/
-}
-\f
-term_type
-Microcode_Termination(code)
- long code;
-{
- extern long death_blow;
- extern char *Term_Messages[];
- Boolean abnormal_p;
- long value;
- extern void OS_quit ();
-
- attempt_termination_backout(code);
-
- if (! inhibit_termination_messages)
- {
- putchar('\n');
- if ((code < 0) || (code > MAX_TERMINATION))
- printf ("Unknown termination code 0x%x", code);
- else
- printf("%s", Term_Messages [code]);
-
- if ((WITHIN_CRITICAL_SECTION_P()) &&
- (code != TERM_HALT))
- {
- printf(" within critical section \"%s\"",
- CRITICAL_SECTION_NAME());
- }
- printf(".\n");
- }
-
- switch(code)
- {
- case TERM_HALT:
- value = 0;
- abnormal_p = false;
- break;
-
- case TERM_END_OF_COMPUTATION:
- Print_Expression(Val, "Final result");
- putchar('\n');
- value = 0;
- abnormal_p = false;
- break;
-\f
-#ifdef unix
- case TERM_SIGNAL:
- {
- extern int assassin_signal;
- extern char * find_signal_name ();
-
- if ((! inhibit_termination_messages) &&
- (assassin_signal != 0))
- printf("Killed by %s.\n", (find_signal_name (assassin_signal)));
- goto normal_termination;
- }
-#endif
-
- case TERM_TRAP:
- /* This claims not to be abnormal so that the user will
- not be asked a second time about dumping core.
- */
- value = 1;
- abnormal_p = false;
- break;
-
- case TERM_NO_ERROR_HANDLER:
- /* This does not print a back trace because it was printed before
- getting here irrelevant of the state of Trace_On_Error.
- */
- value = 1;
- abnormal_p = true;
- if (death_blow == ERR_FASL_FILE_TOO_BIG)
- {
- extern void get_band_parameters();
- long heap_size, const_size;
-
- get_band_parameters(&heap_size, &const_size);
- printf("Try again with values at least as large as\n");
- printf(" -heap %d (%d + %d)\n",
- (MIN_HEAP_DELTA + unblocks(heap_size)),
- unblocks(heap_size), MIN_HEAP_DELTA);
- printf(" -constant %d\n", unblocks(const_size));
- }
- break;
-\f
- case TERM_NON_EXISTENT_CONTINUATION:
- printf("Return code = 0x%lx\n", Fetch_Return());
- goto normal_termination;
-
- case TERM_GC_OUT_OF_SPACE:
- printf("You are out of space at the end of a Garbage Collection!\n");
- printf("Free = 0x%lx; MemTop = 0x%lx; Heap_Top = 0x%lx\n",
- Free, MemTop, Heap_Top);
- printf("Words required = %ld; Words available = %ld\n",
- (MemTop - Free), GC_Space_Needed);
- goto normal_termination;
-
- default:
- normal_termination:
- value = 1;
- abnormal_p = true;
- if (Trace_On_Error)
- {
- printf("\n\n**** Stack trace ****\n\n");
- Back_Trace(stdout);
- }
- break;
- }
- OS_tty_flush_output ();
- OS_quit (code, abnormal_p);
- Reset_Memory ();
- Exit_Hook ();
- Exit_Scheme (value);
- /*NOTREACHED*/
-}
-\f
/* Garbage collection debugging utilities. */
extern SCHEME_OBJECT
\f
DEFINE_PRIMITIVE ("MICROCODE-TABLES-FILENAME", Prim_microcode_tables_filename, 0, 0, 0)
{
- fast char *From, *To;
- char *Prefix, *Suffix;
- fast long Count;
- long position;
- extern SCHEME_OBJECT allocate_string ();
- SCHEME_OBJECT Result;
PRIMITIVE_HEADER (0);
- if ((((position = (Parse_Option ("-utabmd", Saved_argc, Saved_argv, true)))
- != NOT_THERE) &&
- (position != (Saved_argc - 1))) ||
- (((position = (Parse_Option ("-utab", Saved_argc, Saved_argv, true)))
- != NOT_THERE) &&
- (position != (Saved_argc - 1))))
+ {
+ CONST char * file_name = (string_option_argument ("-utabmd"));
+ if (file_name == 0)
+ file_name = (string_option_argument ("-utab"));
+ if (file_name != 0)
+ PRIMITIVE_RETURN (char_pointer_to_string (file_name));
+ }
+ {
+ SCHEME_OBJECT result =
+ (allocate_string ((strlen (SCHEME_SOURCES_PATH))
+ + (strlen (UCODE_TABLES_FILENAME))));
+ char * scan_result = ((char *) (STRING_LOC (result, 0)));
{
- Prefix = "";
- Suffix = (Saved_argv [(position + 1)]);
+ CONST char * scan = SCHEME_SOURCES_PATH;
+ CONST char * end = (scan + (strlen (SCHEME_SOURCES_PATH)));
+ while (scan < end)
+ (*scan_result++) = (*scan++);
}
- else
{
- Prefix = SCHEME_SOURCES_PATH;
- Suffix = UCODE_TABLES_FILENAME;
+ CONST char * scan = UCODE_TABLES_FILENAME;
+ CONST char * end = (scan + (strlen (UCODE_TABLES_FILENAME)));
+ while (scan < end)
+ (*scan_result++) = (*scan++);
}
- /* Find the length of the combined string, and allocate. */
- Count = 0;
- for (From = Prefix; ((*From++) != '\0'); )
- Count += 1;
- for (From = Suffix; ((*From++) != '\0'); )
- Count += 1;
- /* Append both substrings. */
- Result = (allocate_string (Count));
- To = ((char *) (STRING_LOC (Result, 0)));
- for (From = (& (Prefix [0])); ((*From) != '\0'); )
- (*To++) = (*From++);
- for (From = (& (Suffix [0])); ((*From) != '\0'); )
- (*To++) = (*From++);
- PRIMITIVE_RETURN (Result);
+ PRIMITIVE_RETURN (result);
+ }
}
DEFINE_PRIMITIVE ("GET-COMMAND-LINE", Prim_get_command_line, 0, 0, 0)
{
- fast int i;
- fast SCHEME_OBJECT result;
- extern SCHEME_OBJECT allocate_marked_vector ();
PRIMITIVE_HEADER (0);
- result = (allocate_marked_vector (TC_VECTOR, Saved_argc, true));
- for (i = 0; (i < Saved_argc); i += 1)
- FAST_VECTOR_SET (result, i, (char_pointer_to_string (Saved_argv [i])));
- PRIMITIVE_RETURN (result);
+ {
+ SCHEME_OBJECT result = (allocate_marked_vector (TC_VECTOR, Saved_argc, 1));
+ CONST char ** scan = Saved_argv;
+ CONST char ** end = (scan + Saved_argc);
+ SCHEME_OBJECT * scan_result = (VECTOR_LOC (result, 0));
+ while (scan < end)
+ (*scan_result++) = (char_pointer_to_string (*scan++));
+ PRIMITIVE_RETURN (result);
+ }
}
### -*-Midas-*-
###
-### $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/cmpauxmd/mc68k.m4,v 1.12 1990/04/23 02:36:21 jinx Exp $
+### $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/cmpauxmd/mc68k.m4,v 1.13 1990/06/20 17:38:46 cph Exp $
###
### Copyright (c) 1989, 1990 Massachusetts Institute of Technology
###
switch_to_C_registers()
allocate_utility_result()
mov.l %d1,-(%sp) # only one argument
- mov.l extern_c_label(utility_table)+HEX(12)*4,%a0
+ ifdef(`SUNASM',
+ `lea extern_c_label(utility_table),%a0
+ mov.l HEX(12)*4(%a0),%a0',
+ `mov.l extern_c_label(utility_table)+HEX(12)*4,%a0')
utility_call(1) # one argument
\f
set tc_compiled_entry,HEX(28)
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/cmpint.c,v 1.27 1990/04/23 02:35:00 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/cmpint.c,v 1.28 1990/06/20 17:38:59 cph Exp $
Copyright (c) 1989, 1990 Massachusetts Institute of Technology
/* Macro imports */
-#include <setjmp.h>
#include <stdio.h>
+#include "oscond.h" /* Identify the operating system */
+#include "ansidecl.h" /* Macros to support ANSI declarations */
+#include "dstack.h" /* Dynamic-stack support */
#include "config.h" /* SCHEME_OBJECT type and machine dependencies */
#include "types.h" /* Needed by const.h */
#include "const.h" /* REGBLOCK_MINIMUM_LENGTH and PRIM_... codes */
#include "fixobj.h" /* To find the error handlers */
#include "stack.h" /* Stacks and stacklets */
#include "interp.h" /* Interpreter state and primitive destructuring */
-#include "default.h" /* Metering_Apply_Primitive */
+#include "default.h" /* various definitions */
#include "extern.h" /* External decls (missing Cont_Debug, etc.) */
#include "trap.h" /* UNASSIGNED_OBJECT, TRAP_EXTENSION_TYPE */
#include "prims.h" /* LEXPR */
\f
/* Imports from the rest of the "microcode" */
-extern term_type
- Microcode_Termination();
-
extern long
compiler_cache_operator(),
compiler_cache_lookup(),
*local_free = EMPTY_LIST;
return (PRIM_DONE);
}
-\f
else /* (delta > 0) */
{
/* The number of arguments passed is greater than the number of
SCHEME_OBJECT primitive;
long ignore_2, ignore_3, ignore_4;
{
- Metering_Apply_Primitive (Val, primitive);
- Pop_Primitive_Frame (PRIMITIVE_ARITY (primitive));
+ PRIMITIVE_APPLY (Val, primitive);
+ POP_PRIMITIVE_FRAME (PRIMITIVE_ARITY (primitive));
RETURN_TO_SCHEME (OBJECT_ADDRESS (STACK_POP ()));
}
SCHEME_OBJECT primitive;
long ignore_2, ignore_3, ignore_4;
{
- Metering_Apply_Primitive (Val, primitive);
- Pop_Primitive_Frame (((long) Regs[REGBLOCK_LEXPR_ACTUALS]));
+ PRIMITIVE_APPLY (Val, primitive);
+ POP_PRIMITIVE_FRAME (((long) Regs[REGBLOCK_LEXPR_ACTUALS]));
RETURN_TO_SCHEME (OBJECT_ADDRESS (STACK_POP ()));
}
\f
nactuals += 1;
goto callee_is_compiled;
}
-\f
case TC_PRIMITIVE:
{
/* This code depends on the fact that unimplemented
block_address[last_header_offset] =
(MAKE_LINKAGE_SECTION_HEADER (kind, total_count));
-\f
for (offset += 1; ((--count) >= 0); offset += entry_size)
{
SCHEME_OBJECT name;
{
return (comutil_apply (true_operator, nargs, 0, 0));
}
-\f
else /* Error or interrupt */
{
SCHEME_OBJECT trampoline, environment, name;
/* Discard name, env. and nargs */
- Stack_Pointer = (Simulate_Popping (3));
+ Stack_Pointer = (STACK_LOC (3));
old_trampoline = (OBJECT_ADDRESS (STACK_POP ()));
code_block = ((TRAMPOLINE_STORAGE (old_trampoline))[1]);
offset = (OBJECT_DATUM ((TRAMPOLINE_STORAGE (old_trampoline))[2]));
{
kind = KIND_ILLEGAL;
}
-\f
else
{
switch (((unsigned long) max_arity) & 0xff)
return (PRIM_DONE);
}
nmin = (COMPILED_ENTRY_MINIMUM_ARITY (entry));
-\f
if ((nmax > 1) && (nmin > 0) && (nmin <= nactuals) &&
(nactuals <= TRAMPOLINE_TABLE_SIZE) &&
(nmax <= (TRAMPOLINE_TABLE_SIZE + 1)))
extern void
store_variable_cache(),
- compiled_entry_type(),
- Microcode_Termination();
+ compiled_entry_type();
\f
SCHEME_OBJECT
Registers[REGBLOCK_MINIMUM_LENGTH],
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/cmpint.h,v 10.3 1989/09/20 23:06:45 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/cmpint.h,v 10.4 1990/06/20 17:39:09 cph Rel $
-Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
#define With_Stack_Gap(Gap_Size, Gap_Position, Code) \
{ \
- SCHEME_OBJECT *Saved_Destination; \
- fast SCHEME_OBJECT *Destination; \
- fast long size_to_move; \
- \
- size_to_move = (Gap_Position); \
- Destination = Simulate_Pushing(Gap_Size); \
- Saved_Destination = Destination; \
- while (--size_to_move >= 0) \
- { \
- Pop_Into(Destination, Pop()); \
- } \
+ fast long size_to_move = (Gap_Position); \
+ fast SCHEME_OBJECT * Destination = (STACK_LOC (- (Gap_Size))); \
+ SCHEME_OBJECT * Saved_Destination = Destination; \
+ while ((--size_to_move) >= 0) \
+ (STACK_LOCATIVE_POP (Destination)) = (STACK_POP ()); \
Code; \
Stack_Pointer = Saved_Destination; \
}
fast SCHEME_OBJECT *Source; \
\
size_to_move = (Gap_Position); \
- Source = Simulate_Popping(size_to_move); \
- Stack_Pointer = Simulate_Popping((Gap_Size) + size_to_move); \
+ Source = (STACK_LOC (size_to_move)); \
+ Stack_Pointer = (STACK_LOC ((Gap_Size) + size_to_move)); \
extra_code; \
while (--size_to_move >= 0) \
{ \
- Push(Push_From(Source)); \
+ STACK_PUSH (STACK_LOCATIVE_PUSH (Source)); \
} \
}
\f
long frame_size; \
\
frame_size = (nslots); \
- if (Stack_Ref(frame_size + CONTINUATION_RETURN_CODE) == \
+ if (STACK_REF(frame_size + CONTINUATION_RETURN_CODE) == \
(MAKE_OBJECT (TC_RETURN_CODE, RC_REENTER_COMPILED_CODE))) \
{ \
/* Merge compiled code segments on the stack. */ \
Close_Stack_Gap (CONTINUATION_SIZE, \
frame_size, \
{ \
- long segment_size; \
- \
- segment_size = \
+ long segment_size = \
(OBJECT_DATUM \
- (Stack_Ref \
+ (STACK_REF \
(CONTINUATION_EXPRESSION - \
CONTINUATION_SIZE))); \
- last_return_code = Simulate_Popping(segment_size); \
+ last_return_code = (STACK_LOC (segment_size)); \
}); \
/* Undo the subproblem rotation. */ \
Compiler_End_Subproblem(); \
With_Stack_Gap(1, \
frame_size, \
{ \
- last_return_code = &Top_Of_Stack(); \
- Push(return_to_interpreter); \
+ last_return_code = (STACK_LOC (0)); \
+ STACK_PUSH (return_to_interpreter); \
}); \
} \
}
#define execute_compiled_setup() \
{ \
- if (Stack_Ref(CONTINUATION_RETURN_CODE) == \
+ if (STACK_REF(CONTINUATION_RETURN_CODE) == \
(MAKE_OBJECT (TC_RETURN_CODE, RC_REENTER_COMPILED_CODE))) \
{ \
/* Merge compiled code segments on the stack. */ \
\
Restore_Cont(); \
segment_size = OBJECT_DATUM (Fetch_Expression()); \
- last_return_code = Simulate_Popping(segment_size); \
+ last_return_code = (STACK_LOC (segment_size)); \
/* Undo the subproblem rotation. */ \
Compiler_End_Subproblem(); \
} \
{ \
/* Make a new compiled code segment on the stack. */ \
/* History need not be hacked here. */ \
- last_return_code = &Top_Of_Stack(); \
- Push(return_to_interpreter); \
+ last_return_code = (STACK_LOC (0)); \
+ STACK_PUSH (return_to_interpreter); \
} \
}
#define compiled_code_restart() \
{ \
- long segment_size; \
- \
- segment_size = OBJECT_DATUM (Fetch_Expression()); \
- last_return_code = Simulate_Popping(segment_size); \
+ long segment_size = OBJECT_DATUM (Fetch_Expression()); \
+ last_return_code = (STACK_LOC (segment_size)); \
/* Undo the subproblem rotation. */ \
Compiler_End_Subproblem(); \
}
#define compiler_apply_procedure(nslots) \
{ \
- long frame_size; \
- \
- frame_size = (nslots); \
- if (Stack_Ref( frame_size) == return_to_interpreter) \
+ long frame_size = (nslots); \
+ if ((STACK_REF (frame_size)) == return_to_interpreter) \
{ \
Close_Stack_Gap(1, frame_size, {}); \
/* Set up the current rib. */ \
- Compiler_New_Reduction(); \
+ Compiler_New_Reduction (); \
} \
else \
{ /* Make a new interpreter segment which includes this frame. */ \
(CONTINUATION_SIZE, \
frame_size, \
{ \
- long segment_size; \
- \
- segment_size = Stack_Distance(last_return_code); \
- Store_Expression(LONG_TO_UNSIGNED_FIXNUM(segment_size)); \
- Store_Return(RC_REENTER_COMPILED_CODE); \
- Save_Cont(); \
+ long segment_size = \
+ (STACK_LOCATIVE_DIFFERENCE \
+ (last_return_code, (STACK_LOC (0)))); \
+ Store_Expression (LONG_TO_UNSIGNED_FIXNUM (segment_size)); \
+ Store_Return (RC_REENTER_COMPILED_CODE); \
+ Save_Cont (); \
}); \
/* Rotate history to a new subproblem. */ \
- Compiler_New_Subproblem(); \
+ Compiler_New_Subproblem (); \
} \
}
#define apply_compiled_backout() \
{ \
compiler_apply_procedure(STACK_ENV_EXTRA_SLOTS + \
- OBJECT_DATUM (Stack_Ref (STACK_ENV_HEADER)));\
+ OBJECT_DATUM (STACK_REF (STACK_ENV_HEADER)));\
}
/* Backing out of eval. */
#define execute_compiled_backout() \
{ \
- if (Top_Of_Stack() == return_to_interpreter) \
+ if ((STACK_REF (0)) == return_to_interpreter) \
{ \
- Simulate_Popping(1); \
/* Set up the current rib. */ \
- Compiler_New_Reduction(); \
+ Compiler_New_Reduction (); \
} \
else \
{ \
- long segment_size; \
- \
- segment_size = Stack_Distance(last_return_code); \
- Store_Expression(LONG_TO_UNSIGNED_FIXNUM(segment_size)); \
- Store_Return(RC_REENTER_COMPILED_CODE); \
- Save_Cont(); \
+ long segment_size = \
+ (STACK_LOCATIVE_DIFFERENCE (last_return_code, (STACK_LOC (0)))); \
+ Store_Expression (LONG_TO_UNSIGNED_FIXNUM (segment_size)); \
+ Store_Return (RC_REENTER_COMPILED_CODE); \
+ Save_Cont (); \
/* Rotate history to a new subproblem. */ \
- Compiler_New_Subproblem(); \
+ Compiler_New_Subproblem (); \
} \
}
long segment_size; \
\
Restore_Cont(); \
- segment_size = Stack_Distance(last_return_code); \
- Store_Expression(LONG_TO_UNSIGNED_FIXNUM(segment_size)); \
+ segment_size = \
+ (STACK_LOCATIVE_DIFFERENCE (last_return_code, (STACK_LOC (0)))); \
+ Store_Expression (LONG_TO_UNSIGNED_FIXNUM (segment_size)); \
/* The Store_Return is a NOP, the Save_Cont is done by the code \
- that follows. \
- */ \
+ that follows. */ \
/* Store_Return (OBJECT_DATUM (Fetch_Return ())); */ \
- /* Save_Cont(); */ \
- Compiler_New_Subproblem(); \
+ /* Save_Cont (); */ \
+ Compiler_New_Subproblem (); \
}
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/cmpintmd/mc68k.h,v 1.13 1990/04/23 02:35:49 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/cmpintmd/mc68k.h,v 1.14 1990/06/20 17:38:53 cph Exp $
Copyright (c) 1989, 1990 Massachusetts Institute of Technology
#define SETUP_REGISTER(hook) do \
{ \
+ extern unsigned long hook; \
+ (* ((unsigned short *) (a6_value + offset))) = 0x4ef9; \
#define SETUP_REGISTER(hook) \
(((unsigned short *) (a6_value + offset)) + 1))) = \
- extern void hook(); \
- \
+ ((unsigned long) (&hook)); \
+ offset += (COMPILER_HOOK_SIZE * (sizeof (SCHEME_OBJECT))); \
+} while (0)
+
+#else /* not CAST_FUNCTION_TO_INT_BUG */
+
+}
+{ \
+ extern void EXFUN (hook, (void)); \
+ (* ((unsigned short *) (a6_value + offset))) = 0x4ef9; \
+#define SETUP_REGISTER(hook) \
+ (((unsigned short *) (a6_value + offset)) + 1))) = \
+ ((unsigned long) hook); \
offset += (COMPILER_HOOK_SIZE * (sizeof (SCHEME_OBJECT))); \
} while (0)
\f
}
DEFUN_VOID (mc68k_reset_hook)
+{
+
mc68k_reset_hook ()
int offset = (COMPILER_REGBLOCK_N_FIXED * (sizeof (SCHEME_OBJECT)));
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/config.h,v 9.54 1990/04/12 21:05:34 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/config.h,v 9.55 1990/06/20 17:39:15 cph Exp $
Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
#endif /* VMS */
#endif /* vax */
\f
-#ifdef hp9000s200 /* and s300, pretty indistinguishable */
-#define MACHINE_TYPE "hp9000s200"
+#ifdef hp9000s300
+#define MACHINE_TYPE "hp9000s300"
#define HEAP_IN_LOW_MEMORY
#define UNSIGNED_SHIFT
#define CHAR_BIT 8
#define Or3(x, y, z) ((x) ? true : ((y) ? true : (z)))
#endif
\f
-#ifdef sun
+#ifdef sun4
+#define MACHINE_TYPE "sun4"
#define HEAP_IN_LOW_MEMORY
#define UNSIGNED_SHIFT
#define CHAR_BIT 8
#define USHORT_SIZE 16
#define ULONG_SIZE 32
#define BELL '\007'
-
+#define FASL_INTERNAL_FORMAT FASL_SUN4
/* #define FLONUM_EXPT_SIZE 10 */
/* #define FLONUM_MANTISSA_BITS 53 */
/* #define MAX_FLONUM_EXPONENT 1023 */
-
-#ifdef sun4
-#define MACHINE_TYPE "sun4"
-#define FASL_INTERNAL_FORMAT FASL_SUN4
#define FLOATING_ALIGNMENT 0x7 /* Low 3 MBZ for float storage */
+#define HAS_FLOOR
+#define HAS_FREXP
+#define HAS_MODF
+#define HAVE_DOUBLE_TO_LONG_BUG
#endif
#ifdef sun3
#define MACHINE_TYPE "sun3"
+#define HEAP_IN_LOW_MEMORY
+#define UNSIGNED_SHIFT
+#define CHAR_BIT 8
+#define USHORT_SIZE 16
+#define ULONG_SIZE 32
+#define BELL '\007'
#define FASL_INTERNAL_FORMAT FASL_68020
+/* #define FLONUM_EXPT_SIZE 10 */
+/* #define FLONUM_MANTISSA_BITS 53 */
+/* #define MAX_FLONUM_EXPONENT 1023 */
+#define HAS_FLOOR
+#define HAS_FREXP
+#define HAS_MODF
+#define HAVE_DOUBLE_TO_LONG_BUG
#endif
-#ifndef FASL_INTERNAL_FORMAT
+#ifdef sun2
#define MACHINE_TYPE "sun2"
+#define HEAP_IN_LOW_MEMORY
+#define UNSIGNED_SHIFT
+#define CHAR_BIT 8
+#define USHORT_SIZE 16
+#define ULONG_SIZE 32
+#define BELL '\007'
#define FASL_INTERNAL_FORMAT FASL_68000
-#endif
-
+/* #define FLONUM_EXPT_SIZE 10 */
+/* #define FLONUM_MANTISSA_BITS 53 */
+/* #define MAX_FLONUM_EXPONENT 1023 */
#define HAS_FLOOR
#define HAS_FREXP
#define HAS_MODF
#define HAVE_DOUBLE_TO_LONG_BUG
-
-#endif /* sun */
+#endif
#ifdef butterfly
#define MACHINE_TYPE "butterfly"
#define COMPILER_CONSTANT_SIZE 1300
#endif
-#endif /* spectrum */
+#endif /* hp9000s800 */
\f
#ifdef umax
#define MACHINE_TYPE "umax"
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/const.h,v 9.35 1989/09/20 23:07:12 cph Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/const.h,v 9.36 1990/06/20 17:39:29 cph Rel $
*
* Named constants used throughout the interpreter
*
#endif /* SHARP_F */
#define EMPTY_LIST SHARP_F
-#define NOT_THERE -1 /* Command line parser */
\f
/* Assorted sizes used in various places */
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/daemon.c,v 9.27 1989/09/20 23:07:22 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/daemon.c,v 9.28 1990/06/20 17:39:39 cph Rel $
Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
#include "scheme.h"
#include "prims.h"
+#include "osio.h"
\f
/* (CLOSE-LOST-OPEN-FILES file-list)
file-list is an assq-like list where the associations are weak
DEFINE_PRIMITIVE ("CLOSE-LOST-OPEN-FILES", Prim_close_lost_open_files, 1, 1, 0)
{
- extern Boolean OS_file_close();
- fast SCHEME_OBJECT *Smash, Cell, Weak_Cell, Value;
- fast SCHEME_OBJECT file_list;
- long channel_number;
PRIMITIVE_HEADER (1);
- file_list = (ARG_REF (1));
- Value = SHARP_T;
- for (Smash = PAIR_CDR_LOC (file_list), Cell = *Smash;
- Cell != EMPTY_LIST;
- Cell = *Smash)
{
- Weak_Cell = (FAST_PAIR_CAR (Cell));
- if ((FAST_PAIR_CAR (Weak_Cell)) == SHARP_F)
+ SCHEME_OBJECT file_list = (ARG_REF (1));
+ SCHEME_OBJECT * smash = (PAIR_CDR_LOC (file_list));
+ SCHEME_OBJECT cell = (*smash);
+ while (cell != EMPTY_LIST)
{
- channel_number = (UNSIGNED_FIXNUM_TO_LONG (FAST_PAIR_CDR (Weak_Cell)));
- if (!OS_file_close (Channels[channel_number]))
- Value = SHARP_F;
- (Channels [channel_number]) = NULL;
- (*Smash) = (FAST_PAIR_CDR (Cell));
+ SCHEME_OBJECT weak_cell = (FAST_PAIR_CAR (cell));
+ if ((FAST_PAIR_CAR (weak_cell)) == SHARP_F)
+ {
+ OS_channel_close
+ (UNSIGNED_FIXNUM_TO_LONG (FAST_PAIR_CDR (weak_cell)));
+ cell = (FAST_PAIR_CDR (cell));
+ (*smash) = cell;
+ }
+ else
+ {
+ smash = (PAIR_CDR_LOC (cell));
+ cell = (*smash);
+ }
}
- else
- Smash = PAIR_CDR_LOC (Cell);
}
- PRIMITIVE_RETURN (Value);
+ PRIMITIVE_RETURN (UNSPECIFIC);
}
\f
/* Utilities for the rehash daemon below */
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/debug.c,v 9.34 1989/09/20 23:07:26 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/debug.c,v 9.35 1990/06/20 17:39:45 cph Exp $
-Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
Print_Expression (Temp, "Return code");
printf ("\n");
- Expr = (Pop ());
+ Expr = (STACK_POP ());
Print_Expression (Expr, "Expression");
printf ("\n");
if (((OBJECT_DATUM (Temp)) == RC_END_OF_COMPUTATION) ||
Old_Stack = Stack_Pointer;
while (true)
{
- if (Return_Hook_Address == &Top_Of_Stack())
+ if (Return_Hook_Address == (STACK_LOC (0)))
{
- Temp = Pop();
+ Temp = (STACK_POP ());
if (Temp != MAKE_OBJECT (TC_RETURN_CODE, RC_RETURN_TRAP_POINT))
{
printf ("\n--> Return trap is missing here <--\n");
}
else
{
- Temp = Pop();
+ Temp = (STACK_POP ());
}
if ((OBJECT_TYPE (Temp)) == TC_RETURN_CODE)
{
Print_Expression(Temp, " ...");
if ((OBJECT_TYPE (Temp)) == TC_MANIFEST_NM_VECTOR)
{
- Stack_Pointer = Simulate_Popping(OBJECT_DATUM (Temp));
+ Stack_Pointer = (STACK_LOC (- (OBJECT_DATUM (Temp))));
printf (" (skipping)");
}
printf ("\n");
for (i = 0; i < NArgs; i++)
{
- sprintf (buffer1, "Stack_Ref(%d)", i);
+ sprintf (buffer1, "STACK_REF (%d)", i);
sprintf (buffer2, "...Arg %d", (i + 1));
Print_Expression(buffer1, buffer2);
printf ("\n");
}
\f
/* Code for interactively setting and clearing the interpreter
- debugging flags. Invoked via the "D" command to the ^B
- handler or during each FASLOAD.
-*/
+ debugging flags. Invoked via the "D" command to the ^C
+ handler or during each FASLOAD. */
#ifdef ENABLE_DEBUGGING_TOOLS
+
+#ifndef MORE_DEBUG_FLAG_CASES
+#define MORE_DEBUG_FLAG_CASES()
+#endif
+
+#ifndef MORE_DEBUG_FLAG_NAMES
+#define MORE_DEBUG_FLAG_NAMES()
+#endif
+
+#ifndef SET_FLAG_HOOK
+#define SET_FLAG_HOOK()
+#endif
+
+#ifndef DEBUG_GETDEC
+#define DEBUG_GETDEC debug_getdec
+#endif
+
#define D_EVAL 0
#define D_HEX_INPUT 1
#define D_FILE_LOAD 2
#define D_PER_FILE 13
#define D_BIGNUM 14
#define D_FLUIDS 15
-#define LAST_NORMAL_SWITCH 15
-
-Boolean *
-Find_Flag (Num)
- int Num;
-{ switch (Num)
- { case D_EVAL: return &Eval_Debug;
- case D_HEX_INPUT: return &Hex_Input_Debug;
- case D_FILE_LOAD: return &File_Load_Debug;
- case D_RELOC: return &Reloc_Debug;
- case D_INTERN: return &Intern_Debug;
- case D_CONT: return &Cont_Debug;
- case D_PRIMITIVE: return &Primitive_Debug;
- case D_LOOKUP: return &Lookup_Debug ;
- case D_DEFINE: return &Define_Debug;
- case D_GC: return &GC_Debug;
- case D_UPGRADE: return &Upgrade_Debug;
- case D_DUMP: return &Dump_Debug;
- case D_TRACE_ON_ERROR: return &Trace_On_Error;
- case D_PER_FILE: return &Per_File;
- case D_BIGNUM: return &Bignum_Debug;
- case D_FLUIDS: return &Fluids_Debug;
- More_Debug_Flag_Cases();
- default: show_flags(true); return NULL;
- }
+
+#ifndef LAST_SWITCH
+#define LAST_SWITCH D_FLUIDS
+#endif
+
+static Boolean *
+DEFUN (find_flag, (flag_number), int flag_number)
+{
+ switch (flag_number)
+ {
+ case D_EVAL: return (&Eval_Debug);
+ case D_HEX_INPUT: return (&Hex_Input_Debug);
+ case D_FILE_LOAD: return (&File_Load_Debug);
+ case D_RELOC: return (&Reloc_Debug);
+ case D_INTERN: return (&Intern_Debug);
+ case D_CONT: return (&Cont_Debug);
+ case D_PRIMITIVE: return (&Primitive_Debug);
+ case D_LOOKUP: return (&Lookup_Debug) ;
+ case D_DEFINE: return (&Define_Debug);
+ case D_GC: return (&GC_Debug);
+ case D_UPGRADE: return (&Upgrade_Debug);
+ case D_DUMP: return (&Dump_Debug);
+ case D_TRACE_ON_ERROR: return (&Trace_On_Error);
+ case D_PER_FILE: return (&Per_File);
+ case D_BIGNUM: return (&Bignum_Debug);
+ case D_FLUIDS: return (&Fluids_Debug);
+ MORE_DEBUG_FLAG_CASES ();
+ default: return (0);
+ }
}
-\f
-int
-set_flag (Num, Value)
- int Num;
- Boolean Value;
-{ Boolean *Flag = Find_Flag(Num);
- if (Flag != NULL) *Flag = Value;
- Set_Flag_Hook();
+
+static char *
+DEFUN (flag_name, (flag_number), int flag_number)
+{
+ switch (flag_number)
+ {
+ case D_EVAL: return ("Eval_Debug");
+ case D_HEX_INPUT: return ("Hex_Input_Debug");
+ case D_FILE_LOAD: return ("File_Load_Debug");
+ case D_RELOC: return ("Reloc_Debug");
+ case D_INTERN: return ("Intern_Debug");
+ case D_CONT: return ("Cont_Debug");
+ case D_PRIMITIVE: return ("Primitive_Debug");
+ case D_LOOKUP: return ("Lookup_Debug");
+ case D_DEFINE: return ("Define_Debug");
+ case D_GC: return ("GC_Debug");
+ case D_UPGRADE: return ("Upgrade_Debug");
+ case D_DUMP: return ("Dump_Debug");
+ case D_TRACE_ON_ERROR: return ("Trace_On_Error");
+ case D_PER_FILE: return ("Per_File");
+ case D_BIGNUM: return ("Bignum_Debug");
+ case D_FLUIDS: return ("Fluids_Debug");
+ MORE_DEBUG_FLAG_NAMES ();
+ default: return ("Unknown Debug Flag");
+ }
}
-char *
-Flag_Name (Num)
- int Num;
-{ switch(Num)
- { case D_EVAL: return "Eval_Debug";
- case D_HEX_INPUT: return "Hex_Input_Debug";
- case D_FILE_LOAD: return "File_Load_Debug";
- case D_RELOC: return "Reloc_Debug";
- case D_INTERN: return "Intern_Debug";
- case D_CONT: return "Cont_Debug";
- case D_PRIMITIVE: return "Primitive_Debug";
- case D_LOOKUP: return "Lookup_Debug";
- case D_DEFINE: return "Define_Debug";
- case D_GC: return "GC_Debug";
- case D_UPGRADE: return "Upgrade_Debug";
- case D_DUMP: return "Dump_Debug";
- case D_TRACE_ON_ERROR: return "Trace_On_Error";
- case D_PER_FILE: return "Per_File";
- case D_BIGNUM: return "Bignum_Debug";
- case D_FLUIDS: return "Fluids_Debug";
- More_Debug_Flag_Names();
- default: return "Unknown Debug Flag";
- }
+static void
+DEFUN (show_flags, (all), int all)
+{
+ int i;
+ for (i = 0; (i <= LAST_SWITCH); i += 1)
+ {
+ int value = (* (find_flag (i)));
+ if (all || value)
+ fprintf (stdout, "Flag %d (%s) is %s.\n",
+ i, (flag_name (i)), (Value ? "set" : "clear"));
+ }
+ fflush (stdout);
}
-\f
-int
-show_flags (All)
- Boolean All;
-{ int i;
- for (i=0; i <= LAST_SWITCH; i++)
- { Boolean Value = *Find_Flag(i);
- if (All || Value)
- { printf ("Flag %d (%s) is %s.\n",
- i, Flag_Name(i), Value? "set" : "clear");
+
+static int
+DEFUN (set_flag, (flag_number, value), int flag_number AND int value)
+{
+ Boolean * flag = (find_flag (flag_number));
+ if (flag == 0)
+ show_flags (1);
+ else
+ {
+ (*flag) = value;
+ SET_FLAG_HOOK (flag);
}
- }
}
-extern int OS_tty_tyi();
+static int
+DEFUN (debug_getdec, (string), CONST char * string)
+{
+ int result;
+ sscanf (string, "%d", (&result));
+ return (result);
+}
-#define C_STRING_LENGTH 256
-\f
void
-Handle_Debug_Flags ()
-{ char c, input_string[C_STRING_LENGTH];
- int Which, free;
- Boolean interrupted;
- show_flags(false);
- while (true)
- { interrupted = false;
- printf ("Clear<number>, Set<number>, Done, ?, or Halt: ");
- OS_tty_flush_output();
-
- /* Considerably haired up to go through standard (safe) interface */
-
- c = (char) OS_tty_tyi(false, &interrupted);
- if (interrupted) return;
- for (free = 0; free < C_STRING_LENGTH; free++)
- { input_string[free] = OS_tty_tyi(false, &interrupted);
- if (interrupted) return;
- if (input_string[free] == '\n')
- { input_string[free] = '\0';
- break;
+DEFUN_VOID (debug_edit_flags)
+{
+ char input_line [256];
+ show_flags (0);
+ while (1)
+ {
+ fputs ("Clear<number>, Set<number>, Done, ?, or Halt: ", stdout);
+ fflush (stdout);
+ {
+ fgets (input_line, (sizeof (input_line)), stdin);
+ switch (input_line[0])
+ {
+ case 'c':
+ case 'C':
+ set_flag ((DEBUG_GETDEC (input_string)), 0);
+ break;
+ case 's':
+ case 'S':
+ set_flag ((DEBUG_GETDEC (input_string)), 1);
+ break;
+ case 'd':
+ case 'D':
+ return;
+ case 'h':
+ case 'H':
+ termination_normal ();
+ case '?':
+ default:
+ show_flags (1);
+ break;
+ }
}
}
- switch (c)
- { case 'c':
- case 'C': Which=debug_getdec(input_string);
- set_flag(Which, false);
- break;
- case 's':
- case 'S': Which=debug_getdec(input_string);
- set_flag(Which, true);
- break;
- case 'd':
- case 'D': return;
- case 'h':
- case 'H': Microcode_Termination(TERM_HALT);
-
- case '?':
- default : show_flags(true);
- break;
- }
- }
}
-int
-normal_debug_getdec (str)
- int str;
-{ int Result;
- sscanf(str, "%d", &Result);
- return Result;
-}
+#else /* not ENABLE_DEBUGGING_TOOLS */
-#else /* ENABLE_DEBUGGING_TOOLS */
void
-Handle_Debug_Flags ()
-{ fprintf (stderr, "Not a debugging version. No flags to handle.\n");
- return;
+DEFUN_VOID (debug_edit_flags)
+{
+ fprintf (stderr, "Not a debugging version. No flags to handle.\n");
+ fflush (stderr);
}
+
#endif /* not ENABLE_DEBUGGING_TOOLS */
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/default.h,v 9.32 1989/09/20 23:07:30 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/default.h,v 9.33 1990/06/20 17:39:53 cph Exp $
-Copyright (c) 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
(* (locative)) = (object); \
}
#endif
-\f
+
#ifndef USE_STACKLETS
#define Absolute_Stack_Base Constant_Top
#ifndef Exit_Scheme
#define Exit_Scheme exit
#endif
-\f
+
/* Used in various places. */
#ifndef Init_Fixed_Objects
Fixed_Objects = New_Vector
#endif
-#ifndef Entry_Hook
-#define Entry_Hook()
-#endif
-
-#ifndef Exit_Hook
-#define Exit_Hook()
-#endif
-
-#ifndef Sys_Clock
-#define Sys_Clock() ((OS_process_clock ()) * 10)
-#endif
-\f
/* Used in debug.c */
#ifndef Back_Trace_Entry_Hook
#define Back_Trace_Exit_Hook()
#endif
-#ifndef More_Debug_Flag_Cases
-#define More_Debug_Flag_Cases()
-#endif
-
-#ifndef Set_Flag_Hook
-#define Set_Flag_Hook()
-#endif
-
-#ifndef More_Debug_Flag_Names
-#define More_Debug_Flag_Names()
-#endif
-
-#ifndef LAST_SWITCH
-#define LAST_SWITCH LAST_NORMAL_SWITCH
-#endif
-
-#ifndef debug_getdec
-#define debug_getdec normal_debug_getdec
-#endif
-\f
/* Used in extern.h */
#ifndef More_Debug_Flag_Externs
NewFree = Unused_Heap; \
NewMemTop = Unused_Heap_Top
#endif
-
-/* Used in fasload.c */
-
-#ifndef Open_File_Hook
-#define Open_File_Hook(ignore)
-#endif
-
-#ifndef Close_File_Hook
-#define Close_File_Hook()
-#endif
\f
/* Used in interpret.c */
-/* Primitive calling code. */
-
-#ifndef ENABLE_DEBUGGING_TOOLS
-#define APPLY_PRIMITIVE INTERNAL_APPLY_PRIMITIVE
-#else
-extern SCHEME_OBJECT Apply_Primitive();
-#define APPLY_PRIMITIVE(Loc, N) \
-{ \
- Loc = Apply_Primitive(N); \
-}
-#endif
-
-#ifndef Metering_Apply_Primitive
-#define Metering_Apply_Primitive APPLY_PRIMITIVE
-#endif
-
#ifndef Eval_Ucode_Hook
#define Eval_Ucode_Hook()
#endif
#ifndef End_GC_Hook
#define End_GC_Hook()
#endif
-\f
+
/* Used in storage.c */
#ifndef More_Debug_Flag_Allocs
#ifndef Error_Exit_Hook
#define Error_Exit_Hook()
#endif
-\f
+
/* Common Lisp Hooks */
#ifndef SITE_EXPRESSION_DISPATCH_HOOK
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/dmpwrld.c,v 9.30 1989/09/20 23:07:35 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/dmpwrld.c,v 9.31 1990/06/20 17:40:00 cph Exp $
-Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
#define UNEXEC_AVAILABLE
#endif
-#ifdef hp9000s200
+#ifdef hp9000s300
#define UNEXEC_AVAILABLE
#define ADJUST_EXEC_HEADER \
hdr.a_magic = ((ohdr.a_magic.file_type == OLDMAGIC.file_type) ? \
(((((unsigned) &etext) - 1) & ~SEGMENT_MASK) + (SEGMENT_MASK + 1))
#endif
-#ifdef hpux
+#ifdef _HPUX
#define USG
#define HPUX
#endif
Was_Scheme_Dumped = true;
Val = SHARP_T;
OS_quit (TERM_HALT, false);
- Pop_Primitive_Frame(1);
+ POP_PRIMITIVE_FRAME (1);
/* Dump! */
if (Result != 0)
{
- Push (ARG_REF (1)); /* Since popped above */
+ STACK_PUSH (ARG_REF (1)); /* Since popped above */
error_external_return ();
}
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/extern.h,v 9.35 1989/09/25 16:51:09 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/extern.h,v 9.36 1990/06/20 17:40:07 cph Exp $
-Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
\f
#ifdef ENABLE_DEBUGGING_TOOLS
-extern Boolean Eval_Debug, Hex_Input_Debug, Cont_Debug,
- File_Load_Debug, Reloc_Debug, Intern_Debug,
- Primitive_Debug, Define_Debug, Lookup_Debug, GC_Debug,
- Upgrade_Debug, Trace_On_Error, Dump_Debug, Per_File,
- Bignum_Debug, Fluids_Debug;
+extern Boolean Eval_Debug;
+extern Boolean Hex_Input_Debug;
+extern Boolean Cont_Debug;
+extern Boolean File_Load_Debug;
+extern Boolean Reloc_Debug;
+extern Boolean Intern_Debug;
+extern Boolean Primitive_Debug;
+extern Boolean Define_Debug;
+extern Boolean Lookup_Debug;
+extern Boolean GC_Debug;
+extern Boolean Upgrade_Debug;
+extern Boolean Trace_On_Error;
+extern Boolean Dump_Debug;
+extern Boolean Per_File;
+extern Boolean Bignum_Debug;
+extern Boolean Fluids_Debug;
extern sp_record_list SP_List;
-extern void Pop_Return_Break_Point();
-extern int debug_slotno, debug_nslots, local_slotno, local_nslots,
- debug_circle[], local_circle[];
+extern void Pop_Return_Break_Point ();
+extern int debug_slotno;
+extern int debug_nslots;
+extern int local_slotno;
+extern int local_nslots;
+extern int debug_circle [];
+extern int local_circle [];
#else /* not ENABLE_DEBUGGING_TOOLS */
* Local_Heap_Base, /* Per-processor CONSing area */
* Heap, /* Bottom of all heap space */
Current_State_Point, /* Dynamic state point */
- Fluid_Bindings, /* Fluid bindings AList */
-
- /* Address of the most recent return code in the stack. This is
- only meaningful while in compiled code. *** This must be changed
- when stacklets are used. *** */
- * last_return_code,
+ Fluid_Bindings; /* Fluid bindings AList */
+\f
+/* Address of the most recent return code in the stack. This is
+ only meaningful while in compiled code. *** This must be changed
+ when stacklets are used. *** */
+extern SCHEME_OBJECT * last_return_code;
- /* Return code/address used by the compiled code interface to make
- compiled code return to the interpreter. */
- return_to_interpreter;
+/* Return code/address used by the compiled code interface to make
+ compiled code return to the interpreter. */
+extern SCHEME_OBJECT return_to_interpreter;
extern Declare_Fixed_Objects ();
-\f
+
extern long
IntCode, /* Interrupts requesting */
IntEnb, /* Interrupts enabled */
extern int GC_Type_Map [];
-extern FILE * (Channels [FILE_CHANNELS]);
-extern Boolean Photo_Open;
-extern FILE * Photo_File_Handle;
-
-extern jmp_buf * Back_To_Eval;
extern Boolean Trapping;
extern SCHEME_OBJECT Old_Return_Code;
extern SCHEME_OBJECT * Return_Hook_Address;
extern long Prev_Restore_History_Offset;
extern int Saved_argc;
-extern char ** Saved_argv;
-
-extern char * OS_Name;
-extern char * OS_Variant;
+extern CONST char ** Saved_argv;
+extern CONST char * OS_Name;
+extern CONST char * OS_Variant;
+extern struct obstack scratch_obstack;
extern long Heap_Size;
extern long Constant_Size;
extern SCHEME_OBJECT char_pointer_to_string ();
/* Random and OS utilities */
-extern int Parse_Option ();
+extern int EXFUN (boolean_option_argument, (CONST char * name));
+extern CONST char * EXFUN (string_option_argument, (CONST char * name));
+extern long EXFUN (numeric_option_argument, (CONST char * name, long defval));
extern Boolean Restore_History ();
-extern long OS_tty_x_size ();
-extern long OS_tty_y_size ();
-extern long OS_process_clock ();
-extern void OS_tty_flush_output ();
-extern void OS_reinitialize ();
extern Boolean interpreter_applicable_p ();
/* Memory management utilities */
\f
/* Interpreter utilities */
-extern term_type Microcode_Termination ();
+extern void EXFUN (Microcode_Termination, (int code));
+extern void EXFUN (termination_normal, (void));
+extern void EXFUN (termination_end_of_computation, (void));
+extern void EXFUN (termination_trap, (void));
+extern void EXFUN (termination_no_error_handler, (void));
+extern void EXFUN (termination_gc_out_of_space, (void));
+extern void EXFUN (termination_eof, (void));
+extern void EXFUN (termination_signal, (CONST char * signal_name));
+
extern void
Interpret (),
Do_Micro_Error (),
/* Debugging utilities */
+extern void EXFUN (debug_edit_flags, (void));
+
extern void
Back_Trace (),
- Handle_Debug_Flags (),
Show_Env (),
Show_Pure (),
Print_Return (),
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasdump.c,v 9.47 1990/01/31 05:01:53 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasdump.c,v 9.48 1990/06/20 17:40:13 cph Exp $
Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
#include "scheme.h"
#include "prims.h"
+#include "osio.h"
+#include "osfile.h"
+#include "osfs.h"
#define In_Fasdump
#include "gccode.h"
#include "trap.h"
#include "lookup.h"
#include "fasl.h"
+
+static Tchannel dump_channel;
+
+#define Write_Data(size, buffer) \
+ ((OS_channel_write_dump_file \
+ (dump_channel, (buffer), ((size) * (sizeof (SCHEME_OBJECT))))) \
+ / (sizeof (SCHEME_OBJECT)))
+
#include "dump.c"
extern SCHEME_OBJECT
*initialize_primitive_table(),
*cons_primitive_table(),
*cons_whole_primitive_table();
-
-extern Boolean
- OS_file_remove();
\f
/* Some statics used freely in this file */
static SCHEME_OBJECT *NewFree, *NewMemTop, *Fixup, *Orig_New_Free;
static Boolean compiled_code_present_p;
-static unsigned char *dump_file_name = ((unsigned char *) NULL);
+static CONST char * dump_file_name = 0;
/* FASDUMP:
fast SCHEME_OBJECT *Fixes;
Fixes = Fixup;
- result = ((close_p) ? (Close_Dump_File ()) : true);
+ if (close_p)
+ OS_channel_close_noerror (dump_channel);
+ result = true;
while (Fixes != NewMemTop)
{
fast SCHEME_OBJECT *Fix_Address;
}
Fixup = Fixes;
if ((close_p) && ((!result) || (code != PRIM_DONE)))
- {
- result = ((OS_file_remove (dump_file_name)) && result);
- }
- dump_file_name = ((unsigned char *) NULL);
- Fasdump_Exit_Hook();
+ OS_file_remove (dump_file_name);
+ dump_file_name = 0;
+ Fasdump_Exit_Hook ();
if (!result)
{
signal_error_from_primitive (ERR_IO_ERROR);
{
Primitive_GC (table_start - Free);
}
- dump_file_name = (STRING_LOC (File_Name, 0));
+ dump_file_name = ((CONST char *) (STRING_LOC (File_Name, 0)));
Fasdump_Free_Calc(NewFree, NewMemTop, Orig_New_Free);
Fixup = NewMemTop;
ALIGN_FLOAT (NewFree);
{
FASDUMP_INTERRUPT();
}
- if (! (Open_Dump_File (File_Name, WRITE_FLAG)))
- {
+ dump_channel = (OS_open_dump_file (STRING_LOC (File_Name, 0)));
+ if (dump_channel == NO_CHANNEL)
PRIMITIVE_RETURN (Fasdump_Exit (ERR_ARG_2_BAD_RANGE, false));
- }
result = Write_File(Addr_Of_New_Object, 0, 0,
Length, New_Object,
table_start, table_length,
{
FASDUMP_INTERRUPT();
}
- if (! (Open_Dump_File (File_Name, WRITE_FLAG)))
- {
+ dump_channel =
+ (OS_open_dump_file ((CONST char *) (STRING_LOC (File_Name, 0))));
+ if (dump_channel == NO_CHANNEL)
PRIMITIVE_RETURN (Fasdump_Exit (ERR_ARG_2_BAD_RANGE, false));
- }
result = Write_File(New_Object,
Length, New_Object,
0, Constant_Space,
}
else
{
- if (! (Open_Dump_File ((ARG_REF (2)), WRITE_FLAG)))
+ CONST char * filename = ((CONST char *) (STRING_LOC ((ARG_REF (2)), 0)));
+ dump_channel =
+ (OS_open_dump_file (filename));
+ if (dump_channel == NO_CHANNEL)
error_bad_range_arg (2);
result = Write_File((Free - 1),
((long) (Free - Heap_Bottom)), Heap_Bottom,
((long) (table_end - table_start)),
(compiler_utilities != SHARP_F), true);
/* The and is short-circuit, so it must be done in this order. */
- result = ((Close_Dump_File ()) && result);
+ OS_channel_close_noerror (dump_channel);
if (!result)
- {
- result = ((OS_file_remove (STRING_ARG (2))) && result);
- }
+ OS_file_remove (filename);
}
Band_Dump_Exit_Hook ();
Free = saved_free;
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasl.h,v 9.30 1989/09/20 23:07:58 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasl.h,v 9.31 1990/06/20 17:40:19 cph Exp $
Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
The machine/opsys information is contained in config.h
The processor and compiled code version information is
contained in the appropriate cmp* file, or compiler.c */
-
-extern long Load_Data(), Write_Data();
-extern Boolean Open_Dump_File(), Close_Dump_File();
\f
/* FASL Version */
MAKE_OBJECT (((Band_p) ? TC_TRUE : TC_NULL), \
(((Version) << (DATUM_LENGTH / 2)) | \
(Processor_Type)))
-
-#define WRITE_FLAG 1
-#define OPEN_FLAG 0
\f
/* "Memorable" FASL versions -- ones where we modified something
and want to remain backwards compatible.
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasload.c,v 9.52 1990/04/09 14:49:59 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasload.c,v 9.53 1990/06/20 17:40:24 cph Exp $
Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
#include "scheme.h"
#include "prims.h"
+#include "osfile.h"
+#include "osio.h"
#include "gccode.h"
#include "trap.h"
+
+static Tchannel load_channel;
+
+#define Load_Data(size, buffer) \
+ ((OS_channel_read_load_file \
+ (load_channel, (buffer), ((size) * (sizeof (SCHEME_OBJECT))))) \
+ / (sizeof (SCHEME_OBJECT)))
+
#include "load.c"
+
+extern char * malloc ();
+
+extern char * Error_Names [];
+extern char * Abort_Names [];
+extern SCHEME_OBJECT * load_renumber_table;
+extern SCHEME_OBJECT compiler_utilities;
+
+extern SCHEME_OBJECT intern_symbol ();
+extern void install_primitive_table ();
+extern void compiler_reset_error ();
+extern void compiler_initialize ();
+extern void compiler_reset ();
+
+static void EXFUN (terminate_band_load, (PTR ap));
\f
static long failed_heap_length = -1;
-long
-read_file_start(name)
- SCHEME_OBJECT name;
+static long
+DEFUN (read_file_start, (file_name), CONST char * file_name)
{
long value, heap_length;
- Boolean file_opened;
-
- if (OBJECT_TYPE (name) != TC_CHARACTER_STRING)
- {
- return (ERR_ARG_1_WRONG_TYPE);
- }
-
- file_opened = Open_Dump_File(name, OPEN_FLAG);
+ load_channel = (OS_open_load_file (file_name));
if (Per_File)
- {
- Handle_Debug_Flags();
- }
-
- if (!file_opened)
- {
- return (ERR_ARG_1_BAD_RANGE);
- }
-
- value = Read_Header();
+ debug_edit_flags ();
+ if (load_channel == NO_CHANNEL)
+ error_bad_range_arg (1);
+ value = (Read_Header ());
if (value != FASL_FILE_FINE)
{
- Close_Dump_File();
+ OS_channel_close_noerror (load_channel);
switch (value)
{
/* These may want to be separated further. */
if (!Test_Pure_Space_Top(Free_Constant + Const_Count))
{
failed_heap_length = 0;
- Close_Dump_File();
+ OS_channel_close_noerror (load_channel);
return (ERR_FASL_FILE_TOO_BIG);
}
The GC should be modified to do this right.
*/
failed_heap_length = -1;
- Close_Dump_File();
+ OS_channel_close_noerror (load_channel);
return (ERR_FASL_FILE_TOO_BIG);
}
else
{
failed_heap_length = heap_length;
- Close_Dump_File();
+ OS_channel_close_noerror (load_channel);
Request_GC(heap_length);
return (PRIM_INTERRUPT);
}
return (PRIM_DONE);
}
\f
-SCHEME_OBJECT *
-read_file_end()
+static SCHEME_OBJECT *
+DEFUN_VOID (read_file_end)
{
SCHEME_OBJECT *table;
if ((Load_Data(Heap_Count, ((char *) Free))) != Heap_Count)
{
- Close_Dump_File();
+ OS_channel_close_noerror (load_channel);
signal_error_from_primitive (ERR_IO_ERROR);
}
NORMALIZE_REGION(((char *) Free), Heap_Count);
if ((Load_Data(Const_Count, ((char *) Free_Constant))) != Const_Count)
{
- Close_Dump_File();
+ OS_channel_close_noerror (load_channel);
signal_error_from_primitive (ERR_IO_ERROR);
}
NORMALIZE_REGION(((char *) Free_Constant), Const_Count);
if ((Load_Data(Primitive_Table_Size, ((char *) Free))) !=
Primitive_Table_Size)
{
- Close_Dump_File();
+ OS_channel_close_noerror (load_channel);
signal_error_from_primitive (ERR_IO_ERROR);
}
NORMALIZE_REGION(((char *) table), Primitive_Table_Size);
Free += Primitive_Table_Size;
- if (Close_Dump_File())
- {
- return (table);
- }
- else
- {
- signal_error_from_primitive (ERR_IO_ERROR);
- }
+ OS_channel_close_noerror (load_channel);
+ return (table);
}
\f
/* Statics used by Relocate, below */
Relocate_Block(Scan, Stop_At)
fast SCHEME_OBJECT *Scan, *Stop_At;
{
- extern SCHEME_OBJECT *load_renumber_table;
fast SCHEME_OBJECT Temp;
fast long address;
return (true);
}
-extern void get_band_parameters();
-
void
-get_band_parameters(heap_size, const_size)
- long *heap_size, *const_size;
+DEFUN (get_band_parameters, (heap_size, const_size),
+ long * heap_size AND
+ long * const_size)
{
/* This assumes we have just aborted out of a band load. */
-
- *heap_size = Heap_Count;
- *const_size = Const_Count;
- return;
+ (*heap_size) = Heap_Count;
+ (*const_size) = Const_Count;
}
\f
void
SCHEME_OBJECT old_symbol = (*Next_Pointer);
MEMORY_SET (old_symbol, SYMBOL_GLOBAL_VALUE, UNBOUND_OBJECT);
{
- extern SCHEME_OBJECT intern_symbol ();
SCHEME_OBJECT new_symbol = (intern_symbol (old_symbol));
if (new_symbol != old_symbol)
{
*Constant_End, *Orig_Constant,
*temp, *primitive_table;
- extern void install_primitive_table();
- extern SCHEME_OBJECT *load_renumber_table;
-
/* Read File */
#ifdef ENABLE_DEBUGGING_TOOLS
if ((!band_p) && (dumped_utilities != SHARP_F))
{
- extern SCHEME_OBJECT compiler_utilities;
-
if (compiler_utilities == SHARP_F)
{
signal_error_from_primitive (ERR_FASLOAD_COMPILED_MISMATCH);
DEFINE_PRIMITIVE ("BINARY-FASLOAD", Prim_binary_fasload, 1, 1, 0)
{
- long result;
PRIMITIVE_HEADER (1);
- result = (read_file_start (ARG_REF (1)));
- if (band_p)
- signal_error_from_primitive (ERR_FASLOAD_BAND);
- if (result != PRIM_DONE)
- {
- if (result == PRIM_INTERRUPT)
- signal_interrupt_from_primitive ();
- else
- signal_error_from_primitive (result);
- }
+ {
+ long result = (read_file_start (STRING_ARG (1)));
+ if (band_p)
+ signal_error_from_primitive (ERR_FASLOAD_BAND);
+ if (result != PRIM_DONE)
+ {
+ if (result == PRIM_INTERRUPT)
+ signal_interrupt_from_primitive ();
+ else
+ signal_error_from_primitive (result);
+ }
+ }
PRIMITIVE_RETURN (load_file (false));
}
/* Band loading. */
-static char *reload_band_name = ((char *) NULL);
+static char *reload_band_name = 0;
\f
/* (RELOAD-BAND-NAME)
/* Utility for load band below. */
-extern void compiler_reset_error();
-
void
compiler_reset_error()
{
however, be any file which can be loaded with BINARY-FASLOAD.
*/
-#ifndef start_band_load
-#define start_band_load() \
+#ifndef START_BAND_LOAD
+#define START_BAND_LOAD() \
{ \
ENTER_CRITICAL_SECTION ("band load"); \
}
#endif
-#ifndef end_band_load
-#define end_band_load(success, dying) \
+#ifndef END_BAND_LOAD
+#define END_BAND_LOAD(success, dying) \
{ \
if (success || dying) \
- { \
- extern Boolean OS_file_close(); \
- int i; \
- \
- for (i = 0; i < FILE_CHANNELS; i++) \
- { \
- if (Channels[i] != NULL) \
- { \
- OS_file_close(Channels[i]); \
- Channels[i] = NULL; \
- } \
- } \
- } \
+ OS_channel_close_all (); \
EXIT_CRITICAL_SECTION ({}); \
}
#endif
-\f
+
DEFINE_PRIMITIVE ("LOAD-BAND", Prim_band_load, 1, 1, 0)
{
- extern char * malloc ();
- extern strcpy ();
- extern free ();
- extern void compiler_initialize ();
- extern void compiler_reset ();
- extern SCHEME_OBJECT compiler_utilities;
- static void terminate_band_load ();
- SCHEME_OBJECT
- argument,
- *saved_free,
- *saved_memtop,
- *saved_free_constant,
- *saved_stack_pointer;
- long temp, length;
- SCHEME_OBJECT result, cutl;
- char *band_name;
- Boolean load_file_failed;
+ SCHEME_OBJECT result;
PRIMITIVE_HEADER (1);
PRIMITIVE_CANONICALIZE_CONTEXT ();
- argument = (ARG_REF (1));
- saved_free = Free;
- Free = Heap_Bottom;
- saved_memtop = MemTop;
- SET_MEMTOP(Heap_Top);
-
- start_band_load();
-
- saved_free_constant = Free_Constant;
- Free_Constant = Constant_Space;
- saved_stack_pointer = Stack_Pointer;
- Stack_Pointer = Highest_Allocated_Address;
-
- temp = (read_file_start (argument));
- if (temp != PRIM_DONE)
{
- Free = saved_free;
- SET_MEMTOP(saved_memtop);
- Free_Constant = saved_free_constant;
- Stack_Pointer = saved_stack_pointer;
- end_band_load(false, false);
-
- if (temp == PRIM_INTERRUPT)
+ CONST char * file_name = (STRING_ARG (1));
+ SCHEME_OBJECT * saved_free = Free;
+ SCHEME_OBJECT * saved_memtop = MemTop;
+ SCHEME_OBJECT * saved_free_constant = Free_Constant;
+ SCHEME_OBJECT * saved_stack_pointer = Stack_Pointer;
+ Free = Heap_Bottom;
+ SET_MEMTOP (Heap_Top);
+ START_BAND_LOAD ();
+ Free_Constant = Constant_Space;
+ Stack_Pointer = Highest_Allocated_Address;
{
- signal_error_from_primitive (ERR_FASL_FILE_TOO_BIG);
+ long temp = (read_file_start (file_name));
+ if (temp != PRIM_DONE)
+ {
+ Free = saved_free;
+ SET_MEMTOP (saved_memtop);
+ Free_Constant = saved_free_constant;
+ Stack_Pointer = saved_stack_pointer;
+ END_BAND_LOAD (false, false);
+ signal_error_from_primitive
+ ((temp == PRIM_INTERRUPT) ? ERR_FASL_FILE_TOO_BIG : temp);
+ }
}
- else
+ /* Point of no return. */
{
- signal_error_from_primitive (temp);
+ long length = ((strlen (file_name)) + 1);
+ char * band_name = (malloc (length));
+ if (band_name != 0)
+ strcpy (band_name, file_name);
+ transaction_begin ();
+ {
+ char ** ap = (dstack_alloc (sizeof (char *)));
+ (*ap) = band_name;
+ transaction_record_action (tat_abort, terminate_band_load, ap);
+ }
+ result = (load_file (true));
+ transaction_commit ();
+ if (reload_band_name != 0)
+ free (reload_band_name);
+ reload_band_name = band_name;
}
}
-\f
- /* Point of no return. */
-
- length = ((STRING_LENGTH (argument)) + 1); /* add 1 for \0 at end */
- band_name = malloc(length);
- if (band_name != ((char *) NULL))
- strcpy (band_name, ((char *) (STRING_LOC (argument, 0))));
-
- load_file_failed = true;
-
- UNWIND_PROTECT({
- result = load_file(true);
- load_file_failed = false;
- },
- {
- if (load_file_failed)
- {
- terminate_band_load(UNWIND_PROTECT_value,
- band_name);
- /*NOTREACHED*/
- }
- });
-
- if (reload_band_name != ((char *) NULL))
- {
- free(reload_band_name);
- }
- reload_band_name = band_name;
-
/* Reset implementation state paramenters */
-
- INITIALIZE_INTERRUPTS();
+ INITIALIZE_INTERRUPTS ();
Initialize_Stack ();
- Set_Pure_Top();
+ Set_Pure_Top ();
SET_MEMTOP (Heap_Top - GC_Reserve);
-
- cutl = MEMORY_REF (result, 1);
- if (cutl != SHARP_F)
{
- compiler_utilities = cutl;
- compiler_reset(cutl);
- }
- else
- {
- compiler_initialize(true);
+ SCHEME_OBJECT cutl = (MEMORY_REF (result, 1));
+ if (cutl != SHARP_F)
+ {
+ compiler_utilities = cutl;
+ compiler_reset (cutl);
+ }
+ else
+ compiler_initialize (true);
}
Restore_Fixed_Obj (SHARP_F);
Fluid_Bindings = EMPTY_LIST;
Current_State_Point = SHARP_F;
-
/* Setup initial program */
-
Store_Return (RC_END_OF_COMPUTATION);
Store_Expression (SHARP_F);
Save_Cont ();
-\f
- Store_Expression(MEMORY_REF (result, 0));
- Store_Env(MAKE_OBJECT (GLOBAL_ENV, GO_TO_GLOBAL));
-
+ Store_Expression (MEMORY_REF (result, 0));
+ Store_Env (MAKE_OBJECT (GLOBAL_ENV, GO_TO_GLOBAL));
/* Clear various interpreter state parameters. */
-
Trapping = false;
- Return_Hook_Address = NULL;
- History = Make_Dummy_History();
- Prev_Restore_History_Stacklet = NULL;
+ Return_Hook_Address = 0;
+ History = (Make_Dummy_History ());
+ Prev_Restore_History_Stacklet = 0;
Prev_Restore_History_Offset = 0;
-
FLUSH_I_CACHE ();
-
- end_band_load(true, false);
- Band_Load_Hook();
-
+ END_BAND_LOAD (true, false);
+ Band_Load_Hook ();
/* Return in a non-standard way. */
-
PRIMITIVE_ABORT(PRIM_DO_EXPRESSION);
/*NOTREACHED*/
}
static void
-terminate_band_load(abort_value, band_name)
- int abort_value;
- char *band_name;
+DEFUN (terminate_band_load, (ap), PTR ap)
{
- extern char
- * Error_Names[],
- * Abort_Names[];
-
- if (abort_value > 0)
- {
- fprintf(stderr,
- "\nload-band: Error %d (%s) past the point of no return.\n",
- abort_value, Error_Names[abort_value]);
- }
- else
+ fputs ("\nload-band: ", stderr);
{
- fprintf(stderr,
- "\nload-band: Abort %d (%s) past the point of no return.\n",
- abort_value, Abort_Names[(-abort_value)-1]);
+ int abort_value = (abort_to_interpreter_argument ());
+ if (abort_value > 0)
+ fprintf (stderr, "Error %d (%s)",
+ abort_value,
+ (Error_Names [abort_value]));
+ else
+ fprintf (stderr, "Abort %d (%s)",
+ abort_value,
+ (Abort_Names [(-abort_value) - 1]));
}
-
- if (band_name != ((char *) NULL))
+ fputs (" past the point of no return.\n", stderr);
{
- fprintf(stderr, "band-name = \"%s\".\n", band_name);
- free(band_name);
+ char * band_name = (* ((char **) ap));
+ if (band_name != 0)
+ {
+ fprintf (stderr, "band-name = \"%s\".\n", band_name);
+ free (band_name);
+ }
}
- end_band_load(false, true);
- Microcode_Termination(TERM_DISK_RESTORE);
+ fflush (stderr);
+ END_BAND_LOAD (false, true);
+ Microcode_Termination (TERM_DISK_RESTORE);
/*NOTREACHED*/
}
\f
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/fhooks.c,v 9.31 1989/09/20 23:08:15 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/fhooks.c,v 9.32 1990/06/20 17:40:31 cph Rel $
-Copyright (c) 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
{
SCHEME_OBJECT thunk = (ARG_REF (1));
PRIMITIVE_CANONICALIZE_CONTEXT ();
- Pop_Primitive_Frame (1);
+ POP_PRIMITIVE_FRAME (1);
Will_Push (CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS + 1);
/* Save previous fluid bindings for later restore */
Store_Expression (Fluid_Bindings);
Store_Return (RC_RESTORE_FLUIDS);
Save_Cont ();
/* Invoke the thunk. */
- Push (thunk);
- Push (STACK_FRAME_HEADER);
+ STACK_PUSH (thunk);
+ STACK_PUSH (STACK_FRAME_HEADER);
Pushed ();
PRIMITIVE_ABORT (PRIM_APPLY);
/*NOTREACHED*/
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/futures.h,v 9.26 1989/09/20 23:08:39 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/futures.h,v 9.27 1990/06/20 17:40:37 cph Rel $
-Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
{ \
Save_Cont (); \
Will_Push (STACK_ENV_EXTRA_SLOTS + 2); \
- Push (object); \
- Push (Get_Fixed_Obj_Slot (System_Scheduler)); \
- Push (STACK_FRAME_HEADER + 1); \
+ STACK_PUSH (object); \
+ STACK_PUSH (Get_Fixed_Obj_Slot (System_Scheduler)); \
+ STACK_PUSH (STACK_FRAME_HEADER + 1); \
Pushed (); \
}
#define Call_Future_Logging() \
{ \
Will_Push (STACK_ENV_EXTRA_SLOTS + 2); \
- Push (Touched_Futures_Vector ()); \
- Push (Get_Fixed_Obj_Slot (Future_Logger)); \
- Push (STACK_FRAME_HEADER + 1); \
+ STACK_PUSH (Touched_Futures_Vector ()); \
+ STACK_PUSH (Get_Fixed_Obj_Slot (Future_Logger)); \
+ STACK_PUSH (STACK_FRAME_HEADER + 1); \
Pushed (); \
(Touched_Futures_Vector ()) = SHARP_F; \
goto Apply_Non_Trapping; \
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/generic.c,v 9.33 1990/01/12 15:20:15 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/generic.c,v 9.34 1990/06/20 17:40:46 cph Rel $
Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
{ \
PRIMITIVE_CANONICALIZE_CONTEXT (); \
Will_Push (STACK_ENV_EXTRA_SLOTS + 1); \
- Push (Get_Fixed_Obj_Slot (slot)); \
- Push (STACK_FRAME_HEADER + arity); \
+ STACK_PUSH (Get_Fixed_Obj_Slot (slot)); \
+ STACK_PUSH (STACK_FRAME_HEADER + arity); \
Pushed (); \
PRIMITIVE_ABORT (PRIM_APPLY); \
/*NOTREACHED*/ \
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/history.h,v 9.25 1989/09/20 23:08:59 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/history.h,v 9.26 1990/06/20 17:40:53 cph Exp $
-Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
#define Save_History(Return_Code) \
{ \
- Push \
+ STACK_PUSH \
((Prev_Restore_History_Stacklet == NULL) \
? SHARP_F \
: (MAKE_POINTER_OBJECT \
(TC_CONTROL_POINT, Prev_Restore_History_Stacklet))); \
- Push (LONG_TO_UNSIGNED_FIXNUM (Prev_Restore_History_Offset)); \
+ STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (Prev_Restore_History_Offset)); \
Store_Expression \
(MAKE_POINTER_OBJECT (UNMARKED_HISTORY_TYPE, History)); \
Store_Return (Return_Code); \
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/hooks.c,v 9.38 1990/02/13 16:00:20 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/hooks.c,v 9.39 1990/06/20 17:40:58 cph Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
promotional, or sales literature without prior written consent from
MIT in each case. */
-/*
- * This file contains various hooks and handles which connect the
- * primitives with the main interpreter.
- */
+/* This file contains various hooks and handles that connect the
+ primitives with the main interpreter. */
#include "scheme.h"
#include "prims.h"
Primitive_GC_If_Needed
(New_Stacklet_Size (number_of_args + STACK_ENV_EXTRA_SLOTS + 1));
#endif
- Pop_Primitive_Frame (2);
+ POP_PRIMITIVE_FRAME (2);
Will_Push (number_of_args + STACK_ENV_EXTRA_SLOTS + 1);
#ifdef LOSING_PARALLEL_PROCESSOR
saved_stack_pointer = Stack_Pointer;
TOUCH_IN_PRIMITIVE ((PAIR_CDR (scan_list)), scan_list);
}
}
- Push (procedure);
- Push (STACK_FRAME_HEADER + number_of_args);
+ STACK_PUSH (procedure);
+ STACK_PUSH (STACK_FRAME_HEADER + number_of_args);
Pushed ();
PRIMITIVE_ABORT (PRIM_APPLY);
/*NOTREACHED*/
{ \
SCHEME_OBJECT receiver = (receiver_expression); \
CWCC_1 (); \
- Pop_Primitive_Frame (1); \
+ POP_PRIMITIVE_FRAME (1); \
if (Return_Hook_Address != NULL) \
{ \
(* Return_Hook_Address) = Old_Return_Code; \
CWCC_2 (control_point, reuse_flag); \
/* we just cleared the stack so there MUST be room */ \
/* Will_Push(3); */ \
- Push (control_point); \
- Push (receiver); \
- Push (STACK_FRAME_HEADER + 1); \
+ STACK_PUSH (control_point); \
+ STACK_PUSH (receiver); \
+ STACK_PUSH (STACK_FRAME_HEADER + 1); \
/* Pushed(); */ \
} \
}
fast SCHEME_OBJECT * scan = \
(MEMORY_LOC ((target), STACKLET_HEADER_SIZE)); \
while ((n_words--) > 0) \
- (*scan++) = (Pop ()); \
+ (*scan++) = (STACK_POP ()); \
} \
if (Consistency_Check && (Stack_Pointer != Stack_Top)) \
Microcode_Termination (TERM_BAD_STACK); \
Within_Stacklet_Backout ();
Our_Throw_Part_2 ();
Will_Push (STACK_ENV_EXTRA_SLOTS + 1);
- Push (thunk);
- Push (STACK_FRAME_HEADER);
+ STACK_PUSH (thunk);
+ STACK_PUSH (STACK_FRAME_HEADER);
Pushed ();
}
PRIMITIVE_ABORT (PRIM_APPLY);
Will_Push (HISTORY_SIZE + STACK_ENV_EXTRA_SLOTS + 4);
Stop_History ();
/* Stepping should be cleared here! */
- Push (environment);
- Push (irritants);
- Push (message);
- Push (Get_Fixed_Obj_Slot (Error_Procedure));
- Push (STACK_FRAME_HEADER + 3);
+ STACK_PUSH (environment);
+ STACK_PUSH (irritants);
+ STACK_PUSH (message);
+ STACK_PUSH (Get_Fixed_Obj_Slot (Error_Procedure));
+ STACK_PUSH (STACK_FRAME_HEADER + 3);
Pushed ();
PRIMITIVE_ABORT (PRIM_APPLY);
/*NOTREACHED*/
{
fast SCHEME_OBJECT expression = (ARG_REF (1));
fast SCHEME_OBJECT environment = (ARG_REF (2));
- Pop_Primitive_Frame (2);
+ POP_PRIMITIVE_FRAME (2);
Store_Env (environment);
Store_Expression (expression);
}
{
/* New-style thunk used by compiled code. */
PRIMITIVE_CANONICALIZE_CONTEXT();
- Pop_Primitive_Frame (1);
+ POP_PRIMITIVE_FRAME (1);
Will_Push (CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS + 1);
Store_Return (RC_SNAP_NEED_THUNK);
Store_Expression (thunk);
Save_Cont ();
- Push (MEMORY_REF (thunk, THUNK_VALUE));
- Push (STACK_FRAME_HEADER);
+ STACK_PUSH (MEMORY_REF (thunk, THUNK_VALUE));
+ STACK_PUSH (STACK_FRAME_HEADER);
Pushed ();
PRIMITIVE_ABORT (PRIM_APPLY);
/*NOTREACHED*/
{
/* Old-style thunk used by interpreted code. */
PRIMITIVE_CANONICALIZE_CONTEXT();
- Pop_Primitive_Frame (1);
+ POP_PRIMITIVE_FRAME (1);
Will_Push (CONTINUATION_SIZE);
Store_Return (RC_SNAP_NEED_THUNK);
Store_Expression (thunk);
STATE_POINT_DISTANCE_TO_ROOT,
(1 + (FAST_MEMORY_REF (old_point, STATE_POINT_DISTANCE_TO_ROOT))));
- Pop_Primitive_Frame (4);
+ POP_PRIMITIVE_FRAME (4);
Will_Push((2 * CONTINUATION_SIZE) + (STACK_ENV_EXTRA_SLOTS + 1));
/* Push a continuation to go back to the current state after the
body is evaluated */
Save_Cont ();
/* Push a stack frame which will call the body after we have moved
into the new state point */
- Push (during_thunk);
- Push (STACK_FRAME_HEADER);
+ STACK_PUSH (during_thunk);
+ STACK_PUSH (STACK_FRAME_HEADER);
/* Push the continuation to go with the stack frame */
Store_Expression (SHARP_F);
Store_Return (RC_INTERNAL_APPLY);
CHECK_ARG (1, STATE_POINT_P);
{
SCHEME_OBJECT state_point = (ARG_REF (1));
- Pop_Primitive_Frame (1);
+ POP_PRIMITIVE_FRAME (1);
Translate_To_Point (state_point);
/*NOTREACHED*/
}
long new_mask = (INT_Mask & (arg_integer (1)));
SCHEME_OBJECT thunk = (ARG_REF (2));
SCHEME_OBJECT old_mask = (LONG_TO_FIXNUM (FETCH_INTERRUPT_MASK ()));
- Pop_Primitive_Frame (2);
+ POP_PRIMITIVE_FRAME (2);
Will_Push (CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS + 2);
Store_Return (RC_RESTORE_INT_MASK);
Store_Expression (old_mask);
Save_Cont ();
- Push (old_mask);
- Push (thunk);
- Push (STACK_FRAME_HEADER + 1);
+ STACK_PUSH (old_mask);
+ STACK_PUSH (thunk);
+ STACK_PUSH (STACK_FRAME_HEADER + 1);
Pushed ();
SET_INTERRUPT_MASK (new_mask);
PRIMITIVE_ABORT (PRIM_APPLY);
long new_mask = (INT_Mask & (arg_integer (1)));
SCHEME_OBJECT thunk = (ARG_REF (2));
long old_mask = (FETCH_INTERRUPT_MASK ());
- Pop_Primitive_Frame (2);
+ POP_PRIMITIVE_FRAME (2);
Will_Push (CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS + 2);
Store_Return (RC_RESTORE_INT_MASK);
Store_Expression (old_mask);
Save_Cont ();
- Push (LONG_TO_FIXNUM (old_mask));
- Push (thunk);
- Push (STACK_FRAME_HEADER + 1);
+ STACK_PUSH (LONG_TO_FIXNUM (old_mask));
+ STACK_PUSH (thunk);
+ STACK_PUSH (STACK_FRAME_HEADER + 1);
Pushed ();
SET_INTERRUPT_MASK
((new_mask > old_mask) ? new_mask : (new_mask & old_mask));
#else
History = (OBJECT_ADDRESS (Get_Fixed_Obj_Slot (Dummy_History)));
#endif
- Pop_Primitive_Frame (1);
+ POP_PRIMITIVE_FRAME (1);
PRIMITIVE_ABORT (PRIM_POP_RETURN);
/*NOTREACHED*/
}
(MAKE_POINTER_OBJECT ((OBJECT_TYPE (History [HIST_RIB])), rib));
}
}
- Pop_Primitive_Frame (1);
+ POP_PRIMITIVE_FRAME (1);
Stop_History ();
Will_Push (STACK_ENV_EXTRA_SLOTS + 1);
- Push (thunk);
- Push (STACK_FRAME_HEADER);
+ STACK_PUSH (thunk);
+ STACK_PUSH (STACK_FRAME_HEADER);
Pushed ();
PRIMITIVE_ABORT (PRIM_APPLY);
/*NOTREACHED*/
/* -*-C-*-
-Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/intercom.c,v 9.28 1990/06/20 17:41:04 cph Rel $
+
+Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/intercom.c,v 9.27 1989/09/20 23:09:24 cph Exp $
- *
- * Single-processor simulation of locking, propagating, and
- * communicating stuff.
- */
+/* Single-processor simulation of locking, propagating, and
+ communicating stuff. */
\f
#include "scheme.h"
#include "prims.h"
work = (ARG_REF (2)); /* Why is this being ignored? -- CPH */
test = (ARG_REF (3));
Save_Time_Zone (Zone_Global_Int);
- Pop_Primitive_Frame (3);
+ POP_PRIMITIVE_FRAME (3);
Will_Push (CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS + 1);
Store_Return (RC_FINISH_GLOBAL_INT);
Store_Expression (LONG_TO_UNSIGNED_FIXNUM (Which_Level));
Save_Cont ();
- Push (test);
- Push (STACK_FRAME_HEADER);
+ STACK_PUSH (test);
+ STACK_PUSH (STACK_FRAME_HEADER);
Pushed ();
Restore_Time_Zone ();
PRIMITIVE_ABORT (PRIM_APPLY);
Microcode_Termination (TERM_EXIT);
}
PRIMITIVE_CANONICALIZE_CONTEXT ();
- Pop_Primitive_Frame (1);
+ POP_PRIMITIVE_FRAME (1);
Will_Push ((2 * (STACK_ENV_EXTRA_SLOTS + 1)) + 1 + CONTINUATION_SIZE);
/* When the thunk returns, call the primitive again.
If there's still no work, we lose. */
- Push (SHARP_F);
- Push (primitive);
- Push (STACK_FRAME_HEADER + 1);
+ STACK_PUSH (SHARP_F);
+ STACK_PUSH (primitive);
+ STACK_PUSH (STACK_FRAME_HEADER + 1);
Store_Expression (SHARP_F);
Store_Return (RC_INTERNAL_APPLY);
Save_Cont ();
/* Invoke the thunk. */
- Push (thunk);
- Push (STACK_FRAME_HEADER);
+ STACK_PUSH (thunk);
+ STACK_PUSH (STACK_FRAME_HEADER);
Pushed ();
PRIMITIVE_ABORT (PRIM_APPLY);
}
Time_Meters[i] = 0;
}
- Old_Time=Sys_Clock();
+ Old_Time = (OS_process_clock ());
#endif
PRIMITIVE_RETURN (UNSPECIFIC);
}
gc_prim = (make_primitive ("GARBAGE-COLLECT"));
{
SCHEME_OBJECT argument = (ARG_REF (1));
- Pop_Primitive_Frame (1);
+ POP_PRIMITIVE_FRAME (1);
Will_Push (STACK_ENV_EXTRA_SLOTS + 2);
- Push (argument);
- Push (gc_prim);
- Push (STACK_FRAME_HEADER + 1);
+ STACK_PUSH (argument);
+ STACK_PUSH (gc_prim);
+ STACK_PUSH (STACK_FRAME_HEADER + 1);
Pushed ();
PRIMITIVE_ABORT (PRIM_APPLY);
}
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/interp.c,v 9.55 1990/01/30 14:44:25 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/interp.c,v 9.56 1990/06/20 17:41:10 cph Exp $
-Copyright (c) 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
#include "history.h"
#include "cmpint.h"
#include "zones.h"
+
+extern PTR EXFUN (obstack_chunk_alloc, (unsigned int size));
+extern void EXFUN (free, (PTR ptr));
+#define obstack_chunk_free free
\f
/* In order to make the interpreter tail recursive (i.e.
* to avoid calling procedures and thus saving unnecessary
#define Prepare_Eval_Repeat() \
{ \
Will_Push(CONTINUATION_SIZE+1); \
- Push(Fetch_Env()); \
+ STACK_PUSH (Fetch_Env()); \
Store_Return(RC_EVAL_ERROR); \
Save_Cont(); \
Pushed(); \
{ \
fast SCHEME_OBJECT *Arg, Orig_Arg; \
\
- Arg = &(Stack_Ref((Arg_No - 1) + STACK_ENV_FIRST_ARG)); \
+ Arg = &(STACK_REF((Arg_No - 1) + STACK_ENV_FIRST_ARG)); \
Orig_Arg = *Arg; \
\
if (OBJECT_TYPE (*Arg) != TC_FUTURE) \
Store_Return(RC_RESTORE_VALUE); \
Store_Expression(Orig_Val); \
Save_Cont(); \
- Push(Val); \
- Push(Get_Fixed_Obj_Slot(System_Scheduler)); \
- Push(STACK_FRAME_HEADER + 1); \
+ STACK_PUSH (Val); \
+ STACK_PUSH (Get_Fixed_Obj_Slot(System_Scheduler)); \
+ STACK_PUSH (STACK_FRAME_HEADER + 1); \
Pushed(); \
goto Internal_Apply; \
} \
{ \
Save_Cont(); \
Will_Push(CONTINUATION_SIZE + 2); \
- Push(Val); \
+ STACK_PUSH (Val); \
Save_Env(); \
Store_Return(RC_REPEAT_DISPATCH); \
Store_Expression(LONG_TO_FIXNUM(CODE_MAP(Which_Way))); \
The EVAL/APPLY ying/yang
*/
+static PTR interpreter_catch_dstack_position;
+static jmp_buf interpreter_catch_env;
+static int interpreter_throw_argument;
+
+void
+DEFUN (abort_to_interpreter, (argument), int argument)
+{
+ interpreter_throw_argument = argument;
+ dstack_set_position (interpreter_catch_dstack_position);
+ obstack_free ((&scratch_obstack), 0);
+ obstack_init (&scratch_obstack);
+ longjmp (interpreter_catch_env, argument);
+}
+
+int
+DEFUN_VOID (abort_to_interpreter_argument)
+{
+ return (interpreter_throw_argument);
+}
+
void
Interpret(dumped_p)
Boolean dumped_p;
* for operation.
*/
- Which_Way = setjmp(*Back_To_Eval);
- Set_Time_Zone(Zone_Working);
- Import_Registers();
+ interpreter_catch_dstack_position = dstack_position;
+ Which_Way = (setjmp (interpreter_catch_env));
+ Set_Time_Zone (Zone_Working);
+ Import_Registers ();
\f
Repeat_Dispatch:
switch (Which_Way)
{
Stop_Trapping ();
Will_Push (4);
- Push (Fetch_Env ());
- Push (Fetch_Expression ());
- Push (Fetch_Eval_Trapper ());
- Push (STACK_FRAME_HEADER + 2);
+ STACK_PUSH (Fetch_Env ());
+ STACK_PUSH (Fetch_Expression ());
+ STACK_PUSH (Fetch_Eval_Trapper ());
+ STACK_PUSH (STACK_FRAME_HEADER + 2);
Pushed ();
goto Apply_Non_Trapping;
}
Eval_GC_Check(New_Stacklet_Size(Array_Length + 1 + 1 + CONTINUATION_SIZE));
#endif /* USE_STACKLETS */
Will_Push(Array_Length + 1 + 1 + CONTINUATION_SIZE);
- Stack_Pointer = Simulate_Pushing(Array_Length);
- Push(MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, Array_Length));
+ Stack_Pointer = (STACK_LOC (- Array_Length));
+ STACK_PUSH (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, Array_Length));
/* The finger: last argument number */
Pushed();
if (Array_Length == 0)
{
- Push(STACK_FRAME_HEADER); /* Frame size */
+ STACK_PUSH (STACK_FRAME_HEADER); /* Frame size */
Do_Nth_Then(RC_COMB_APPLY_FUNCTION, COMB_FN_SLOT, {});
}
Save_Env();
}
Prepare_Eval_Repeat();
Will_Push(STACK_ENV_EXTRA_SLOTS+2);
- Push(Fetch_Expression()); /* Arg: FUTURE object */
- Push(Get_Fixed_Obj_Slot(System_Scheduler));
- Push(STACK_FRAME_HEADER+1);
+ STACK_PUSH (Fetch_Expression()); /* Arg: FUTURE object */
+ STACK_PUSH (Get_Fixed_Obj_Slot(System_Scheduler));
+ STACK_PUSH (STACK_FRAME_HEADER+1);
Pushed();
goto Internal_Apply;
#endif
Restore_Cont();
if (Consistency_Check &&
(OBJECT_TYPE (Fetch_Return()) != TC_RETURN_CODE))
- { Push(Val); /* For possible stack trace */
+ { STACK_PUSH (Val); /* For possible stack trace */
Save_Cont();
Export_Registers();
Microcode_Termination(TERM_BAD_STACK);
{
case RC_COMB_1_PROCEDURE:
Restore_Env();
- Push(Val); /* Arg. 1 */
- Push(SHARP_F); /* Operator */
- Push(STACK_FRAME_HEADER + 1);
+ STACK_PUSH (Val); /* Arg. 1 */
+ STACK_PUSH (SHARP_F); /* Operator */
+ STACK_PUSH (STACK_FRAME_HEADER + 1);
Finished_Eventual_Pushing(CONTINUATION_SIZE);
Do_Another_Then(RC_COMB_APPLY_FUNCTION, COMB_1_FN);
case RC_COMB_2_FIRST_OPERAND:
Restore_Env();
- Push(Val);
+ STACK_PUSH (Val);
Save_Env();
Do_Another_Then(RC_COMB_2_PROCEDURE, COMB_2_ARG_1);
case RC_COMB_2_PROCEDURE:
Restore_Env();
- Push(Val); /* Arg 1, just calculated */
- Push(SHARP_F); /* Function */
- Push(STACK_FRAME_HEADER + 2);
+ STACK_PUSH (Val); /* Arg 1, just calculated */
+ STACK_PUSH (SHARP_F); /* Function */
+ STACK_PUSH (STACK_FRAME_HEADER + 2);
Finished_Eventual_Pushing(CONTINUATION_SIZE);
Do_Another_Then(RC_COMB_APPLY_FUNCTION, COMB_2_FN);
{ long Arg_Number;
Restore_Env();
- Arg_Number = OBJECT_DATUM (Stack_Ref(STACK_COMB_FINGER))-1;
- Stack_Ref(STACK_COMB_FIRST_ARG+Arg_Number) = Val;
- Stack_Ref(STACK_COMB_FINGER) =
+ Arg_Number = OBJECT_DATUM (STACK_REF(STACK_COMB_FINGER))-1;
+ STACK_REF(STACK_COMB_FIRST_ARG+Arg_Number) = Val;
+ STACK_REF(STACK_COMB_FINGER) =
MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, Arg_Number);
/* DO NOT count on the type code being NMVector here, since
the stack parser may create them with #F here! */
Do_Another_Then(RC_COMB_SAVE_VALUE,
(COMB_ARG_1_SLOT - 1) + Arg_Number);
}
- Push(FAST_MEMORY_REF (Fetch_Expression(), 0)); /* Frame Size */
+ STACK_PUSH (FAST_MEMORY_REF (Fetch_Expression(), 0)); /* Frame Size */
Do_Another_Then(RC_COMB_APPLY_FUNCTION, COMB_FN_SLOT);
}
case RC_END_OF_COMPUTATION:
/* Signals bottom of stack */
Export_Registers();
- Microcode_Termination(TERM_END_OF_COMPUTATION);
+ termination_end_of_computation ();
case RC_EVAL_ERROR:
/* Should be called RC_REDO_EVALUATION. */
- Store_Env(Pop());
+ Store_Env(STACK_POP ());
Reduces_To(Fetch_Expression());
\f
case RC_EXECUTE_ACCESS_FINISH:
((handler = (Get_Fixed_Obj_Slot(Trap_Handler))) == SHARP_F))
{
fprintf(stderr, "There is no trap handler for recovery!\n");
- Microcode_Termination(TERM_TRAP);
+ termination_trap ();
/*NOTREACHED*/
}
Will_Push(STACK_ENV_EXTRA_SLOTS + 2);
- Push(info);
- Push(handler);
- Push(STACK_FRAME_HEADER + 1);
+ STACK_PUSH (info);
+ STACK_PUSH (handler);
+ STACK_PUSH (STACK_FRAME_HEADER + 1);
Pushed();
goto Internal_Apply;
}
{ \
Store_Expression (SHARP_F); \
Prepare_Pop_Return_Interrupt (RC_INTERNAL_APPLY_VAL, \
- (Stack_Ref (STACK_ENV_FUNCTION))); \
+ (STACK_REF (STACK_ENV_FUNCTION))); \
}
#define Apply_Error(N) \
{ \
Store_Expression (SHARP_F); \
Store_Return (RC_INTERNAL_APPLY_VAL); \
- Val = (Stack_Ref (STACK_ENV_FUNCTION)); \
+ Val = (STACK_REF (STACK_ENV_FUNCTION)); \
Pop_Return_Error (N); \
}
case RC_INTERNAL_APPLY_VAL:
Internal_Apply_Val:
- Stack_Ref (STACK_ENV_FUNCTION) = Val;
+ STACK_REF (STACK_ENV_FUNCTION) = Val;
case RC_INTERNAL_APPLY:
Internal_Apply:
{
long Count;
- Count = (OBJECT_DATUM (Stack_Ref (STACK_ENV_HEADER)));
- Top_Of_Stack() = (Fetch_Apply_Trapper ());
- Push (STACK_FRAME_HEADER + Count);
+ Count = (OBJECT_DATUM (STACK_REF (STACK_ENV_HEADER)));
+ (* (STACK_LOC (0))) = (Fetch_Apply_Trapper ());
+ STACK_PUSH (STACK_FRAME_HEADER + Count);
Stop_Trapping ();
}
{
fast SCHEME_OBJECT Function;
- Apply_Future_Check(Function, Stack_Ref(STACK_ENV_FUNCTION));
+ Apply_Future_Check(Function, STACK_REF(STACK_ENV_FUNCTION));
switch(OBJECT_TYPE (Function))
{
of everything, including type code, etc.
*/
- nargs = Pop();
- Push(FAST_MEMORY_REF (Function, ENTITY_OPERATOR));
- Push(nargs + 1);
+ nargs = (STACK_POP ());
+ STACK_PUSH (FAST_MEMORY_REF (Function, ENTITY_OPERATOR));
+ STACK_PUSH (nargs + 1);
/* This must be done to prevent an infinite push loop by
an entity whose handler is the entity itself or some
other such loop. Of course, it will die if stack overflow
{
fast long nargs;
- nargs = OBJECT_DATUM (Pop());
+ nargs = OBJECT_DATUM (STACK_POP ());
Function = FAST_MEMORY_REF (Function, PROCEDURE_LAMBDA_EXPR);
{
((OBJECT_TYPE (Function) != TC_LEXPR) ||
(nargs < VECTOR_LENGTH (formals))))
{
- Push(STACK_FRAME_HEADER + nargs - 1);
+ STACK_PUSH (STACK_FRAME_HEADER + nargs - 1);
Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
}
}
if (GC_Check(nargs + 1))
{
- Push(STACK_FRAME_HEADER + nargs - 1);
+ STACK_PUSH (STACK_FRAME_HEADER + nargs - 1);
Prepare_Apply_Interrupt ();
Immediate_GC(nargs + 1);
}
Store_Env(MAKE_POINTER_OBJECT (TC_ENVIRONMENT, scan));
*scan++ = MAKE_OBJECT (TC_MANIFEST_VECTOR, nargs);
while(--nargs >= 0)
- *scan++ = Pop();
+ *scan++ = (STACK_POP ());
Free = scan;
Reduces_To(FAST_MEMORY_REF (Function, LAMBDA_SCODE));
}
case TC_CONTROL_POINT:
{
- if (OBJECT_DATUM (Stack_Ref (STACK_ENV_HEADER)) !=
+ if (OBJECT_DATUM (STACK_REF (STACK_ENV_HEADER)) !=
STACK_ENV_FIRST_ARG)
{
Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
}
- Val = (Stack_Ref (STACK_ENV_FIRST_ARG));
+ Val = (STACK_REF (STACK_ENV_FIRST_ARG));
Our_Throw(false, Function);
Apply_Stacklet_Backout();
Our_Throw_Part_2();
/* Note that the first test below will fail for lexpr primitives. */
- nargs = ((OBJECT_DATUM (Stack_Ref(STACK_ENV_HEADER))) -
+ nargs = ((OBJECT_DATUM (STACK_REF(STACK_ENV_HEADER))) -
(STACK_ENV_FIRST_ARG - 1));
if (nargs != PRIMITIVE_ARITY(Function))
{
Regs[REGBLOCK_LEXPR_ACTUALS] = ((SCHEME_OBJECT) nargs);
}
- Stack_Pointer = Simulate_Popping(STACK_ENV_FIRST_ARG);
- Store_Expression(Function);
-
- Export_Regs_Before_Primitive();
- Metering_Apply_Primitive(Val, Function);
- Import_Regs_After_Primitive();
-
- Pop_Primitive_Frame(nargs);
+ Stack_Pointer = (STACK_LOC (STACK_ENV_FIRST_ARG));
+ Store_Expression (Function);
+ EXPORT_REGS_BEFORE_PRIMITIVE ();
+ PRIMITIVE_APPLY (Val, Function);
+ IMPORT_REGS_AFTER_PRIMITIVE ();
+ POP_PRIMITIVE_FRAME (nargs);
if (Must_Report_References())
{
Store_Expression(Val);
fast long i;
fast SCHEME_OBJECT *scan;
- nargs = OBJECT_DATUM (Pop()) - STACK_FRAME_HEADER;
+ nargs = OBJECT_DATUM (STACK_POP ()) - STACK_FRAME_HEADER;
if (Eval_Debug)
{
if ((nargs < formals) || (!rest_flag && (nargs > params)))
{
- Push(STACK_FRAME_HEADER + nargs);
+ STACK_PUSH (STACK_FRAME_HEADER + nargs);
Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
}
(2 * (nargs - params)) :
0)))
{
- Push(STACK_FRAME_HEADER + nargs);
+ STACK_PUSH (STACK_FRAME_HEADER + nargs);
Prepare_Apply_Interrupt ();
Immediate_GC(size + 1 + ((nargs > params) ?
(2 * (nargs - params)) :
if (nargs <= params)
{
for (i = (nargs + 1); --i >= 0; )
- *scan++ = Pop();
+ *scan++ = (STACK_POP ());
for (i = (params - nargs); --i >= 0; )
*scan++ = UNASSIGNED_OBJECT;
if (rest_flag)
list = MAKE_POINTER_OBJECT (TC_LIST, (scan + size));
for (i = (params + 1); --i >= 0; )
- *scan++ = Pop();
+ *scan++ = (STACK_POP ());
*scan++ = list;
for (i = auxes; --i >= 0; )
*scan++ = UNASSIGNED_OBJECT;
/* Now scan == OBJECT_ADDRESS (list) */
for (i = (nargs - params); --i >= 0; )
{
- *scan++ = Pop();
+ *scan++ = (STACK_POP ());
*scan = MAKE_POINTER_OBJECT (TC_LIST, (scan + 1));
scan += 1;
}
case TC_COMPILED_ENTRY:
{
apply_compiled_setup(STACK_ENV_EXTRA_SLOTS +
- OBJECT_DATUM (Stack_Ref (STACK_ENV_HEADER)));
+ OBJECT_DATUM (STACK_REF (STACK_ENV_HEADER)));
Export_Registers();
Which_Way = apply_compiled_procedure();
{
compiler_apply_procedure
(STACK_ENV_EXTRA_SLOTS +
- OBJECT_DATUM (Stack_Ref (STACK_ENV_HEADER)));
+ OBJECT_DATUM (STACK_REF (STACK_ENV_HEADER)));
goto Internal_Apply;
}
SCHEME_OBJECT Thunk, New_Location;
From_Count =
- (UNSIGNED_FIXNUM_TO_LONG (Stack_Ref (TRANSLATE_FROM_DISTANCE)));
+ (UNSIGNED_FIXNUM_TO_LONG (STACK_REF (TRANSLATE_FROM_DISTANCE)));
if (From_Count != 0)
- { SCHEME_OBJECT Current = Stack_Ref(TRANSLATE_FROM_POINT);
- Stack_Ref(TRANSLATE_FROM_DISTANCE) =
+ { SCHEME_OBJECT Current = STACK_REF(TRANSLATE_FROM_POINT);
+ STACK_REF(TRANSLATE_FROM_DISTANCE) =
(LONG_TO_UNSIGNED_FIXNUM (From_Count - 1));
Thunk = FAST_MEMORY_REF (Current, STATE_POINT_AFTER_THUNK);
New_Location = FAST_MEMORY_REF (Current, STATE_POINT_NEARER_POINT);
- Stack_Ref(TRANSLATE_FROM_POINT) = New_Location;
+ STACK_REF(TRANSLATE_FROM_POINT) = New_Location;
if ((From_Count == 1) &&
- (Stack_Ref(TRANSLATE_TO_DISTANCE) == LONG_TO_UNSIGNED_FIXNUM(0)))
- Stack_Pointer = Simulate_Popping(4);
+ (STACK_REF(TRANSLATE_TO_DISTANCE) == LONG_TO_UNSIGNED_FIXNUM(0)))
+ Stack_Pointer = (STACK_LOC (4));
else Save_Cont();
}
else
fast long i;
To_Count =
- (UNSIGNED_FIXNUM_TO_LONG (Stack_Ref (TRANSLATE_TO_DISTANCE)) - 1);
- To_Location = Stack_Ref(TRANSLATE_TO_POINT);
+ (UNSIGNED_FIXNUM_TO_LONG (STACK_REF (TRANSLATE_TO_DISTANCE)) - 1);
+ To_Location = STACK_REF(TRANSLATE_TO_POINT);
for (i = 0; i < To_Count; i++)
{
To_Location =
}
Thunk = FAST_MEMORY_REF (To_Location, STATE_POINT_BEFORE_THUNK);
New_Location = To_Location;
- Stack_Ref(TRANSLATE_TO_DISTANCE) = LONG_TO_UNSIGNED_FIXNUM(To_Count);
+ STACK_REF(TRANSLATE_TO_DISTANCE) = LONG_TO_UNSIGNED_FIXNUM(To_Count);
if (To_Count == 0)
{
- Stack_Pointer = Simulate_Popping(4);
+ Stack_Pointer = (STACK_LOC (4));
}
else
{
Current_State_Point = New_Location;
}
Will_Push(2);
- Push(Thunk);
- Push(STACK_FRAME_HEADER);
+ STACK_PUSH (Thunk);
+ STACK_PUSH (STACK_FRAME_HEADER);
Pushed();
goto Internal_Apply;
}
case RC_INVOKE_STACK_THREAD:
/* Used for WITH_THREADED_STACK primitive */
Will_Push(3);
- Push(Val); /* Value calculated by thunk */
- Push(Fetch_Expression());
- Push(STACK_FRAME_HEADER+1);
+ STACK_PUSH (Val); /* Value calculated by thunk */
+ STACK_PUSH (Fetch_Expression());
+ STACK_PUSH (STACK_FRAME_HEADER+1);
Pushed();
goto Internal_Apply;
GC_Space_Needed = 0;
}
if (GC_Check(GC_Space_Needed))
- {
- Microcode_Termination(TERM_GC_OUT_OF_SPACE);
- }
+ termination_gc_out_of_space ();
GC_Space_Needed = 0;
EXIT_CRITICAL_SECTION ({ Save_Cont(); Export_Registers(); });
End_GC_Hook();
\f
case RC_PCOMB1_APPLY:
End_Subproblem();
- Push(Val); /* Argument value */
+ STACK_PUSH (Val); /* Argument value */
Finished_Eventual_Pushing(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG);
Store_Expression(FAST_MEMORY_REF (Fetch_Expression(), PCOMB1_FN_SLOT));
We may have a non-contiguous frame. -- Jinx
*/
Will_Push(3);
- Push(Fetch_Expression());
- Push(Fetch_Apply_Trapper());
- Push(STACK_FRAME_HEADER + 1 +
+ STACK_PUSH (Fetch_Expression());
+ STACK_PUSH (Fetch_Apply_Trapper());
+ STACK_PUSH (STACK_FRAME_HEADER + 1 +
PRIMITIVE_N_PARAMETERS(Fetch_Expression()));
Pushed();
Stop_Trapping();
*/
{
- fast SCHEME_OBJECT primitive;
-
- primitive = Fetch_Expression();
- Export_Regs_Before_Primitive();
- Metering_Apply_Primitive(Val, primitive);
- Import_Regs_After_Primitive();
-
- Pop_Primitive_Frame(PRIMITIVE_ARITY(primitive));
- if (Must_Report_References())
- {
- Store_Expression(Val);
- Store_Return(RC_RESTORE_VALUE);
- Save_Cont();
- Call_Future_Logging();
- }
+ fast SCHEME_OBJECT primitive = (Fetch_Expression ());
+ EXPORT_REGS_BEFORE_PRIMITIVE ();
+ PRIMITIVE_APPLY (Val, primitive);
+ IMPORT_REGS_AFTER_PRIMITIVE ();
+ POP_PRIMITIVE_FRAME (PRIMITIVE_ARITY (primitive));
+ if (Must_Report_References ())
+ {
+ Store_Expression (Val);
+ Store_Return (RC_RESTORE_VALUE);
+ Save_Cont ();
+ Call_Future_Logging ();
+ }
break;
}
\f
case RC_PCOMB2_APPLY:
End_Subproblem();
- Push(Val); /* Value of arg. 1 */
+ STACK_PUSH (Val); /* Value of arg. 1 */
Finished_Eventual_Pushing(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG);
Store_Expression(FAST_MEMORY_REF (Fetch_Expression(), PCOMB2_FN_SLOT));
goto Primitive_Internal_Apply;
case RC_PCOMB2_DO_1:
Restore_Env();
- Push(Val); /* Save value of arg. 2 */
+ STACK_PUSH (Val); /* Save value of arg. 2 */
Do_Another_Then(RC_PCOMB2_APPLY, PCOMB2_ARG_1_SLOT);
case RC_PCOMB3_APPLY:
End_Subproblem();
- Push(Val); /* Save value of arg. 1 */
+ STACK_PUSH (Val); /* Save value of arg. 1 */
Finished_Eventual_Pushing(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG);
Store_Expression(FAST_MEMORY_REF (Fetch_Expression(), PCOMB3_FN_SLOT));
goto Primitive_Internal_Apply;
{
SCHEME_OBJECT Temp;
- Temp = Pop(); /* Value of arg. 3 */
+ Temp = (STACK_POP ()); /* Value of arg. 3 */
Restore_Env();
- Push(Temp); /* Save arg. 3 again */
- Push(Val); /* Save arg. 2 */
+ STACK_PUSH (Temp); /* Save arg. 3 again */
+ STACK_PUSH (Val); /* Save arg. 2 */
Do_Another_Then(RC_PCOMB3_APPLY, PCOMB3_ARG_1_SLOT);
}
case RC_PCOMB3_DO_2:
Restore_Then_Save_Env();
- Push(Val); /* Save value of arg. 3 */
+ STACK_PUSH (Val); /* Save value of arg. 3 */
Do_Another_Then(RC_PCOMB3_DO_1, PCOMB3_ARG_2_SLOT);
case RC_POP_RETURN_ERROR:
Store_Return(RC_PURIFY_GC_2);
Save_Cont();
Will_Push(2);
- Push(GC_Daemon_Proc);
- Push(STACK_FRAME_HEADER);
+ STACK_PUSH (GC_Daemon_Proc);
+ STACK_PUSH (STACK_FRAME_HEADER);
Pushed();
goto Internal_Apply;
}
case RC_REPEAT_DISPATCH:
Which_Way = (FIXNUM_TO_LONG (Fetch_Expression ()));
Restore_Env();
- Val = Pop();
+ Val = (STACK_POP ());
Restore_Cont();
goto Repeat_Dispatch;
{
SCHEME_OBJECT Stacklet;
- Prev_Restore_History_Offset = OBJECT_DATUM (Pop());
- Stacklet = Pop();
+ Prev_Restore_History_Offset = OBJECT_DATUM (STACK_POP ());
+ Stacklet = (STACK_POP ());
History = OBJECT_ADDRESS (Fetch_Expression());
if (Prev_Restore_History_Offset == 0)
{
Immediate_GC((Free > MemTop) ? 0 : ((MemTop-Free)+1));
}
Import_Registers();
- Prev_Restore_History_Offset = OBJECT_DATUM (Pop());
- Stacklet = Pop();
+ Prev_Restore_History_Offset = OBJECT_DATUM (STACK_POP ());
+ Stacklet = (STACK_POP ());
if (Prev_Restore_History_Offset == 0)
Prev_Restore_History_Stacklet = NULL;
else
Save_Cont();
Return_Hook_Address = NULL;
Stop_Trapping();
- Push(Val);
- Push(Fetch_Return_Trapper());
- Push(STACK_FRAME_HEADER+1);
+ STACK_PUSH (Val);
+ STACK_PUSH (Fetch_Return_Trapper());
+ STACK_PUSH (STACK_FRAME_HEADER+1);
Pushed();
goto Apply_Non_Trapping;
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/interp.h,v 9.32 1989/09/20 23:09:41 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/interp.h,v 9.33 1990/06/20 17:41:20 cph Rel $
-Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
MIT in each case. */
/* Macros used by the interpreter and some utilities. */
+
+extern void EXFUN (abort_to_interpreter, (int argument));
+extern int EXFUN (abort_to_interpreter_argument, (void));
\f
/********************/
/* OPEN CODED RACKS */
#define Import_Val()
#define Import_Registers_Except_Val() Import_Registers()
-#define Import_Regs_After_Primitive()
-#define Export_Regs_Before_Primitive() Export_Registers()
+#define IMPORT_REGS_AFTER_PRIMITIVE()
+#define EXPORT_REGS_BEFORE_PRIMITIVE Export_Registers
#define Env Regs[REGBLOCK_ENV]
#define Val Regs[REGBLOCK_VAL]
SCHEME_OBJECT *Will_Push_Limit; \
\
Internal_Will_Push((N)); \
- Will_Push_Limit = Simulate_Pushing(N)
+ Will_Push_Limit = (STACK_LOC (- (N)))
#define Pushed() \
if (Stack_Pointer < Will_Push_Limit) \
#define STACK_POP() (STACK_LOCATIVE_POP (Stack_Pointer))
#define STACK_LOC(offset) (STACK_LOCATIVE_OFFSET (Stack_Pointer, (offset)))
#define STACK_REF(offset) (STACK_LOCATIVE_REFERENCE (Stack_Pointer, (offset)))
-
-/* Aliases */
-#define Push STACK_PUSH
-#define Pop STACK_POP
-#define Stack_Ref STACK_REF
-#define Simulate_Pushing(offset) (STACK_LOC (- (offset)))
-#define Simulate_Popping STACK_LOC
-
-#define Top_Of_Stack() (STACK_REF (0))
-#define Stack_Distance(previous_top_of_stack) \
- (STACK_LOCATIVE_DIFFERENCE (previous_top_of_stack, (STACK_LOC (0))))
-
-#define Push_From(SP) (STACK_LOCATIVE_PUSH (SP))
-#define Pop_Into(SP, object) (STACK_LOCATIVE_POP (SP)) = (object)
\f
/* Fetch from register */
#define Store_Return(P) \
Return = MAKE_OBJECT (TC_RETURN_CODE, (P))
-#define Save_Env() Push(Env)
-#define Restore_Env() Env = Pop()
-#define Restore_Then_Save_Env() Env = Top_Of_Stack()
+#define Save_Env() STACK_PUSH (Env)
+#define Restore_Env() Env = (STACK_POP ())
+#define Restore_Then_Save_Env() Env = (STACK_REF (0))
/* Note: Save_Cont must match the definitions in sdata.h */
#define Save_Cont() \
{ \
- Push(Expression); \
- Push(Return); \
- Cont_Print(); \
+ STACK_PUSH (Expression); \
+ STACK_PUSH (Return); \
+ Cont_Print (); \
}
#define Restore_Cont() \
{ \
- Return = Pop(); \
- Expression = Pop(); \
+ Return = (STACK_POP ()); \
+ Expression = (STACK_POP ()); \
if (Cont_Debug) \
{ \
Print_Return(RESTORE_CONT_RETURN_MESSAGE); \
(PRIMITIVE_VIRTUAL_INDEX(primitive)))
/* This will automagically cause an error if the primitive is
- not implemented.
- */
+ not implemented. */
-#define INTERNAL_APPLY_PRIMITIVE(loc, primitive) \
-{ \
- Regs[REGBLOCK_PRIMITIVE] = primitive; \
- loc = \
- ((* \
- (Primitive_Procedure_Table \
- [PRIMITIVE_TABLE_INDEX (primitive)])) \
- ()); \
- Regs[REGBLOCK_PRIMITIVE] = SHARP_F; \
-}
+#ifndef ENABLE_DEBUGGING_TOOLS
-/* This is only valid for implemented primitives. */
+#define PRIMITIVE_APPLY PRIMITIVE_APPLY_INTERNAL
-#define PRIMITIVE_ARITY(primitive) \
-(Primitive_Arity_Table[PRIMITIVE_TABLE_INDEX(primitive)])
+#else
-extern long primitive_to_arity();
+extern SCHEME_OBJECT EXFUN
+ (primitive_apply_internal, (SCHEME_OBJECT primitive));
+#define PRIMITIVE_APPLY(loc, primitive) \
+ (loc) = (primitive_apply_internal (primitive))
-#define PRIMITIVE_N_PARAMETERS(primitive) \
- (primitive_to_arity(primitive))
+#endif
-/* This is only valid during a primitive call. */
+extern char * EXFUN (primitive_to_name, (SCHEME_OBJECT primitive));
+extern long EXFUN (primitive_to_arity, (SCHEME_OBJECT primitive));
+extern long EXFUN (primitive_to_arguments, (SCHEME_OBJECT primitive));
-extern long primitive_to_arguments();
+#define PRIMITIVE_APPLY_INTERNAL(loc, primitive) \
+{ \
+ (Regs[REGBLOCK_PRIMITIVE]) = (primitive); \
+ { \
+ /* Save the dynamic-stack position. */ \
+ PTR PRIMITIVE_APPLY_INTERNAL_position = dstack_position; \
+ (loc) = \
+ ((* \
+ (Primitive_Procedure_Table \
+ [PRIMITIVE_TABLE_INDEX (primitive)])) \
+ ()); \
+ /* If the primitive failed to unwind the dynamic stack, lose. */ \
+ if (PRIMITIVE_APPLY_INTERNAL_position != dstack_position) \
+ { \
+ fprintf (stderr, "\nPrimitive slipped the dynamic stack: %s\n", \
+ (primitive_to_name (primitive))); \
+ fflush (stderr); \
+ Microcode_Termination (TERM_EXIT); \
+ } \
+ } \
+ (Regs[REGBLOCK_PRIMITIVE]) = SHARP_F; \
+}
-#define PRIMITIVE_N_ARGUMENTS(primitive) \
- (primitive_to_arguments(primitive))
+/* This is only valid for implemented primitives. */
-#define Pop_Primitive_Frame(NArgs) \
- Stack_Pointer = Simulate_Popping(NArgs)
-\f
-#define UNWIND_PROTECT(body_statement, cleanup_statement) do \
-{ \
- jmp_buf UNWIND_PROTECT_new_buf, *UNWIND_PROTECT_old_buf; \
- int UNWIND_PROTECT_value; \
- \
- UNWIND_PROTECT_old_buf = Back_To_Eval; \
- Back_To_Eval = ((jmp_buf *) UNWIND_PROTECT_new_buf); \
- UNWIND_PROTECT_value = (setjmp (*Back_To_Eval)); \
- if (UNWIND_PROTECT_value != 0) \
- { \
- Back_To_Eval = UNWIND_PROTECT_old_buf; \
- cleanup_statement; \
- longjmp ((*Back_To_Eval), UNWIND_PROTECT_value); \
- } \
- body_statement; \
- Back_To_Eval = UNWIND_PROTECT_old_buf; \
- cleanup_statement; \
-} while (0)
+#define PRIMITIVE_ARITY(primitive) \
+ (Primitive_Arity_Table [PRIMITIVE_TABLE_INDEX (primitive)])
+
+#define PRIMITIVE_N_PARAMETERS primitive_to_arity
+#define PRIMITIVE_N_ARGUMENTS primitive_to_arguments
+#define POP_PRIMITIVE_FRAME(arity) Stack_Pointer = (STACK_LOC (arity))
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/intrpt.h,v 1.7 1989/09/20 23:09:45 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/intrpt.h,v 1.8 1990/06/20 17:41:26 cph Rel $
-Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
/* Compatibility */
#define COMPILER_SET_MEMTOP() COMPILER_SETUP_INTERRUPT()
-\f
-/* Critical sections.
-
- There should be a stack of critical sections, each with a
- queue of hooks.
- */
-
-extern char * critical_section_name;
-extern Boolean critical_section_hook_p;
-extern void (*critical_section_hook)();
-
-#define DECLARE_CRITICAL_SECTION() \
- char * critical_section_name = ((char *) NULL); \
- Boolean critical_section_hook_p; \
- void (*critical_section_hook)()
-
-#define ENTER_CRITICAL_SECTION(name) \
-{ \
- critical_section_name = (name); \
-}
-
-#define RENAME_CRITICAL_SECTION(name) \
-{ \
- critical_section_name = (name); \
-}
-
-#define EXIT_CRITICAL_SECTION(code_if_hook) \
-{ \
- if (critical_section_hook_p) \
- { \
- code_if_hook; \
- { \
- char * name; \
- \
- name = critical_section_name; \
- critical_section_hook_p = false; \
- critical_section_name = ((char *) NULL); \
- (*critical_section_hook) (name); \
- /*NOTREACHED*/ \
- } \
- } \
- else \
- { \
- critical_section_name = ((char *) NULL); \
- } \
-}
-
-#define SET_CRITICAL_SECTION_HOOK(hook) \
-{ \
- critical_section_hook = (hook); \
- critical_section_hook_p = true; \
-}
-
-#define CLEAR_CRITICAL_SECTION_HOOK() \
-{ \
- critical_section_hook_p = false; \
-}
-
-#define WITHIN_CRITICAL_SECTION_P() \
- (critical_section_name != ((char *) NULL))
-
-#define CRITICAL_SECTION_NAME() \
- (critical_section_name)
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/memmag.c,v 9.43 1990/04/09 14:45:53 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/memmag.c,v 9.44 1990/06/20 17:41:31 cph Rel $
Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
GCFlip();
GC();
CLEAR_INTERRUPT(INT_GC);
- Pop_Primitive_Frame(1);
+ POP_PRIMITIVE_FRAME (1);
GC_Daemon_Proc = Get_Fixed_Obj_Slot(GC_Daemon);
RENAME_CRITICAL_SECTION ("garbage collector daemon");
if (GC_Daemon_Proc == SHARP_F)
Store_Return(RC_NORMAL_GC_DONE);
Store_Expression(LONG_TO_UNSIGNED_FIXNUM(MemTop - Free));
Save_Cont();
- Push(GC_Daemon_Proc);
- Push(STACK_FRAME_HEADER);
+ STACK_PUSH (GC_Daemon_Proc);
+ STACK_PUSH (STACK_FRAME_HEADER);
Pushed();
PRIMITIVE_ABORT(PRIM_APPLY);
/* The following comment is by courtesy of LINT, your friendly sponsor. */
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/mul.c,v 9.28 1990/02/08 00:39:02 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/mul.c,v 9.29 1990/06/20 17:41:36 cph Exp $
Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
#if (TYPE_CODE_LENGTH == 8)
-#if defined(vax) && defined(bsd)
+#if defined(vax) && defined(_BSD)
#define MUL_HANDLED
: SHARP_F);
}
-#endif /* vax+bsd */
+#endif /* vax and _BSD */
\f
-/* 68k family code. Uses hp9000s200 conventions for the new compiler. */
+/* 68k family code. Uses hp9000s300 conventions for the new compiler. */
-#if defined(hp9000s200) && !defined(old_cc) && !defined(__GNUC__)
+#if defined(hp9000s300) && !defined(old_cc) && !defined(__GNUC__)
#define MUL_HANDLED
/* The following constants are hard coded in the assembly language
asm(" data");
#endif /* not MC68020 */
-#endif /* hp9000s200 */
+#endif /* hp9000s300 */
\f
#endif /* (TYPE_CODE_LENGTH == 8) */
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/ppband.c,v 9.37 1990/04/17 21:55:47 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/ppband.c,v 9.38 1990/06/20 17:37:59 cph Exp $
-Copyright (c) 1987, 1989 Massachusetts Institute of Technology
+Copyright (c) 1987, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
#include "sdata.h"
#define fast register
-\f
+
/* These are needed by load.c */
static SCHEME_OBJECT * memory_base;
return (fread (To_Where, (sizeof (SCHEME_OBJECT)), Count, stdin));
}
-long
-Write_Data()
-{
- fprintf(stderr, "Write_Data called\n");
- exit(1);
-}
-
-Boolean
-Open_Dump_File()
-{
- fprintf(stderr, "Open_Dump_File called\n");
- exit(1);
-}
-
-Boolean
-Close_Dump_File()
-{
- fprintf(stderr, "Close_Dump_File called\n");
- exit(1);
-}
-\f
#define INHIBIT_COMPILED_VERSION_CHECK
#include "load.c"
-
+\f
#ifdef HEAP_IN_LOW_MEMORY
-#ifdef spectrum
+#ifdef hp9000s800
#define File_To_Pointer(P) \
((((long) (P)) & DATUM_MASK) / sizeof(SCHEME_OBJECT))
#else
#define File_To_Pointer(P) ((P) / sizeof(SCHEME_OBJECT))
-#endif /* spectrum */
+#endif /* hp9000s800 */
#else
#define File_To_Pointer(P) (P)
#endif
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/prename.h,v 1.3 1989/09/20 23:10:32 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/prename.h,v 1.4 1990/06/20 17:41:41 cph Rel $
-Copyright (c) 1988 Massachusetts Institute of Technology
+Copyright (c) 1988, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
{ "NULL?", "NOT" },
{ "FALSE?", "NOT" },
{ "PRIMITIVE-TYPE", "OBJECT-TYPE" },
- { "PRIMITIVE-GC-TYPE", "PRIMITIVE-OBJECT-GC-TYPE" },
{ "PRIMITIVE-TYPE?", "OBJECT-TYPE?" },
- { "PRIMITIVE-DATUM", "PRIMITIVE-OBJECT-DATUM" },
- { "PRIMITIVE-SET-TYPE", "OBJECT-SET-TYPE" },
{ "&MAKE-OBJECT", "PRIMITIVE-OBJECT-SET-TYPE" },
{ "SYSTEM-MEMORY-REF", "PRIMITIVE-OBJECT-REF" },
- { "SYSTEM-MEMORY-SET!", "PRIMITIVE-OBJECT-SET!" },
- { "OBJECT-NEW-TYPE", "OBJECT-SET-TYPE" },
{ "PRIMITIVE-OBJECT-NEW-TYPE", "PRIMITIVE-OBJECT-SET-TYPE" },
- { "SINE-FLONUM", "FLONUM-SIN" },
- { "COSINE-FLONUM", "FLONUM-COS" },
- { "ATAN-FLONUM", "FLONUM-ATAN" },
- { "EXP-FLONUM", "FLONUM-EXP" },
- { "LN-FLONUM", "FLONUM-LOG" },
- { "SQRT-FLONUM", "FLONUM-SQRT" },
- { "PLUS-FLONUM", "FLONUM-ADD" },
- { "MINUS-FLONUM", "FLONUM-SUBTRACT" },
- { "MULTIPLY-FLONUM", "FLONUM-MULTIPLY" },
- { "DIVIDE-FLONUM", "FLONUM-DIVIDE" },
- { "ZERO-FLONUM?", "FLONUM-ZERO?" },
- { "POSITIVE-FLONUM?", "FLONUM-POSITIVE?" },
- { "NEGATIVE-FLONUM?", "FLONUM-NEGATIVE?" },
- { "EQUAL-FLONUM?", "FLONUM-EQUAL?" },
- { "LESS-THAN-FLONUM?", "FLONUM-LESS?" },
- { "GREATER-THAN-FLONUM?", "FLONUM-GREATER?" },
- { "TRUNCATE-FLONUM", "FLONUM-TRUNCATE->EXACT" }
+ { "FILE-CLOSE-CHANNEL", "CHANNEL-CLOSE" },
+ { "PHOTO-OPEN", "TRANSCRIPT-ON" },
+ { "PHOTO-CLOSE", "TRANSCRIPT-OFF" },
+ { "GET-NEXT-INTERRUPT-CHARACTER", "TTY-NEXT-INTERRUPT-CHAR" },
+ { "CHECK-AND-CLEAN-UP-INPUT-CHANNEL", "TTY-CLEAN-INTERRUPTS" },
+ { "REMOVE-FILE", "FILE-REMOVE" },
+ { "RENAME-FILE", "FILE-RENAME" },
+ { "COPY-FILE", "FILE-COPY" },
+ { "MAKE-DIRECTORY", "DIRECTORY-MAKE" },
+ { "OPEN-DIRECTORY", "DIRECTORY-OPEN" },
+ { "SCREEN-X-SIZE", "TTY-X-SIZE" },
+ { "SCREEN-Y-SIZE", "TTY-Y-SIZE" },
+ { "FILE-SYMLINK?", "FILE-SOFT-LINK?" }
};
-#define N_ALIASES 29
+#define N_ALIASES 20
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/prims.h,v 9.36 1989/09/20 23:10:42 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/prims.h,v 9.37 1990/06/20 17:41:45 cph Rel $
-Copyright (c) 1987, 1989 Massachusetts Institute of Technology
+Copyright (c) 1987, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
/* Primitives return by performing one of the following operations. */
#define PRIMITIVE_RETURN(value) return (value)
-#define PRIMITIVE_ABORT(action) longjmp ((*Back_To_Eval), (action))
+#define PRIMITIVE_ABORT abort_to_interpreter
extern void canonicalize_primitive_context ();
#define PRIMITIVE_CANONICALIZE_CONTEXT canonicalize_primitive_context
/* -*-C-*-
-Copyright (c) 1988, 1989 Massachusetts Institute of Technology
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/purify.c,v 9.43 1990/06/20 17:41:52 cph Exp $
+
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/purify.c,v 9.42 1989/11/26 17:38:52 jinx Exp $
- *
- * This file contains the code that copies objects into pure
- * and constant space.
- *
- */
+/* This file contains the code that copies objects into pure
+ and constant space. */
#include "scheme.h"
#include "prims.h"
GC_Reserve = new_gc_reserve;
ENTER_CRITICAL_SECTION ("purify pass 1");
Purify_Result = (Purify (Object, (ARG_REF (2))));
- Pop_Primitive_Frame (3);
+ POP_PRIMITIVE_FRAME (3);
Daemon = Get_Fixed_Obj_Slot(GC_Daemon);
if (Daemon == SHARP_F)
{
Store_Return(RC_PURIFY_GC_1);
Will_Push(CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS + 1);
Save_Cont();
- Push(Daemon);
- Push(STACK_FRAME_HEADER);
+ STACK_PUSH (Daemon);
+ STACK_PUSH (STACK_FRAME_HEADER);
Pushed();
PRIMITIVE_ABORT(PRIM_APPLY);
/*NOTREACHED*/
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/scheme.h,v 9.31 1989/09/24 15:13:08 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/scheme.h,v 9.32 1990/06/20 17:41:58 cph Exp $
-Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
#define forward extern /* For forward references */
-#include <setjmp.h>
#include <stdio.h>
+#include "oscond.h" /* Identify the operating system */
+#include "ansidecl.h" /* Macros to support ANSI declarations */
+#include "dstack.h" /* Dynamic stack support package */
+#include "obstack.h" /* Obstack package */
#include "config.h" /* Machine and OS configuration info */
#ifdef SITE_INCLUDE_FILE
#include "const.h" /* Various named constants */
#include "object.h" /* Scheme object representation */
#include "intrpt.h" /* Interrupt processing macros */
+#include "critsec.h" /* Critical sections */
#include "gc.h" /* Memory management related macros */
#include "scode.h" /* Scheme scode representation */
#include "sdata.h" /* Scheme user data representation */
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/stack.h,v 9.27 1989/09/20 23:11:35 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/stack.h,v 9.28 1990/06/20 17:42:03 cph Rel $
-Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
Store_Expression(SHARP_F); \
Store_Return(RC_END_OF_COMPUTATION); \
Save_Cont(); \
- Push(Val); \
- Push(Previous_Stacklet); \
- Push(STACK_FRAME_HEADER + 1); \
+ STACK_PUSH (Val); \
+ STACK_PUSH (Previous_Stacklet); \
+ STACK_PUSH (STACK_FRAME_HEADER + 1); \
Store_Return(RC_INTERNAL_APPLY); \
Save_Cont(); \
Pushed()
/* -*-C-*-
-Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/step.c,v 9.28 1990/06/20 17:42:08 cph Rel $
+
+Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/step.c,v 9.27 1989/09/20 23:11:47 cph Exp $
- *
- * Support for the stepper
- */
+/* Support for the stepper */
#include "scheme.h"
#include "prims.h"
has the existing return code to be clobbered, since it was put
there by Save_Cont.
*/
- Return_Hook_Address = &Top_Of_Stack();
- Old_Return_Code = Top_Of_Stack();
- *Return_Hook_Address =
+ Return_Hook_Address = (STACK_LOC (0));
+ Old_Return_Code = (*Return_Hook_Address);
+ (*Return_Hook_Address) =
(MAKE_OBJECT (TC_RETURN_CODE, RC_RETURN_TRAP_POINT));
}
return;
SCHEME_OBJECT environment = (ARG_REF (2));
PRIMITIVE_CANONICALIZE_CONTEXT ();
Install_Traps ((ARG_REF (3)), false);
- Pop_Primitive_Frame (3);
+ POP_PRIMITIVE_FRAME (3);
Store_Expression (expression);
Store_Env (environment);
}
error_wrong_type_arg (2);
}
Install_Traps ((ARG_REF (3)), true);
- Pop_Primitive_Frame (3);
+ POP_PRIMITIVE_FRAME (3);
{
fast SCHEME_OBJECT * scan_stack = (STACK_LOC (- number_of_args));
fast SCHEME_OBJECT scan_list;
(*scan_stack++) = (PAIR_CAR (scan_list));
TOUCH_IN_PRIMITIVE ((PAIR_CDR (scan_list)), scan_list);
}
- Push (procedure);
- Push (STACK_FRAME_HEADER + number_of_args);
+ STACK_PUSH (procedure);
+ STACK_PUSH (STACK_FRAME_HEADER + number_of_args);
Pushed ();
}
}
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/storage.c,v 9.45 1989/11/30 03:04:10 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/storage.c,v 9.46 1990/06/20 17:42:13 cph Exp $
-Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
/* Used to signal microcode errors from compiled code. */
compiled_code_error_code;
-Declare_Fixed_Objects();
-
-FILE *(Channels[FILE_CHANNELS]), *Photo_File_Handle;
-
-int Saved_argc;
-char **Saved_argv;
-char *OS_Name, *OS_Variant;
-
-Boolean Photo_Open; /* Photo file open */
+Declare_Fixed_Objects ();
Boolean Trapping;
-SCHEME_OBJECT Old_Return_Code, *Return_Hook_Address;
+SCHEME_OBJECT Old_Return_Code;
+SCHEME_OBJECT * Return_Hook_Address;
-SCHEME_OBJECT *Prev_Restore_History_Stacklet;
+SCHEME_OBJECT * Prev_Restore_History_Stacklet;
long Prev_Restore_History_Offset;
-jmp_buf *Back_To_Eval; /* Buffer for set/longjmp */
-
-long Heap_Size, Constant_Size, Stack_Size;
-SCHEME_OBJECT *Highest_Allocated_Address;
-
+long Heap_Size;
+long Constant_Size;
+long Stack_Size;
+SCHEME_OBJECT * Highest_Allocated_Address;
#ifndef HEAP_IN_LOW_MEMORY
-
SCHEME_OBJECT * memory_base;
-
#endif
\f
/**********************/
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/sysprim.c,v 9.33 1989/09/20 23:12:08 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/sysprim.c,v 9.34 1990/06/20 17:42:19 cph Exp $
-Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
#include "scheme.h"
#include "prims.h"
+#include "ostty.h"
+#include "ostop.h"
\f
-/* Interrupt primitives */
-
-DEFINE_PRIMITIVE ("CHECK-AND-CLEAN-UP-INPUT-CHANNEL", Prim_chk_and_cln_input_channel, 2, 2, 0)
-{
- extern Boolean OS_tty_clean_interrupts();
- PRIMITIVE_HEADER (2);
-
- PRIMITIVE_RETURN
- (BOOLEAN_TO_OBJECT
- (OS_tty_clean_interrupts ((arg_nonnegative_integer (1)),
- (arg_nonnegative_integer (2)))));
-}
-
-DEFINE_PRIMITIVE ("GET-NEXT-INTERRUPT-CHARACTER", Prim_get_next_interrupt_char, 0, 0, 0)
-{
- int result;
- extern int OS_tty_next_interrupt_char();
- PRIMITIVE_HEADER (0);
-
- result = (OS_tty_next_interrupt_char ());
- if (result == -1)
- {
- error_external_return ();
- /*NOTREACHED*/
- }
- PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (result));
-}
-\f
-/* Time primitives */
-
-DEFINE_PRIMITIVE ("SYSTEM-CLOCK", Prim_system_clock, 0, 0, 0)
-{
- PRIMITIVE_HEADER (0);
- PRIMITIVE_RETURN (long_to_integer (OS_process_clock ()));
-}
+/* Pretty random primitives */
-DEFINE_PRIMITIVE ("REAL-TIME-CLOCK", Prim_real_time_clock, 0, 0, 0)
+DEFINE_PRIMITIVE ("EXIT", Prim_non_restartable_exit, 0, 0,
+ "Exit Scheme with no option to restart.")
{
- extern long OS_real_time_clock ();
PRIMITIVE_HEADER (0);
- PRIMITIVE_RETURN (long_to_integer (OS_real_time_clock ()));
+ termination_normal ();
}
-DEFINE_PRIMITIVE ("SETUP-TIMER-INTERRUPT", Prim_setup_timer_interrupt, 2, 2, 0)
-{
- extern void Clear_Int_Timer ();
- extern void Set_Int_Timer ();
- PRIMITIVE_HEADER (2);
- if (((ARG_REF (1)) == SHARP_F) && ((ARG_REF (2)) == SHARP_F))
- Clear_Int_Timer ();
- else
- Set_Int_Timer
- ((arg_nonnegative_integer (1)), (arg_nonnegative_integer (2)));
- PRIMITIVE_RETURN (UNSPECIFIC);
-}
-
-/* Date and current time primitives */
-
-#define DATE_PRIMITIVE(OS_name) \
-{ \
- int result; \
- extern int OS_name (); \
- PRIMITIVE_HEADER (0); \
- result = (OS_name ()); \
- PRIMITIVE_RETURN \
- ((result == -1) ? SHARP_F : (LONG_TO_UNSIGNED_FIXNUM (result))); \
-}
-
-DEFINE_PRIMITIVE ("CURRENT-YEAR", Prim_current_year, 0, 0, 0)
- DATE_PRIMITIVE (OS_Current_Year)
-
-DEFINE_PRIMITIVE ("CURRENT-MONTH", Prim_current_month, 0, 0, 0)
- DATE_PRIMITIVE (OS_Current_Month)
-
-DEFINE_PRIMITIVE ("CURRENT-DAY", Prim_current_day, 0, 0, 0)
- DATE_PRIMITIVE (OS_Current_Day)
-
-DEFINE_PRIMITIVE ("CURRENT-HOUR", Prim_current_hour, 0, 0, 0)
- DATE_PRIMITIVE (OS_Current_Hour)
-
-DEFINE_PRIMITIVE ("CURRENT-MINUTE", Prim_current_minute, 0, 0, 0)
- DATE_PRIMITIVE (OS_Current_Minute)
-
-DEFINE_PRIMITIVE ("CURRENT-SECOND", Prim_current_second, 0, 0, 0)
- DATE_PRIMITIVE (OS_Current_Second)
-\f
-/* Pretty random primitives */
-
-/* (EXIT)
- Halt SCHEME, with no intention of restarting. */
-
-DEFINE_PRIMITIVE ("EXIT", Prim_non_restartable_exit, 0, 0, 0)
+DEFINE_PRIMITIVE ("HALT", Prim_restartable_exit, 0, 0,
+ "Exit Scheme, suspending it to that it can be restarted.")
{
PRIMITIVE_HEADER (0);
-
- Microcode_Termination (TERM_HALT);
+ OS_restartable_exit ();
}
-/* (HALT)
- Halt Scheme in such a way that it can be restarted.
- Not all operating systems support this. */
-
-DEFINE_PRIMITIVE ("HALT", Prim_restartable_exit, 0, 0, 0)
+DEFINE_PRIMITIVE ("UNDER-EMACS?", Prim_under_emacs_p, 0, 0, 0)
{
- extern Boolean Restartable_Exit();
PRIMITIVE_HEADER (0);
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (Restartable_Exit ()));
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (OS_under_emacs_p ()));
}
/* (SET-RUN-LIGHT! OBJECT)
{
PRIMITIVE_HEADER (1);
#ifdef RUN_LIGHT_IS_BEEP
- {
- extern void OS_tty_beep();
-
- OS_tty_beep();
- OS_tty_flush_output();
- PRIMITIVE_RETURN (SHARP_T);
- }
+ OS_tty_beep ();
+ PRIMITIVE_RETURN (SHARP_T);
#else
PRIMITIVE_RETURN (SHARP_F);
#endif
}
-DEFINE_PRIMITIVE ("UNDER-EMACS?", Prim_under_emacs_p, 0, 0, 0)
-{
- extern Boolean OS_under_emacs_p ();
- PRIMITIVE_HEADER (0);
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (OS_under_emacs_p ()));
-}
-\f
#define CONVERT_ADDRESS(address) \
(long_to_integer (ADDRESS_TO_DATUM (address)))
#endif /* USE_STACKLETS */
PRIMITIVE_RETURN (result);
}
-\f
+
DEFINE_PRIMITIVE ("SET-TRAP-STATE!", Prim_set_trap_state, 1, 1, 0)
{
long result;
#!/bin/sh
# Configuration script for MIT Scheme
-# $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/unxutl/Attic/config,v 1.5 1990/02/07 21:31:56 jinx Exp $
+# $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/unxutl/Attic/config,v 1.6 1990/06/20 17:39:22 cph Exp $
# Modelled on the configuration script for GNU CC
# Copyright (C) 1988 Free Software Foundation, Inc.
#hard_link="echo ln"
#symbolic_link="echo ln -s"
+cmpint_file=nothing_special
cmp_file=nothing_special
case $# in
machine=$1
case $machine in
- vax) # for vaxen running bsd
+ vax-bsd42) # vaxen running 4.2BSD
system_file=bsd4-2
machine_file=vax
- mfour_file=bsd
;;
- vax-ultrix) # for vaxen running ultrix
+ vax-bsd43) # vaxen running 4.3BSD
+ system_file=bsd4-3
+ machine_file=vax
+ ;;
+ vax-ultrix) # vaxen running ultrix
system_file=ultrix
machine_file=vax
- mfour_file=bsd
;;
- mips-ultrix)
+ mips-ultrix | dec-3100 | pmax)
system_file=ultrix
machine_file=mips
- mfour_file=bsd
+ cmpint_file=cmpint-mips.h
;;
- hp9k300)
+ hp9k300 | bobcat) # HP9000 series 300
system_file=hpux
machine_file=hp9k300
- mfour_file=sysV
+ cmpint_file=cmpint-mc68k.h
;;
- hp9k800)
+ hp9k800 | spectrum | hppa) # HP9000 series 800
system_file=hpux
machine_file=hp9k800
- mfour_file=sysV
+ cmpint_file=cmpint-hppa.h
;;
sun3)
- system_file=bsd4-2
+ system_file=sunos4
machine_file=sun3
- mfour_file=bsd
- cmp_file=sun/cmp68020.s
- cmp_link=cmp68020.s
+ cmpint_file=cmpint-mc68k.h
+ cmp_file=sun/cmpaux-mc68k.s
+ cmp_link=cmpaux-mc68k.s
;;
- sun3-nfp) # Sun3, No Floating Point
- system_file=bsd4-2
+ sun3-os3) # sun3, pre-4.0 sunos
+ system_file=sunos3
machine_file=sun3
- mfour_file=bsd
- cmp_file=sun-nfp/cmp68020.s
- cmp_link=cmp68020.s
+ cmpint_file=cmpint-mc68k.h
+ cmp_file=sun/cmpaux-mc68k.s
+ cmp_link=cmpaux-mc68k.s
;;
- sun4)
- system_file=bsd4-2
+ sun3-nfp) # sun3, No Floating Point
+ system_file=sunos4
+ machine_file=sun3
+ cmpint_file=cmpint-mc68k.h
+ cmp_file=sun-nfp/cmpaux-mc68k.s
+ cmp_link=cmpaux-mc68k.s
+ ;;
+ sun3-os3-nfp) # sun3, pre-4.0 sunos, No Floating Point
+ system_file=sunos3
+ machine_file=sun3
+ cmpint_file=cmpint-mc68k.h
+ cmp_file=sun-nfp/cmpaux-mc68k.s
+ cmp_link=cmpaux-mc68k.s
+ ;;
+ sun4 | sparc)
+ system_file=sunos4
machine_file=sun4
- mfour_file=bsd
;;
umax) # Encore Multimax
system_file=umax
machine_file=umax
- mfour_file=bsd
;;
*)
echo "$progname: unknown machine name: $machine"
exit 1
esac
- files="s/${system_file}.h m/${machine_file}.h ${mfour_file}.macros"
- links="s.h m.h m4.macros"
+ files="s/${system_file}.h m/${machine_file}.h"
+ links="s.h m.h"
while [ -n "$files" ]
do
echo "Linked \`$link' to \`$file'."
done
+ case $cmpint_file in
+ nothing_special)
+ ;;
+ *)
+ $symbolic_link $cmpint_file cmpint2.h 2>/dev/null || $hard_link $cmpint_file cmpint2.h
+ if [ ! -r cmpint2.h ]
+ then
+ echo "$progname: unable to link \`cmpint2.h' to \`$cmpint_file'."
+ exit 1
+ fi
+ echo "Linked \`cmpint2.h' to \`$cmpint_file'."
+ ;;
+ esac
+
case $cmp_file in
nothing_special)
;;
;;
*)
echo "Usage: $progname machine"
- echo -n "Where \`machine' is something like "
- echo "\`vax', \`sun3', \`hp9k300', etc."
+ echo "Where \`machine' is one of:"
+ echo "vax-bsd42 vax-bsd43 vax-ultrix mips-ultrix hp9k300 hp9k800"
+ echo "sun3 sun3-nfp sun4 umax"
if [ -r config.status ]
then
cat config.status
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/unxutl/Attic/ymkfile,v 1.22 1990/04/17 19:16:28 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/unxutl/Attic/ymkfile,v 1.23 1990/06/20 17:42:50 cph Exp $
Copyright (c) 1989, 1990 Massachusetts Institute of Technology
comutl.c \
daemon.c \
debug.c \
+error.c \
extern.c \
fasdump.c \
fasload.c \
-fileio.c \
fixnum.c \
flonum.c \
gcloop.c \
lookprm.c \
lookup.c \
memmag.c \
+obstack.c \
+osscheme.c \
+ostty.c \
prim.c \
primutl.c \
-process.c \
+ptrvec.c \
purify.c \
purutl.c \
regex.c \
string.c \
syntax.c \
sysprim.c \
-ttyio.c \
+term.c \
+transact.c \
utils.c \
-vector.c
+vector.c \
+wind.c
+
+UNIX_SOURCES = \
+intext.c \
+ux.c \
+uxctty.c \
+uxenv.c \
+uxfile.c \
+uxfs.c \
+uxio.c \
+uxproc.c \
+uxsig.c \
+uxsock.c \
+uxterm.c \
+uxtop.c \
+uxtrap.c \
+uxtty.c \
+uxutil.c
+
+OS_PRIM_SOURCES = \
+prosenv.c \
+prosfile.c \
+prosfs.c \
+prosio.c \
+prosproc.c \
+prosterm.c \
+prostty.c \
+pruxenv.c \
+pruxfs.c \
+pruxsock.c
HEAD_FILES = scheme.touch prims.h zones.h locks.h bignum.h \
$(GC_HEAD_FILES) trap.h lookup.h history.h cmpint.h
comutl.o \
daemon.o \
debug.o \
+error.o \
extern.o \
fasload.o \
-fileio.o \
fixnum.o \
flonum.o \
generic.o \
list.o \
lookprm.o \
lookup.o \
+obstack.o \
+osscheme.o \
+ostty.o \
prim.o \
primutl.o \
-process.o \
+ptrvec.o \
purutl.o \
regex.o \
rgxprim.o \
string.o \
syntax.o \
sysprim.o \
-ttyio.o \
+term.o \
+transact.o \
utils.o \
-vector.o
+vector.o \
+wind.o
+
+UNIX_OBJECTS = \
+intext.o \
+ux.o \
+uxctty.o \
+uxenv.o \
+uxfile.o \
+uxfs.o \
+uxio.o \
+uxproc.o \
+uxsig.o \
+uxsock.o \
+uxterm.o \
+uxtop.o \
+uxtrap.o \
+uxtty.o \
+uxutil.o
+
+OS_PRIM_OBJECTS = \
+prosenv.o \
+prosfile.o \
+prosfs.o \
+prosio.o \
+prosproc.o \
+prosterm.o \
+prostty.o \
+pruxenv.o \
+pruxfs.o \
+pruxsock.o
STD_GC_OBJECTS = \
fasdump.o \
bchmmg.o \
bchpur.o
-OBJECTS = $(CORE_OBJECTS) $(STD_GC_OBJECTS) os.o
-BCHOBJECTS = $(CORE_OBJECTS) $(BCH_GC_OBJECTS) os.o
+OBJECTS = $(CORE_OBJECTS) $(STD_GC_OBJECTS) $(UNIX_OBJECTS) $(OS_PRIM_OBJECTS)
+BCHOBJECTS = $(CORE_OBJECTS) $(BCH_GC_OBJECTS) $(UNIX_OBJECTS) $(OS_PRIM_OBJECTS)
/* Construction rules. */
/* The first two are for VMS. */
usrdef.txt :
- ./make_vmslist usrdef.txt $(SCHEME_SOURCES) $(SOURCES)
+ ./make_vmslist usrdef.txt $(SCHEME_SOURCES) $(SOURCES) $(OS_PRIM_SOURCES)
vmsusrdef.c :
echo "$$ Findprim -o usrdef.c -l [-.vms]usrdef.txt"
$(CC) $(CFLAGS) -c usrdef.c
-usrdef.c : $(SCHEME_SOURCES) $(SOURCES) usrdef.touch Findprim xmakefile
+usrdef.c : $(SCHEME_SOURCES) $(SOURCES) $(OS_PRIM_SOURCES) usrdef.touch Findprim xmakefile
@ECHO "#** Re-making" $@ because of $?
rm -f usrdef.c
- ./Findprim $(SCHEME_SOURCES) $(SOURCES) > usrdef.c
+ ./Findprim $(SCHEME_SOURCES) $(SOURCES) $(OS_PRIM_SOURCES) > usrdef.c
primitive_tables :
rm -f usrdef.c usrdef.o
-scheme.touch os.touch psbmap.touch usrdef.touch :
+scheme.touch psbmap.touch usrdef.touch :
@ECHO "#** Resetting" $@ because of $?
rm -f $@
- touch $@
+ /* Create the file by opening rather than using `touch' program.
+ Some versions of the `touch' program don't work well when the
+ file server's clock is not synchronized with the client's. */
+ echo "touch" > $@
#include "ymake.local"
/* scheme.touch depends also on butterfly.h rename.c */
-scheme.touch : scheme.h config.h bkpt.h object.h scode.h sdata.h \
- gc.h interp.h stack.h futures.h types.h errors.h returns.h \
- const.h fixobj.h default.h extern.h prim.h intrpt.h float.h
-os.touch : os.c unix.c vms.c unknown.c scheme.touch zones.h \
- process.h unixpro.c
+scheme.touch : scheme.h oscond.h ansidecl.h dstack.h obstack.h config.h \
+ bkpt.h object.h scode.h sdata.h gc.h interp.h stack.h futures.h \
+ types.h errors.h returns.h const.h fixobj.h default.h extern.h prim.h \
+ intrpt.h critsec.h float.h
psbmap.touch : config.h object.h bignum.h bignumint.h bitstr.h types.h \
sdata.h const.h psbmap.h $(GC_HEAD_FILES) comlin.h comlin.c
usrdef.touch : usrdef.h config.h object.h prim.h
storage.o : scheme.touch gctype.c
-char.o fileio.o string.o ttyio.o : scheme.touch prims.h
+char.o string.o : scheme.touch prims.h
boot.o : scheme.touch prims.h version.h paths.h
+term.o : scheme.touch
compiler.o : config.h object.h sdata.h types.h errors.h const.h returns.h
-os.o : scheme.touch os.touch zones.h
-bchmmg.o bchgcl.o bchpur.o : scheme.touch prims.h bchgcc.h $(GC_HEAD_FILES)
-bchdmp.o : scheme.touch prims.h bchgcc.h $(GC_HEAD_FILES) fasl.h dump.c
+bchmmg.o bchgcl.o bchpur.o : scheme.touch prims.h bchgcc.h oscond.h $(GC_HEAD_FILES)
+bchdmp.o : scheme.touch prims.h bchgcc.h oscond.h $(GC_HEAD_FILES) fasl.h dump.c
syntax.o : scheme.touch prims.h edwin.h syntax.h
bitstr.o : scheme.touch prims.h bitstr.h
regex.o : scheme.touch syntax.h regex.h
rgxprim.o : scheme.touch prims.h edwin.h syntax.h regex.h
-unixprim.o : scheme.touch prims.h
Bintopsb.o : psbmap.touch trap.h limits.h fasl.h load.c bltdef.h
Psbtobin.o : psbmap.touch float.h fasl.h dump.c
cmpaux-mc68k.s : cmpaux-mc68k.m4
cmpaux-vax.s : cmpaux-vax.m4
-process.c : scheme.touch process.h prims.h
+osscheme.o : scheme.touch posixtype.h os.h osscheme.h
+ostty.o : ansidecl.h posixtype.h os.h ostty.h osscheme.h
+
+error.o ptrvec.o transact.o : ansidecl.h dstack.h
+wind.o : ansidecl.h dstack.h obstack.h
+obstack.o : obstack.h
+
+$(UNIX_OBJECTS) pruxenv.o pruxfs.o pruxsock.o : oscond.h ansidecl.h \
+ posixtype.h intext.h dstack.h os.h osscheme.h ux.h
+uxctty.o : osctty.h
+uxenv.o : osenv.h
+uxfile.o : osfile.h osio.h uxio.h
+uxfs.o : osfs.h
+uxio.o : osio.h uxio.h
+uxproc.o : osproc.h uxproc.h
+uxsig.o : ossig.h osctty.h uxtrap.h uxutil.h critsec.h
+uxsock.o : uxsock.h
+uxterm.o : osterm.h uxterm.h osio.h uxio.h
+uxtop.o : ostop.h
+uxtrap.o : scheme.touch uxtrap.h
+uxtty.o : ostty.h osenv.h osterm.h uxterm.h
+uxutil.o : uxutil.h
+pruxfs.o : osfs.h
+pruxsock.o : uxsock.h
+
+$(OS_PRIM_OBJECTS) : scheme.touch prims.h posixtype.h os.h
+prosenv.o : osenv.h
+prosfile.o : osfile.h
+prosfs.o pruxfs.o : osfs.h
+prosio.o : osio.h
+prosproc.o : osproc.h
+prosterm.o : osterm.h osio.h
+prostty.o : ostty.h osctty.h ossig.h osfile.h osio.h
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utils.c,v 9.44 1989/09/20 23:12:51 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utils.c,v 9.45 1990/06/20 17:42:27 cph Exp $
Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
* the currently enabled interrupts.
*/
- Push(LONG_TO_FIXNUM(FETCH_INTERRUPT_MASK()));
- Push(LONG_TO_FIXNUM(The_Int_Code));
- Push(Handler);
- Push(STACK_FRAME_HEADER + 2);
+ STACK_PUSH (LONG_TO_FIXNUM(FETCH_INTERRUPT_MASK()));
+ STACK_PUSH (LONG_TO_FIXNUM(The_Int_Code));
+ STACK_PUSH (Handler);
+ STACK_PUSH (STACK_FRAME_HEADER + 2);
Pushed();
/* Turn off interrupts */
SET_INTERRUPT_MASK(New_Int_Enb);
err_print (code, stderr);
fprintf (stderr, "\n**** Stack Trace ****\n\n");
Back_Trace (stderr);
- Microcode_Termination (TERM_NO_ERROR_HANDLER);
+ termination_no_error_handler ();
/*NOTREACHED*/
}
Microcode_Termination (TERM_BAD_BACK_OUT);
}
nargs = (PRIMITIVE_N_ARGUMENTS (primitive));
- if (COMPILED_CODE_ADDRESS_P (Stack_Ref (nargs)))
+ if (COMPILED_CODE_ADDRESS_P (STACK_REF (nargs)))
compiler_apply_procedure (nargs);
- Push (primitive);
- Push (STACK_FRAME_HEADER + nargs);
+ STACK_PUSH (primitive);
+ STACK_PUSH (STACK_FRAME_HEADER + nargs);
Store_Env (MAKE_OBJECT (GLOBAL_ENV, END_OF_CHAIN));
Val = SHARP_F;
Store_Return (RC_INTERNAL_APPLY);
Microcode_Termination (TERM_BAD_BACK_OUT);
}
nargs = (PRIMITIVE_N_ARGUMENTS (primitive));
- if (! (COMPILED_CODE_ADDRESS_P (Stack_Ref (nargs))))
+ if (! (COMPILED_CODE_ADDRESS_P (STACK_REF (nargs))))
return;
/* The primitive has been invoked from compiled code. */
PRIMITIVE_ABORT (PRIM_REENTER);
}
else
{
- Push(Fetch_Env());
+ STACK_PUSH (Fetch_Env());
}
Store_Return((From_Pop_Return) ?
Store_Expression(LONG_TO_FIXNUM(FETCH_INTERRUPT_MASK()));
Save_Cont();
/* Arg 2: Int. mask */
- Push(LONG_TO_FIXNUM(FETCH_INTERRUPT_MASK()));
+ STACK_PUSH (LONG_TO_FIXNUM(FETCH_INTERRUPT_MASK()));
/* Arg 1: Err. No */
if ((Err >= SMALLEST_FIXNUM) && (Err <= BIGGEST_FIXNUM))
{
- Push (LONG_TO_FIXNUM(Err));
+ STACK_PUSH (LONG_TO_FIXNUM(Err));
}
else
{
- Push (LONG_TO_UNSIGNED_FIXNUM (ERR_BAD_ERROR_CODE));
+ STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (ERR_BAD_ERROR_CODE));
}
/* Procedure: Handler */
- Push(Handler);
- Push(STACK_FRAME_HEADER + 2);
+ STACK_PUSH (Handler);
+ STACK_PUSH (STACK_FRAME_HEADER + 2);
Pushed();
/* Disable all interrupts */
return (true);
}
\f
-/* If a debugging version of the interpreter is made, then this
- * procedure is called to actually invoke a primitive. When a
- * 'production' version is made, all of the consistency checks are
- * omitted and a macro from DEFAULT.H is used to directly code the
- * call to the primitive function. This is only used in INTERPRET.C.
- */
+/* If a "debugging" version of the interpreter is made, then this
+ procedure is called to actually invoke a primitive. When a
+ "production" version is made, all of the consistency checks are
+ omitted and a macro from "default.h" is used to directly code the
+ call to the primitive function. */
#ifdef ENABLE_DEBUGGING_TOOLS
SCHEME_OBJECT
-Apply_Primitive (primitive)
- SCHEME_OBJECT primitive;
+DEFUN (primitive_apply_internal, (primitive), SCHEME_OBJECT primitive)
{
- SCHEME_OBJECT Result, *Saved_Stack;
-
+ SCHEME_OBJECT result;
if (Primitive_Debug)
+ Print_Primitive (primitive);
{
- Print_Primitive(primitive);
- }
- Saved_Stack = Stack_Pointer;
- INTERNAL_APPLY_PRIMITIVE(Result, primitive);
- if (Saved_Stack != Stack_Pointer)
- {
-
- int NArgs;
-
- NArgs = PRIMITIVE_N_ARGUMENTS(primitive);
- Print_Expression(primitive, "Stack bad after ");
- fprintf(stderr,
- "\nStack was 0x%x, now 0x%x, #args=%d.\n",
- Saved_Stack, Stack_Pointer, NArgs);
- Microcode_Termination(TERM_EXIT);
- /*NOTREACHED*/
+ SCHEME_OBJECT * saved_stack = Stack_Pointer;
+ PRIMITIVE_APPLY_INTERNAL (result, primitive);
+ if (saved_stack != Stack_Pointer)
+ {
+ int arity = (PRIMITIVE_N_ARGUMENTS (primitive));
+ Print_Expression (primitive, "Stack bad after ");
+ fprintf (stderr, "\nStack was 0x%x, now 0x%x, #args=%d.\n",
+ saved_stack, Stack_Pointer, arity);
+ fflush (stderr);
+ Microcode_Termination (TERM_EXIT);
+ }
}
if (Primitive_Debug)
- {
- Print_Expression(Result, "Primitive Result");
- fprintf(stderr, "\n");
- }
- return (Result);
+ {
+ Print_Expression (result, "Primitive Result");
+ putc ('\n', stderr);
+ fflush (stderr);
+ }
+ return (result);
}
#endif /* ENABLE_DEBUGGING_TOOLS */
Store_Return(RC_RESTORE_INT_MASK);
Store_Expression(LONG_TO_FIXNUM(FETCH_INTERRUPT_MASK()));
Save_Cont();
- Push(LONG_TO_UNSIGNED_FIXNUM((Distance - Merge_Depth)));
- Push(Target);
- Push(LONG_TO_UNSIGNED_FIXNUM((From_Depth - Merge_Depth)));
- Push(Current_Location);
+ STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM((Distance - Merge_Depth)));
+ STACK_PUSH (Target);
+ STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM((From_Depth - Merge_Depth)));
+ STACK_PUSH (Current_Location);
Store_Expression(State_Space);
Store_Return(RC_MOVE_TO_ADJACENT_POINT);
Save_Cont();
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/version.h,v 11.31 1990/05/16 22:42:55 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/version.h,v 11.32 1990/06/20 17:42:34 cph Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
#define VERSION 11
#endif
#ifndef SUBVERSION
-#define SUBVERSION 31
+#define SUBVERSION 32
#endif
#ifndef UCODE_TABLES_FILENAME
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/x11term.c,v 1.7 1989/11/11 19:13:10 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/x11term.c,v 1.8 1990/06/20 17:42:39 cph Exp $
-Copyright (c) 1989 Massachusetts Institute of Technology
+Copyright (c) 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
xterm_process_event (& event);
continue;
}
- status = ((int *) 0);
+ status = 0;
nbytes =
- (XLookupString ((& event),
+ (XLookupString (((XKeyEvent *) (&event)),
(& (copy_buffer [0])),
(sizeof (copy_buffer)),
- (& keysym),
- status));
+ (&keysym),
+ ((XComposeStatus *) status)));
if ((IsFunctionKey (keysym)) ||
(IsCursorKey (keysym)) ||
(IsKeypadKey (keysym)) ||
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/xdebug.c,v 9.26 1989/09/20 23:13:32 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/xdebug.c,v 9.27 1990/06/20 17:42:45 cph Rel $
Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
PRIMITIVE_RETURN (UNSPECIFIC);
}
\f
-/* Primitives to give scheme a handle on utilities on this file. */
+/* Primitives to give scheme a handle on utilities in this file. */
-DEFINE_PRIMITIVE ("DEBUG-FLAGS", Prim_debug_flags, 0, 0, 0)
+DEFINE_PRIMITIVE ("DEBUG-EDIT-FLAGS", Prim_debug_edit_flags, 0, 0, 0)
{
PRIMITIVE_HEADER (0);
-
- Handle_Debug_Flags ();
+ debug_edit_flags ();
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("DEBUG-FIND-WHO-POINTS", Prim_debug_find_who_points, 3, 3, 0)
{
PRIMITIVE_HEADER (3);
-
PRIMITIVE_RETURN
(Find_Who_Points
((ARG_REF (1)),
{
SCHEME_OBJECT object;
PRIMITIVE_HEADER (2);
-
object = (ARG_REF (1));
Print_Memory
(((GC_Type_Non_Pointer (object))
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/zones.h,v 9.23 1988/08/15 20:58:52 cph Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/zones.h,v 9.24 1990/06/20 17:42:58 cph Rel $
*
* Metering stuff.
* We break all times into time zones suitable for external analysis.
extern long New_Time, Old_Time, Time_Meters[], Current_Zone;
#ifdef ENABLE_DEBUGGING_TOOLS
-#define Set_Time_Zone(Zone) \
-{ New_Time = Sys_Clock();\
- Time_Meters[Current_Zone] += New_Time-Old_Time;\
- Old_Time = New_Time;\
- Current_Zone = Zone;\
+#define Set_Time_Zone(Zone) \
+{ \
+ New_Time = (OS_process_clock ()); \
+ Time_Meters[Current_Zone] += New_Time-Old_Time; \
+ Old_Time = New_Time; \
+ Current_Zone = Zone; \
}
#else
#define Set_Time_Zone(Zone) Current_Zone = Zone;
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/cmpint.c,v 1.27 1990/04/23 02:35:00 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/cmpint.c,v 1.28 1990/06/20 17:38:59 cph Exp $
Copyright (c) 1989, 1990 Massachusetts Institute of Technology
/* Macro imports */
-#include <setjmp.h>
#include <stdio.h>
+#include "oscond.h" /* Identify the operating system */
+#include "ansidecl.h" /* Macros to support ANSI declarations */
+#include "dstack.h" /* Dynamic-stack support */
#include "config.h" /* SCHEME_OBJECT type and machine dependencies */
#include "types.h" /* Needed by const.h */
#include "const.h" /* REGBLOCK_MINIMUM_LENGTH and PRIM_... codes */
#include "fixobj.h" /* To find the error handlers */
#include "stack.h" /* Stacks and stacklets */
#include "interp.h" /* Interpreter state and primitive destructuring */
-#include "default.h" /* Metering_Apply_Primitive */
+#include "default.h" /* various definitions */
#include "extern.h" /* External decls (missing Cont_Debug, etc.) */
#include "trap.h" /* UNASSIGNED_OBJECT, TRAP_EXTENSION_TYPE */
#include "prims.h" /* LEXPR */
\f
/* Imports from the rest of the "microcode" */
-extern term_type
- Microcode_Termination();
-
extern long
compiler_cache_operator(),
compiler_cache_lookup(),
*local_free = EMPTY_LIST;
return (PRIM_DONE);
}
-\f
else /* (delta > 0) */
{
/* The number of arguments passed is greater than the number of
SCHEME_OBJECT primitive;
long ignore_2, ignore_3, ignore_4;
{
- Metering_Apply_Primitive (Val, primitive);
- Pop_Primitive_Frame (PRIMITIVE_ARITY (primitive));
+ PRIMITIVE_APPLY (Val, primitive);
+ POP_PRIMITIVE_FRAME (PRIMITIVE_ARITY (primitive));
RETURN_TO_SCHEME (OBJECT_ADDRESS (STACK_POP ()));
}
SCHEME_OBJECT primitive;
long ignore_2, ignore_3, ignore_4;
{
- Metering_Apply_Primitive (Val, primitive);
- Pop_Primitive_Frame (((long) Regs[REGBLOCK_LEXPR_ACTUALS]));
+ PRIMITIVE_APPLY (Val, primitive);
+ POP_PRIMITIVE_FRAME (((long) Regs[REGBLOCK_LEXPR_ACTUALS]));
RETURN_TO_SCHEME (OBJECT_ADDRESS (STACK_POP ()));
}
\f
nactuals += 1;
goto callee_is_compiled;
}
-\f
case TC_PRIMITIVE:
{
/* This code depends on the fact that unimplemented
block_address[last_header_offset] =
(MAKE_LINKAGE_SECTION_HEADER (kind, total_count));
-\f
for (offset += 1; ((--count) >= 0); offset += entry_size)
{
SCHEME_OBJECT name;
{
return (comutil_apply (true_operator, nargs, 0, 0));
}
-\f
else /* Error or interrupt */
{
SCHEME_OBJECT trampoline, environment, name;
/* Discard name, env. and nargs */
- Stack_Pointer = (Simulate_Popping (3));
+ Stack_Pointer = (STACK_LOC (3));
old_trampoline = (OBJECT_ADDRESS (STACK_POP ()));
code_block = ((TRAMPOLINE_STORAGE (old_trampoline))[1]);
offset = (OBJECT_DATUM ((TRAMPOLINE_STORAGE (old_trampoline))[2]));
{
kind = KIND_ILLEGAL;
}
-\f
else
{
switch (((unsigned long) max_arity) & 0xff)
return (PRIM_DONE);
}
nmin = (COMPILED_ENTRY_MINIMUM_ARITY (entry));
-\f
if ((nmax > 1) && (nmin > 0) && (nmin <= nactuals) &&
(nactuals <= TRAMPOLINE_TABLE_SIZE) &&
(nmax <= (TRAMPOLINE_TABLE_SIZE + 1)))
extern void
store_variable_cache(),
- compiled_entry_type(),
- Microcode_Termination();
+ compiled_entry_type();
\f
SCHEME_OBJECT
Registers[REGBLOCK_MINIMUM_LENGTH],
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/const.h,v 9.35 1989/09/20 23:07:12 cph Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/const.h,v 9.36 1990/06/20 17:39:29 cph Rel $
*
* Named constants used throughout the interpreter
*
#endif /* SHARP_F */
#define EMPTY_LIST SHARP_F
-#define NOT_THERE -1 /* Command line parser */
\f
/* Assorted sizes used in various places */
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/fasl.h,v 9.30 1989/09/20 23:07:58 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/fasl.h,v 9.31 1990/06/20 17:40:19 cph Exp $
Copyright (c) 1987, 1988, 1989 Massachusetts Institute of Technology
The machine/opsys information is contained in config.h
The processor and compiled code version information is
contained in the appropriate cmp* file, or compiler.c */
-
-extern long Load_Data(), Write_Data();
-extern Boolean Open_Dump_File(), Close_Dump_File();
\f
/* FASL Version */
MAKE_OBJECT (((Band_p) ? TC_TRUE : TC_NULL), \
(((Version) << (DATUM_LENGTH / 2)) | \
(Processor_Type)))
-
-#define WRITE_FLAG 1
-#define OPEN_FLAG 0
\f
/* "Memorable" FASL versions -- ones where we modified something
and want to remain backwards compatible.
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/interp.c,v 9.55 1990/01/30 14:44:25 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/interp.c,v 9.56 1990/06/20 17:41:10 cph Exp $
-Copyright (c) 1988, 1989 Massachusetts Institute of Technology
+Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
#include "history.h"
#include "cmpint.h"
#include "zones.h"
+
+extern PTR EXFUN (obstack_chunk_alloc, (unsigned int size));
+extern void EXFUN (free, (PTR ptr));
+#define obstack_chunk_free free
\f
/* In order to make the interpreter tail recursive (i.e.
* to avoid calling procedures and thus saving unnecessary
#define Prepare_Eval_Repeat() \
{ \
Will_Push(CONTINUATION_SIZE+1); \
- Push(Fetch_Env()); \
+ STACK_PUSH (Fetch_Env()); \
Store_Return(RC_EVAL_ERROR); \
Save_Cont(); \
Pushed(); \
{ \
fast SCHEME_OBJECT *Arg, Orig_Arg; \
\
- Arg = &(Stack_Ref((Arg_No - 1) + STACK_ENV_FIRST_ARG)); \
+ Arg = &(STACK_REF((Arg_No - 1) + STACK_ENV_FIRST_ARG)); \
Orig_Arg = *Arg; \
\
if (OBJECT_TYPE (*Arg) != TC_FUTURE) \
Store_Return(RC_RESTORE_VALUE); \
Store_Expression(Orig_Val); \
Save_Cont(); \
- Push(Val); \
- Push(Get_Fixed_Obj_Slot(System_Scheduler)); \
- Push(STACK_FRAME_HEADER + 1); \
+ STACK_PUSH (Val); \
+ STACK_PUSH (Get_Fixed_Obj_Slot(System_Scheduler)); \
+ STACK_PUSH (STACK_FRAME_HEADER + 1); \
Pushed(); \
goto Internal_Apply; \
} \
{ \
Save_Cont(); \
Will_Push(CONTINUATION_SIZE + 2); \
- Push(Val); \
+ STACK_PUSH (Val); \
Save_Env(); \
Store_Return(RC_REPEAT_DISPATCH); \
Store_Expression(LONG_TO_FIXNUM(CODE_MAP(Which_Way))); \
The EVAL/APPLY ying/yang
*/
+static PTR interpreter_catch_dstack_position;
+static jmp_buf interpreter_catch_env;
+static int interpreter_throw_argument;
+
+void
+DEFUN (abort_to_interpreter, (argument), int argument)
+{
+ interpreter_throw_argument = argument;
+ dstack_set_position (interpreter_catch_dstack_position);
+ obstack_free ((&scratch_obstack), 0);
+ obstack_init (&scratch_obstack);
+ longjmp (interpreter_catch_env, argument);
+}
+
+int
+DEFUN_VOID (abort_to_interpreter_argument)
+{
+ return (interpreter_throw_argument);
+}
+
void
Interpret(dumped_p)
Boolean dumped_p;
* for operation.
*/
- Which_Way = setjmp(*Back_To_Eval);
- Set_Time_Zone(Zone_Working);
- Import_Registers();
+ interpreter_catch_dstack_position = dstack_position;
+ Which_Way = (setjmp (interpreter_catch_env));
+ Set_Time_Zone (Zone_Working);
+ Import_Registers ();
\f
Repeat_Dispatch:
switch (Which_Way)
{
Stop_Trapping ();
Will_Push (4);
- Push (Fetch_Env ());
- Push (Fetch_Expression ());
- Push (Fetch_Eval_Trapper ());
- Push (STACK_FRAME_HEADER + 2);
+ STACK_PUSH (Fetch_Env ());
+ STACK_PUSH (Fetch_Expression ());
+ STACK_PUSH (Fetch_Eval_Trapper ());
+ STACK_PUSH (STACK_FRAME_HEADER + 2);
Pushed ();
goto Apply_Non_Trapping;
}
Eval_GC_Check(New_Stacklet_Size(Array_Length + 1 + 1 + CONTINUATION_SIZE));
#endif /* USE_STACKLETS */
Will_Push(Array_Length + 1 + 1 + CONTINUATION_SIZE);
- Stack_Pointer = Simulate_Pushing(Array_Length);
- Push(MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, Array_Length));
+ Stack_Pointer = (STACK_LOC (- Array_Length));
+ STACK_PUSH (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, Array_Length));
/* The finger: last argument number */
Pushed();
if (Array_Length == 0)
{
- Push(STACK_FRAME_HEADER); /* Frame size */
+ STACK_PUSH (STACK_FRAME_HEADER); /* Frame size */
Do_Nth_Then(RC_COMB_APPLY_FUNCTION, COMB_FN_SLOT, {});
}
Save_Env();
}
Prepare_Eval_Repeat();
Will_Push(STACK_ENV_EXTRA_SLOTS+2);
- Push(Fetch_Expression()); /* Arg: FUTURE object */
- Push(Get_Fixed_Obj_Slot(System_Scheduler));
- Push(STACK_FRAME_HEADER+1);
+ STACK_PUSH (Fetch_Expression()); /* Arg: FUTURE object */
+ STACK_PUSH (Get_Fixed_Obj_Slot(System_Scheduler));
+ STACK_PUSH (STACK_FRAME_HEADER+1);
Pushed();
goto Internal_Apply;
#endif
Restore_Cont();
if (Consistency_Check &&
(OBJECT_TYPE (Fetch_Return()) != TC_RETURN_CODE))
- { Push(Val); /* For possible stack trace */
+ { STACK_PUSH (Val); /* For possible stack trace */
Save_Cont();
Export_Registers();
Microcode_Termination(TERM_BAD_STACK);
{
case RC_COMB_1_PROCEDURE:
Restore_Env();
- Push(Val); /* Arg. 1 */
- Push(SHARP_F); /* Operator */
- Push(STACK_FRAME_HEADER + 1);
+ STACK_PUSH (Val); /* Arg. 1 */
+ STACK_PUSH (SHARP_F); /* Operator */
+ STACK_PUSH (STACK_FRAME_HEADER + 1);
Finished_Eventual_Pushing(CONTINUATION_SIZE);
Do_Another_Then(RC_COMB_APPLY_FUNCTION, COMB_1_FN);
case RC_COMB_2_FIRST_OPERAND:
Restore_Env();
- Push(Val);
+ STACK_PUSH (Val);
Save_Env();
Do_Another_Then(RC_COMB_2_PROCEDURE, COMB_2_ARG_1);
case RC_COMB_2_PROCEDURE:
Restore_Env();
- Push(Val); /* Arg 1, just calculated */
- Push(SHARP_F); /* Function */
- Push(STACK_FRAME_HEADER + 2);
+ STACK_PUSH (Val); /* Arg 1, just calculated */
+ STACK_PUSH (SHARP_F); /* Function */
+ STACK_PUSH (STACK_FRAME_HEADER + 2);
Finished_Eventual_Pushing(CONTINUATION_SIZE);
Do_Another_Then(RC_COMB_APPLY_FUNCTION, COMB_2_FN);
{ long Arg_Number;
Restore_Env();
- Arg_Number = OBJECT_DATUM (Stack_Ref(STACK_COMB_FINGER))-1;
- Stack_Ref(STACK_COMB_FIRST_ARG+Arg_Number) = Val;
- Stack_Ref(STACK_COMB_FINGER) =
+ Arg_Number = OBJECT_DATUM (STACK_REF(STACK_COMB_FINGER))-1;
+ STACK_REF(STACK_COMB_FIRST_ARG+Arg_Number) = Val;
+ STACK_REF(STACK_COMB_FINGER) =
MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, Arg_Number);
/* DO NOT count on the type code being NMVector here, since
the stack parser may create them with #F here! */
Do_Another_Then(RC_COMB_SAVE_VALUE,
(COMB_ARG_1_SLOT - 1) + Arg_Number);
}
- Push(FAST_MEMORY_REF (Fetch_Expression(), 0)); /* Frame Size */
+ STACK_PUSH (FAST_MEMORY_REF (Fetch_Expression(), 0)); /* Frame Size */
Do_Another_Then(RC_COMB_APPLY_FUNCTION, COMB_FN_SLOT);
}
case RC_END_OF_COMPUTATION:
/* Signals bottom of stack */
Export_Registers();
- Microcode_Termination(TERM_END_OF_COMPUTATION);
+ termination_end_of_computation ();
case RC_EVAL_ERROR:
/* Should be called RC_REDO_EVALUATION. */
- Store_Env(Pop());
+ Store_Env(STACK_POP ());
Reduces_To(Fetch_Expression());
\f
case RC_EXECUTE_ACCESS_FINISH:
((handler = (Get_Fixed_Obj_Slot(Trap_Handler))) == SHARP_F))
{
fprintf(stderr, "There is no trap handler for recovery!\n");
- Microcode_Termination(TERM_TRAP);
+ termination_trap ();
/*NOTREACHED*/
}
Will_Push(STACK_ENV_EXTRA_SLOTS + 2);
- Push(info);
- Push(handler);
- Push(STACK_FRAME_HEADER + 1);
+ STACK_PUSH (info);
+ STACK_PUSH (handler);
+ STACK_PUSH (STACK_FRAME_HEADER + 1);
Pushed();
goto Internal_Apply;
}
{ \
Store_Expression (SHARP_F); \
Prepare_Pop_Return_Interrupt (RC_INTERNAL_APPLY_VAL, \
- (Stack_Ref (STACK_ENV_FUNCTION))); \
+ (STACK_REF (STACK_ENV_FUNCTION))); \
}
#define Apply_Error(N) \
{ \
Store_Expression (SHARP_F); \
Store_Return (RC_INTERNAL_APPLY_VAL); \
- Val = (Stack_Ref (STACK_ENV_FUNCTION)); \
+ Val = (STACK_REF (STACK_ENV_FUNCTION)); \
Pop_Return_Error (N); \
}
case RC_INTERNAL_APPLY_VAL:
Internal_Apply_Val:
- Stack_Ref (STACK_ENV_FUNCTION) = Val;
+ STACK_REF (STACK_ENV_FUNCTION) = Val;
case RC_INTERNAL_APPLY:
Internal_Apply:
{
long Count;
- Count = (OBJECT_DATUM (Stack_Ref (STACK_ENV_HEADER)));
- Top_Of_Stack() = (Fetch_Apply_Trapper ());
- Push (STACK_FRAME_HEADER + Count);
+ Count = (OBJECT_DATUM (STACK_REF (STACK_ENV_HEADER)));
+ (* (STACK_LOC (0))) = (Fetch_Apply_Trapper ());
+ STACK_PUSH (STACK_FRAME_HEADER + Count);
Stop_Trapping ();
}
{
fast SCHEME_OBJECT Function;
- Apply_Future_Check(Function, Stack_Ref(STACK_ENV_FUNCTION));
+ Apply_Future_Check(Function, STACK_REF(STACK_ENV_FUNCTION));
switch(OBJECT_TYPE (Function))
{
of everything, including type code, etc.
*/
- nargs = Pop();
- Push(FAST_MEMORY_REF (Function, ENTITY_OPERATOR));
- Push(nargs + 1);
+ nargs = (STACK_POP ());
+ STACK_PUSH (FAST_MEMORY_REF (Function, ENTITY_OPERATOR));
+ STACK_PUSH (nargs + 1);
/* This must be done to prevent an infinite push loop by
an entity whose handler is the entity itself or some
other such loop. Of course, it will die if stack overflow
{
fast long nargs;
- nargs = OBJECT_DATUM (Pop());
+ nargs = OBJECT_DATUM (STACK_POP ());
Function = FAST_MEMORY_REF (Function, PROCEDURE_LAMBDA_EXPR);
{
((OBJECT_TYPE (Function) != TC_LEXPR) ||
(nargs < VECTOR_LENGTH (formals))))
{
- Push(STACK_FRAME_HEADER + nargs - 1);
+ STACK_PUSH (STACK_FRAME_HEADER + nargs - 1);
Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
}
}
if (GC_Check(nargs + 1))
{
- Push(STACK_FRAME_HEADER + nargs - 1);
+ STACK_PUSH (STACK_FRAME_HEADER + nargs - 1);
Prepare_Apply_Interrupt ();
Immediate_GC(nargs + 1);
}
Store_Env(MAKE_POINTER_OBJECT (TC_ENVIRONMENT, scan));
*scan++ = MAKE_OBJECT (TC_MANIFEST_VECTOR, nargs);
while(--nargs >= 0)
- *scan++ = Pop();
+ *scan++ = (STACK_POP ());
Free = scan;
Reduces_To(FAST_MEMORY_REF (Function, LAMBDA_SCODE));
}
case TC_CONTROL_POINT:
{
- if (OBJECT_DATUM (Stack_Ref (STACK_ENV_HEADER)) !=
+ if (OBJECT_DATUM (STACK_REF (STACK_ENV_HEADER)) !=
STACK_ENV_FIRST_ARG)
{
Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
}
- Val = (Stack_Ref (STACK_ENV_FIRST_ARG));
+ Val = (STACK_REF (STACK_ENV_FIRST_ARG));
Our_Throw(false, Function);
Apply_Stacklet_Backout();
Our_Throw_Part_2();
/* Note that the first test below will fail for lexpr primitives. */
- nargs = ((OBJECT_DATUM (Stack_Ref(STACK_ENV_HEADER))) -
+ nargs = ((OBJECT_DATUM (STACK_REF(STACK_ENV_HEADER))) -
(STACK_ENV_FIRST_ARG - 1));
if (nargs != PRIMITIVE_ARITY(Function))
{
Regs[REGBLOCK_LEXPR_ACTUALS] = ((SCHEME_OBJECT) nargs);
}
- Stack_Pointer = Simulate_Popping(STACK_ENV_FIRST_ARG);
- Store_Expression(Function);
-
- Export_Regs_Before_Primitive();
- Metering_Apply_Primitive(Val, Function);
- Import_Regs_After_Primitive();
-
- Pop_Primitive_Frame(nargs);
+ Stack_Pointer = (STACK_LOC (STACK_ENV_FIRST_ARG));
+ Store_Expression (Function);
+ EXPORT_REGS_BEFORE_PRIMITIVE ();
+ PRIMITIVE_APPLY (Val, Function);
+ IMPORT_REGS_AFTER_PRIMITIVE ();
+ POP_PRIMITIVE_FRAME (nargs);
if (Must_Report_References())
{
Store_Expression(Val);
fast long i;
fast SCHEME_OBJECT *scan;
- nargs = OBJECT_DATUM (Pop()) - STACK_FRAME_HEADER;
+ nargs = OBJECT_DATUM (STACK_POP ()) - STACK_FRAME_HEADER;
if (Eval_Debug)
{
if ((nargs < formals) || (!rest_flag && (nargs > params)))
{
- Push(STACK_FRAME_HEADER + nargs);
+ STACK_PUSH (STACK_FRAME_HEADER + nargs);
Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
}
(2 * (nargs - params)) :
0)))
{
- Push(STACK_FRAME_HEADER + nargs);
+ STACK_PUSH (STACK_FRAME_HEADER + nargs);
Prepare_Apply_Interrupt ();
Immediate_GC(size + 1 + ((nargs > params) ?
(2 * (nargs - params)) :
if (nargs <= params)
{
for (i = (nargs + 1); --i >= 0; )
- *scan++ = Pop();
+ *scan++ = (STACK_POP ());
for (i = (params - nargs); --i >= 0; )
*scan++ = UNASSIGNED_OBJECT;
if (rest_flag)
list = MAKE_POINTER_OBJECT (TC_LIST, (scan + size));
for (i = (params + 1); --i >= 0; )
- *scan++ = Pop();
+ *scan++ = (STACK_POP ());
*scan++ = list;
for (i = auxes; --i >= 0; )
*scan++ = UNASSIGNED_OBJECT;
/* Now scan == OBJECT_ADDRESS (list) */
for (i = (nargs - params); --i >= 0; )
{
- *scan++ = Pop();
+ *scan++ = (STACK_POP ());
*scan = MAKE_POINTER_OBJECT (TC_LIST, (scan + 1));
scan += 1;
}
case TC_COMPILED_ENTRY:
{
apply_compiled_setup(STACK_ENV_EXTRA_SLOTS +
- OBJECT_DATUM (Stack_Ref (STACK_ENV_HEADER)));
+ OBJECT_DATUM (STACK_REF (STACK_ENV_HEADER)));
Export_Registers();
Which_Way = apply_compiled_procedure();
{
compiler_apply_procedure
(STACK_ENV_EXTRA_SLOTS +
- OBJECT_DATUM (Stack_Ref (STACK_ENV_HEADER)));
+ OBJECT_DATUM (STACK_REF (STACK_ENV_HEADER)));
goto Internal_Apply;
}
SCHEME_OBJECT Thunk, New_Location;
From_Count =
- (UNSIGNED_FIXNUM_TO_LONG (Stack_Ref (TRANSLATE_FROM_DISTANCE)));
+ (UNSIGNED_FIXNUM_TO_LONG (STACK_REF (TRANSLATE_FROM_DISTANCE)));
if (From_Count != 0)
- { SCHEME_OBJECT Current = Stack_Ref(TRANSLATE_FROM_POINT);
- Stack_Ref(TRANSLATE_FROM_DISTANCE) =
+ { SCHEME_OBJECT Current = STACK_REF(TRANSLATE_FROM_POINT);
+ STACK_REF(TRANSLATE_FROM_DISTANCE) =
(LONG_TO_UNSIGNED_FIXNUM (From_Count - 1));
Thunk = FAST_MEMORY_REF (Current, STATE_POINT_AFTER_THUNK);
New_Location = FAST_MEMORY_REF (Current, STATE_POINT_NEARER_POINT);
- Stack_Ref(TRANSLATE_FROM_POINT) = New_Location;
+ STACK_REF(TRANSLATE_FROM_POINT) = New_Location;
if ((From_Count == 1) &&
- (Stack_Ref(TRANSLATE_TO_DISTANCE) == LONG_TO_UNSIGNED_FIXNUM(0)))
- Stack_Pointer = Simulate_Popping(4);
+ (STACK_REF(TRANSLATE_TO_DISTANCE) == LONG_TO_UNSIGNED_FIXNUM(0)))
+ Stack_Pointer = (STACK_LOC (4));
else Save_Cont();
}
else
fast long i;
To_Count =
- (UNSIGNED_FIXNUM_TO_LONG (Stack_Ref (TRANSLATE_TO_DISTANCE)) - 1);
- To_Location = Stack_Ref(TRANSLATE_TO_POINT);
+ (UNSIGNED_FIXNUM_TO_LONG (STACK_REF (TRANSLATE_TO_DISTANCE)) - 1);
+ To_Location = STACK_REF(TRANSLATE_TO_POINT);
for (i = 0; i < To_Count; i++)
{
To_Location =
}
Thunk = FAST_MEMORY_REF (To_Location, STATE_POINT_BEFORE_THUNK);
New_Location = To_Location;
- Stack_Ref(TRANSLATE_TO_DISTANCE) = LONG_TO_UNSIGNED_FIXNUM(To_Count);
+ STACK_REF(TRANSLATE_TO_DISTANCE) = LONG_TO_UNSIGNED_FIXNUM(To_Count);
if (To_Count == 0)
{
- Stack_Pointer = Simulate_Popping(4);
+ Stack_Pointer = (STACK_LOC (4));
}
else
{
Current_State_Point = New_Location;
}
Will_Push(2);
- Push(Thunk);
- Push(STACK_FRAME_HEADER);
+ STACK_PUSH (Thunk);
+ STACK_PUSH (STACK_FRAME_HEADER);
Pushed();
goto Internal_Apply;
}
case RC_INVOKE_STACK_THREAD:
/* Used for WITH_THREADED_STACK primitive */
Will_Push(3);
- Push(Val); /* Value calculated by thunk */
- Push(Fetch_Expression());
- Push(STACK_FRAME_HEADER+1);
+ STACK_PUSH (Val); /* Value calculated by thunk */
+ STACK_PUSH (Fetch_Expression());
+ STACK_PUSH (STACK_FRAME_HEADER+1);
Pushed();
goto Internal_Apply;
GC_Space_Needed = 0;
}
if (GC_Check(GC_Space_Needed))
- {
- Microcode_Termination(TERM_GC_OUT_OF_SPACE);
- }
+ termination_gc_out_of_space ();
GC_Space_Needed = 0;
EXIT_CRITICAL_SECTION ({ Save_Cont(); Export_Registers(); });
End_GC_Hook();
\f
case RC_PCOMB1_APPLY:
End_Subproblem();
- Push(Val); /* Argument value */
+ STACK_PUSH (Val); /* Argument value */
Finished_Eventual_Pushing(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG);
Store_Expression(FAST_MEMORY_REF (Fetch_Expression(), PCOMB1_FN_SLOT));
We may have a non-contiguous frame. -- Jinx
*/
Will_Push(3);
- Push(Fetch_Expression());
- Push(Fetch_Apply_Trapper());
- Push(STACK_FRAME_HEADER + 1 +
+ STACK_PUSH (Fetch_Expression());
+ STACK_PUSH (Fetch_Apply_Trapper());
+ STACK_PUSH (STACK_FRAME_HEADER + 1 +
PRIMITIVE_N_PARAMETERS(Fetch_Expression()));
Pushed();
Stop_Trapping();
*/
{
- fast SCHEME_OBJECT primitive;
-
- primitive = Fetch_Expression();
- Export_Regs_Before_Primitive();
- Metering_Apply_Primitive(Val, primitive);
- Import_Regs_After_Primitive();
-
- Pop_Primitive_Frame(PRIMITIVE_ARITY(primitive));
- if (Must_Report_References())
- {
- Store_Expression(Val);
- Store_Return(RC_RESTORE_VALUE);
- Save_Cont();
- Call_Future_Logging();
- }
+ fast SCHEME_OBJECT primitive = (Fetch_Expression ());
+ EXPORT_REGS_BEFORE_PRIMITIVE ();
+ PRIMITIVE_APPLY (Val, primitive);
+ IMPORT_REGS_AFTER_PRIMITIVE ();
+ POP_PRIMITIVE_FRAME (PRIMITIVE_ARITY (primitive));
+ if (Must_Report_References ())
+ {
+ Store_Expression (Val);
+ Store_Return (RC_RESTORE_VALUE);
+ Save_Cont ();
+ Call_Future_Logging ();
+ }
break;
}
\f
case RC_PCOMB2_APPLY:
End_Subproblem();
- Push(Val); /* Value of arg. 1 */
+ STACK_PUSH (Val); /* Value of arg. 1 */
Finished_Eventual_Pushing(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG);
Store_Expression(FAST_MEMORY_REF (Fetch_Expression(), PCOMB2_FN_SLOT));
goto Primitive_Internal_Apply;
case RC_PCOMB2_DO_1:
Restore_Env();
- Push(Val); /* Save value of arg. 2 */
+ STACK_PUSH (Val); /* Save value of arg. 2 */
Do_Another_Then(RC_PCOMB2_APPLY, PCOMB2_ARG_1_SLOT);
case RC_PCOMB3_APPLY:
End_Subproblem();
- Push(Val); /* Save value of arg. 1 */
+ STACK_PUSH (Val); /* Save value of arg. 1 */
Finished_Eventual_Pushing(CONTINUATION_SIZE + STACK_ENV_FIRST_ARG);
Store_Expression(FAST_MEMORY_REF (Fetch_Expression(), PCOMB3_FN_SLOT));
goto Primitive_Internal_Apply;
{
SCHEME_OBJECT Temp;
- Temp = Pop(); /* Value of arg. 3 */
+ Temp = (STACK_POP ()); /* Value of arg. 3 */
Restore_Env();
- Push(Temp); /* Save arg. 3 again */
- Push(Val); /* Save arg. 2 */
+ STACK_PUSH (Temp); /* Save arg. 3 again */
+ STACK_PUSH (Val); /* Save arg. 2 */
Do_Another_Then(RC_PCOMB3_APPLY, PCOMB3_ARG_1_SLOT);
}
case RC_PCOMB3_DO_2:
Restore_Then_Save_Env();
- Push(Val); /* Save value of arg. 3 */
+ STACK_PUSH (Val); /* Save value of arg. 3 */
Do_Another_Then(RC_PCOMB3_DO_1, PCOMB3_ARG_2_SLOT);
case RC_POP_RETURN_ERROR:
Store_Return(RC_PURIFY_GC_2);
Save_Cont();
Will_Push(2);
- Push(GC_Daemon_Proc);
- Push(STACK_FRAME_HEADER);
+ STACK_PUSH (GC_Daemon_Proc);
+ STACK_PUSH (STACK_FRAME_HEADER);
Pushed();
goto Internal_Apply;
}
case RC_REPEAT_DISPATCH:
Which_Way = (FIXNUM_TO_LONG (Fetch_Expression ()));
Restore_Env();
- Val = Pop();
+ Val = (STACK_POP ());
Restore_Cont();
goto Repeat_Dispatch;
{
SCHEME_OBJECT Stacklet;
- Prev_Restore_History_Offset = OBJECT_DATUM (Pop());
- Stacklet = Pop();
+ Prev_Restore_History_Offset = OBJECT_DATUM (STACK_POP ());
+ Stacklet = (STACK_POP ());
History = OBJECT_ADDRESS (Fetch_Expression());
if (Prev_Restore_History_Offset == 0)
{
Immediate_GC((Free > MemTop) ? 0 : ((MemTop-Free)+1));
}
Import_Registers();
- Prev_Restore_History_Offset = OBJECT_DATUM (Pop());
- Stacklet = Pop();
+ Prev_Restore_History_Offset = OBJECT_DATUM (STACK_POP ());
+ Stacklet = (STACK_POP ());
if (Prev_Restore_History_Offset == 0)
Prev_Restore_History_Stacklet = NULL;
else
Save_Cont();
Return_Hook_Address = NULL;
Stop_Trapping();
- Push(Val);
- Push(Fetch_Return_Trapper());
- Push(STACK_FRAME_HEADER+1);
+ STACK_PUSH (Val);
+ STACK_PUSH (Fetch_Return_Trapper());
+ STACK_PUSH (STACK_FRAME_HEADER+1);
Pushed();
goto Apply_Non_Trapping;
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/mul.c,v 9.28 1990/02/08 00:39:02 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/mul.c,v 9.29 1990/06/20 17:41:36 cph Exp $
Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
#if (TYPE_CODE_LENGTH == 8)
-#if defined(vax) && defined(bsd)
+#if defined(vax) && defined(_BSD)
#define MUL_HANDLED
: SHARP_F);
}
-#endif /* vax+bsd */
+#endif /* vax and _BSD */
\f
-/* 68k family code. Uses hp9000s200 conventions for the new compiler. */
+/* 68k family code. Uses hp9000s300 conventions for the new compiler. */
-#if defined(hp9000s200) && !defined(old_cc) && !defined(__GNUC__)
+#if defined(hp9000s300) && !defined(old_cc) && !defined(__GNUC__)
#define MUL_HANDLED
/* The following constants are hard coded in the assembly language
asm(" data");
#endif /* not MC68020 */
-#endif /* hp9000s200 */
+#endif /* hp9000s300 */
\f
#endif /* (TYPE_CODE_LENGTH == 8) */
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/ppband.c,v 9.37 1990/04/17 21:55:47 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/ppband.c,v 9.38 1990/06/20 17:37:59 cph Exp $
-Copyright (c) 1987, 1989 Massachusetts Institute of Technology
+Copyright (c) 1987, 1989, 1990 Massachusetts Institute of Technology
This material was developed by the Scheme project at the Massachusetts
Institute of Technology, Department of Electrical Engineering and
#include "sdata.h"
#define fast register
-\f
+
/* These are needed by load.c */
static SCHEME_OBJECT * memory_base;
return (fread (To_Where, (sizeof (SCHEME_OBJECT)), Count, stdin));
}
-long
-Write_Data()
-{
- fprintf(stderr, "Write_Data called\n");
- exit(1);
-}
-
-Boolean
-Open_Dump_File()
-{
- fprintf(stderr, "Open_Dump_File called\n");
- exit(1);
-}
-
-Boolean
-Close_Dump_File()
-{
- fprintf(stderr, "Close_Dump_File called\n");
- exit(1);
-}
-\f
#define INHIBIT_COMPILED_VERSION_CHECK
#include "load.c"
-
+\f
#ifdef HEAP_IN_LOW_MEMORY
-#ifdef spectrum
+#ifdef hp9000s800
#define File_To_Pointer(P) \
((((long) (P)) & DATUM_MASK) / sizeof(SCHEME_OBJECT))
#else
#define File_To_Pointer(P) ((P) / sizeof(SCHEME_OBJECT))
-#endif /* spectrum */
+#endif /* hp9000s800 */
#else
#define File_To_Pointer(P) (P)
#endif
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/version.h,v 11.31 1990/05/16 22:42:55 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/version.h,v 11.32 1990/06/20 17:42:34 cph Exp $
Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology
#define VERSION 11
#endif
#ifndef SUBVERSION
-#define SUBVERSION 31
+#define SUBVERSION 32
#endif
#ifndef UCODE_TABLES_FILENAME
projects / mit-scheme.git / commitdiff