From e8449d2f800171b84bf141570cbb4d1b63fa2f58 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Wed, 20 Jun 1990 17:42:58 +0000 Subject: [PATCH] * Complete redesign of the operating-system interface. I/O is more uniform and is able to take advantage of things like sockets, pipes, ptys, etc. All I/O buffering is moved into the runtime system for better performance with Scheme compiler code. Strong knowledge of POSIX.1 should make porting to VMS easy once VMS supports POSIX.1. * Change operating system conditionalizations to standard form suggested by POSIX.1. * Add FSF macros to support ANSI declarations. * Add dynamic-stack package and obstacks. * Provide higher-level utilities for parsing command line options. * Instead of `Back_To_Eval', there is now a procedure `abort_to_interpreter' which knows about everything that needs to be cleaned up. * Change names of some macros: Pop STACK_POP Push STACK_PUSH Push_From STACK_LOCATIVE_PUSH Pop_Into STACK_LOCATIVE_POP (similar) Stack_Ref STACK_REF Top_Of_Stack() STACK_REF(0) Simulate_Popping STACK_LOC Simulate_Pushing STACK_LOC (similar) Stack_Distance STACK_LOCATIVE_DIFFERENCE (similar) Pop_Primitive_Frame POP_PRIMITIVE_FRAME Metering_Apply_Primitive PRIMITIVE_APPLY Export_Regs_Before_Primitive EXPORT_REGS_BEFORE_PRIMITIVE Import_Regs_After_Primitive IMPORT_REGS_AFTER_PRIMITIVE * Sun assembler can't handle a constant used in "cmpaux-mc68k.m4", so provide an option to rewrite that instruction as two instructions. * Some compilers won't cast a function to an integer, so kludge around it by mis-declaring the external function as an integer, taking it the integer's address, and casting THAT to an integer. * Move critical section code and termination code to their own files. --- v7/src/microcode/bchdmp.c | 22 +- v7/src/microcode/bchgcc.h | 5 +- v7/src/microcode/bchmmg.c | 36 +- v7/src/microcode/bchpur.c | 8 +- v7/src/microcode/bkpt.h | 68 +--- v7/src/microcode/boot.c | 624 +++++++++++------------------ v7/src/microcode/cmpauxmd/mc68k.m4 | 7 +- v7/src/microcode/cmpint.c | 30 +- v7/src/microcode/cmpint.h | 108 +++-- v7/src/microcode/cmpintmd/mc68k.h | 21 +- v7/src/microcode/config.h | 50 ++- v7/src/microcode/const.h | 3 +- v7/src/microcode/daemon.c | 40 +- v7/src/microcode/debug.c | 279 +++++++------ v7/src/microcode/default.h | 70 +--- v7/src/microcode/dmpwrld.c | 12 +- v7/src/microcode/extern.h | 90 +++-- v7/src/microcode/fasdump.c | 54 +-- v7/src/microcode/fasl.h | 8 +- v7/src/microcode/fasload.c | 352 +++++++--------- v7/src/microcode/fhooks.c | 10 +- v7/src/microcode/futures.h | 16 +- v7/src/microcode/generic.c | 6 +- v7/src/microcode/history.h | 8 +- v7/src/microcode/hooks.c | 80 ++-- v7/src/microcode/intercom.c | 39 +- v7/src/microcode/interp.c | 270 +++++++------ v7/src/microcode/interp.h | 127 +++--- v7/src/microcode/intrpt.h | 67 +--- v7/src/microcode/memmag.c | 8 +- v7/src/microcode/mul.c | 12 +- v7/src/microcode/ppband.c | 33 +- v7/src/microcode/prename.h | 41 +- v7/src/microcode/prims.h | 6 +- v7/src/microcode/purify.c | 18 +- v7/src/microcode/scheme.h | 10 +- v7/src/microcode/stack.h | 10 +- v7/src/microcode/step.c | 23 +- v7/src/microcode/storage.c | 30 +- v7/src/microcode/sysprim.c | 129 +----- v7/src/microcode/unxutl/config | 86 ++-- v7/src/microcode/unxutl/ymkfile | 155 +++++-- v7/src/microcode/utils.c | 96 +++-- v7/src/microcode/version.h | 4 +- v7/src/microcode/x11term.c | 12 +- v7/src/microcode/xdebug.c | 11 +- v7/src/microcode/zones.h | 13 +- v8/src/microcode/cmpint.c | 30 +- v8/src/microcode/const.h | 3 +- v8/src/microcode/fasl.h | 8 +- v8/src/microcode/interp.c | 270 +++++++------ v8/src/microcode/mul.c | 12 +- v8/src/microcode/ppband.c | 33 +- v8/src/microcode/version.h | 4 +- 54 files changed, 1603 insertions(+), 1964 deletions(-) diff --git a/v7/src/microcode/bchdmp.c b/v7/src/microcode/bchdmp.c index 0c357fe2e..5e1090bec 100644 --- a/v7/src/microcode/bchdmp.c +++ b/v7/src/microcode/bchdmp.c @@ -1,6 +1,6 @@ /* -*-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 @@ -38,11 +38,20 @@ MIT in each case. */ #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 @@ -727,7 +736,9 @@ DEFINE_PRIMITIVE ("DUMP-BAND", Prim_band_dump, 2, 2, 0) } 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, @@ -736,12 +747,9 @@ DEFINE_PRIMITIVE ("DUMP-BAND", Prim_band_dump, 2, 2, 0) 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; diff --git a/v7/src/microcode/bchgcc.h b/v7/src/microcode/bchgcc.h index 802f173cf..01407b497 100644 --- a/v7/src/microcode/bchgcc.h +++ b/v7/src/microcode/bchgcc.h @@ -1,6 +1,6 @@ /* -*-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 @@ -32,8 +32,9 @@ Technology nor of any adaptation thereof in any advertising, promotional, or sales literature without prior written consent from MIT in each case. */ +#include "oscond.h" #include "gccode.h" -#ifdef bsd +#ifdef _BSD #include #else #include diff --git a/v7/src/microcode/bchmmg.c b/v7/src/microcode/bchmmg.c index e3d89f5f2..c6e8eaa72 100644 --- a/v7/src/microcode/bchmmg.c +++ b/v7/src/microcode/bchmmg.c @@ -1,6 +1,6 @@ /* -*-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 @@ -121,20 +121,13 @@ open_gc_file(size) (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) @@ -158,7 +151,7 @@ open_gc_file(size) Saved_argv[0], gc_file_name); exit(1); } -#ifdef hpux +#ifdef _HPUX if (gc_file_name == gc_default_file_name) { extern prealloc(); @@ -884,16 +877,13 @@ DEFINE_PRIMITIVE ("GARBAGE-COLLECT", Prim_garbage_collect, 1, 1, 0) 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) @@ -910,8 +900,8 @@ DEFINE_PRIMITIVE ("GARBAGE-COLLECT", Prim_garbage_collect, 1, 1, 0) 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. */ diff --git a/v7/src/microcode/bchpur.c b/v7/src/microcode/bchpur.c index 75e62c4ae..bae9e075a 100644 --- a/v7/src/microcode/bchpur.c +++ b/v7/src/microcode/bchpur.c @@ -1,6 +1,6 @@ /* -*-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 @@ -511,7 +511,7 @@ DEFINE_PRIMITIVE ("PRIMITIVE-PURIFY", Prim_primitive_purify, 3, 3, 0) (*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) { @@ -525,8 +525,8 @@ DEFINE_PRIMITIVE ("PRIMITIVE-PURIFY", Prim_primitive_purify, 3, 3, 0) 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*/ diff --git a/v7/src/microcode/bkpt.h b/v7/src/microcode/bkpt.h index 936af1388..bf19932b5 100644 --- a/v7/src/microcode/bkpt.h +++ b/v7/src/microcode/bkpt.h @@ -1,8 +1,8 @@ /* -*-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 @@ -37,68 +37,38 @@ MIT in each case. */ It "shadows" definitions in default.h */ #ifdef ENABLE_DEBUGGING_TOOLS - + 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() - -/* 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 */ diff --git a/v7/src/microcode/boot.c b/v7/src/microcode/boot.c index ac26e99c1..923d4a31f 100644 --- a/v7/src/microcode/boot.c +++ b/v7/src/microcode/boot.c @@ -1,8 +1,8 @@ /* -*-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 @@ -87,189 +87,203 @@ for details. They are created by defining a macro Command_Line_Args. #include #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); } -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))); } /* 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); -} - -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; - } - + 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; + } } /* Exit is done in a different way on some operating systems (eg. VMS) */ @@ -278,29 +292,27 @@ Exit_Scheme_Declarations; 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) { @@ -308,13 +320,14 @@ main (argc, argv) 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), @@ -323,8 +336,9 @@ main (argc, argv) } 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); @@ -429,40 +443,33 @@ make_fixed_objects_vector () /* 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 (); } - -/* The initial program to execute is one of + + /* The initial program to execute is one of (SCODE-EVAL (BINARY-FASLOAD ) SYSTEM-GLOBAL-ENVIRONMENT), (LOAD-BAND ), 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 ) GLOBAL-ENV) */ @@ -503,19 +510,13 @@ Start_Scheme(Start_Prim, File_Name) /*NOTREACHED*/ } -/* Start_Scheme continues on the next page */ - -/* 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); @@ -524,14 +525,13 @@ Start_Scheme(Start_Prim, File_Name) 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*/ } @@ -539,8 +539,6 @@ Start_Scheme(Start_Prim, File_Name) 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); @@ -548,163 +546,6 @@ Enter_Interpreter() /*NOTREACHED*/ } -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*/ -} - -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; - -#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; - - 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*/ -} - /* Garbage collection debugging utilities. */ extern SCHEME_OBJECT @@ -797,52 +638,45 @@ DEFINE_PRIMITIVE ("MICROCODE-IDENTIFY", Prim_microcode_identify, 0, 0, 0) 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); + } } diff --git a/v7/src/microcode/cmpauxmd/mc68k.m4 b/v7/src/microcode/cmpauxmd/mc68k.m4 index 323c81728..fd8bb8c9e 100644 --- a/v7/src/microcode/cmpauxmd/mc68k.m4 +++ b/v7/src/microcode/cmpauxmd/mc68k.m4 @@ -1,6 +1,6 @@ ### -*-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 ### @@ -370,7 +370,10 @@ define_c_label(asm_primitive_apply) 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 set tc_compiled_entry,HEX(28) diff --git a/v7/src/microcode/cmpint.c b/v7/src/microcode/cmpint.c index 9de8592e7..0bd16aa13 100644 --- a/v7/src/microcode/cmpint.c +++ b/v7/src/microcode/cmpint.c @@ -1,6 +1,6 @@ /* -*-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 @@ -75,8 +75,10 @@ MIT in each case. */ /* Macro imports */ -#include #include +#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 */ @@ -89,7 +91,7 @@ MIT in each case. */ #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 */ @@ -165,9 +167,6 @@ MAKE_POINTER_OBJECT(TC_COMPILED_ENTRY, ((SCHEME_OBJECT *) (entry))) /* Imports from the rest of the "microcode" */ -extern term_type - Microcode_Termination(); - extern long compiler_cache_operator(), compiler_cache_lookup(), @@ -588,7 +587,6 @@ setup_lexpr_invocation (nactuals, nmax, entry_address) *local_free = EMPTY_LIST; return (PRIM_DONE); } - else /* (delta > 0) */ { /* The number of arguments passed is greater than the number of @@ -688,8 +686,8 @@ comutil_primitive_apply (primitive, ignore_2, ignore_3, ignore_4) 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 ())); } @@ -706,8 +704,8 @@ comutil_primitive_lexpr_apply (primitive, ignore_2, ignore_3, ignore_4) 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 ())); } @@ -749,7 +747,6 @@ comutil_apply (procedure, nactuals, ignore_3, ignore_4) nactuals += 1; goto callee_is_compiled; } - case TC_PRIMITIVE: { /* This code depends on the fact that unimplemented @@ -889,7 +886,6 @@ link_cc_block (block_address, offset, last_header_offset, block_address[last_header_offset] = (MAKE_LINKAGE_SECTION_HEADER (kind, total_count)); - for (offset += 1; ((--count) >= 0); offset += entry_size) { SCHEME_OBJECT name; @@ -1134,7 +1130,6 @@ comutil_operator_lookup_trap (tramp_data, ignore_2, ignore_3, ignore_4) { return (comutil_apply (true_operator, nargs, 0, 0)); } - else /* Error or interrupt */ { SCHEME_OBJECT trampoline, environment, name; @@ -1172,7 +1167,7 @@ comp_op_lookup_trap_restart () /* 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])); @@ -2097,7 +2092,6 @@ compiled_entry_type (entry, buffer) { kind = KIND_ILLEGAL; } - else { switch (((unsigned long) max_arity) & 0xff) @@ -2349,7 +2343,6 @@ make_uuo_link (procedure, extension, block, offset) return (PRIM_DONE); } nmin = (COMPILED_ENTRY_MINIMUM_ARITY (entry)); - if ((nmax > 1) && (nmin > 0) && (nmin <= nactuals) && (nactuals <= TRAMPOLINE_TABLE_SIZE) && (nmax <= (TRAMPOLINE_TABLE_SIZE + 1))) @@ -2639,8 +2632,7 @@ extern SCHEME_OBJECT extern void store_variable_cache(), - compiled_entry_type(), - Microcode_Termination(); + compiled_entry_type(); SCHEME_OBJECT Registers[REGBLOCK_MINIMUM_LENGTH], diff --git a/v7/src/microcode/cmpint.h b/v7/src/microcode/cmpint.h index 753576e95..6d992136e 100644 --- a/v7/src/microcode/cmpint.h +++ b/v7/src/microcode/cmpint.h @@ -1,8 +1,8 @@ /* -*-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 @@ -43,17 +43,11 @@ MIT in each case. */ #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; \ } @@ -68,12 +62,12 @@ MIT in each case. */ 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)); \ } \ } @@ -94,21 +88,19 @@ MIT in each case. */ 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(); \ @@ -120,8 +112,8 @@ MIT in each case. */ 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); \ }); \ } \ } @@ -132,7 +124,7 @@ MIT in each case. */ #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. */ \ @@ -140,7 +132,7 @@ MIT in each case. */ \ 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(); \ } \ @@ -148,8 +140,8 @@ MIT in each case. */ { \ /* 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); \ } \ } @@ -159,10 +151,8 @@ MIT in each case. */ #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(); \ } @@ -182,14 +172,12 @@ MIT in each case. */ #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. */ \ @@ -197,15 +185,15 @@ MIT in each case. */ (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 (); \ } \ } @@ -223,29 +211,27 @@ MIT in each case. */ #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 (); \ } \ } @@ -263,12 +249,12 @@ MIT in each case. */ 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 (); \ } diff --git a/v7/src/microcode/cmpintmd/mc68k.h b/v7/src/microcode/cmpintmd/mc68k.h index bf9e77ed4..1a9b070aa 100644 --- a/v7/src/microcode/cmpintmd/mc68k.h +++ b/v7/src/microcode/cmpintmd/mc68k.h @@ -1,6 +1,6 @@ /* -*-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 @@ -232,10 +232,23 @@ extdo { \ #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) @@ -243,6 +256,8 @@ extdo { \ } DEFUN_VOID (mc68k_reset_hook) +{ + mc68k_reset_hook () int offset = (COMPILER_REGBLOCK_N_FIXED * (sizeof (SCHEME_OBJECT))); diff --git a/v7/src/microcode/config.h b/v7/src/microcode/config.h index 1193a4a6d..82feb4093 100644 --- a/v7/src/microcode/config.h +++ b/v7/src/microcode/config.h @@ -1,6 +1,6 @@ /* -*-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 @@ -321,8 +321,8 @@ longjmp(Exit_Point, NORMAL_EXIT) #endif /* VMS */ #endif /* vax */ -#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 @@ -370,40 +370,60 @@ longjmp(Exit_Point, NORMAL_EXIT) #define Or3(x, y, z) ((x) ? true : ((y) ? true : (z))) #endif -#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" @@ -500,7 +520,7 @@ longjmp(Exit_Point, NORMAL_EXIT) #define COMPILER_CONSTANT_SIZE 1300 #endif -#endif /* spectrum */ +#endif /* hp9000s800 */ #ifdef umax #define MACHINE_TYPE "umax" diff --git a/v7/src/microcode/const.h b/v7/src/microcode/const.h index 5e52dbcdf..3334de206 100644 --- a/v7/src/microcode/const.h +++ b/v7/src/microcode/const.h @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, 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 * @@ -75,7 +75,6 @@ MIT in each case. */ #endif /* SHARP_F */ #define EMPTY_LIST SHARP_F -#define NOT_THERE -1 /* Command line parser */ /* Assorted sizes used in various places */ diff --git a/v7/src/microcode/daemon.c b/v7/src/microcode/daemon.c index 8aff4272c..12a4ffa10 100644 --- a/v7/src/microcode/daemon.c +++ b/v7/src/microcode/daemon.c @@ -1,6 +1,6 @@ /* -*-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 @@ -45,6 +45,7 @@ MIT in each case. */ #include "scheme.h" #include "prims.h" +#include "osio.h" /* (CLOSE-LOST-OPEN-FILES file-list) file-list is an assq-like list where the associations are weak @@ -55,30 +56,29 @@ MIT in each case. */ 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); } /* Utilities for the rehash daemon below */ diff --git a/v7/src/microcode/debug.c b/v7/src/microcode/debug.c index 804c4ab1d..4ca527822 100644 --- a/v7/src/microcode/debug.c +++ b/v7/src/microcode/debug.c @@ -1,8 +1,8 @@ /* -*-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 @@ -708,7 +708,7 @@ Print_One_Continuation_Frame (Temp) 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) || @@ -736,9 +736,9 @@ Back_Trace (where) 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"); @@ -751,7 +751,7 @@ Back_Trace (where) } else { - Temp = Pop(); + Temp = (STACK_POP ()); } if ((OBJECT_TYPE (Temp)) == TC_RETURN_CODE) { @@ -765,7 +765,7 @@ Back_Trace (where) 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"); @@ -831,7 +831,7 @@ Print_Primitive (primitive) 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"); @@ -839,11 +839,27 @@ Print_Primitive (primitive) } /* 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 @@ -860,140 +876,141 @@ Print_Primitive (primitive) #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); + } } - -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); } - -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 - 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, Set, 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, Set, 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 */ diff --git a/v7/src/microcode/default.h b/v7/src/microcode/default.h index b51d3de90..a9c4f3981 100644 --- a/v7/src/microcode/default.h +++ b/v7/src/microcode/default.h @@ -1,8 +1,8 @@ /* -*-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 @@ -77,7 +77,7 @@ MIT in each case. */ (* (locative)) = (object); \ } #endif - + #ifndef USE_STACKLETS #define Absolute_Stack_Base Constant_Top @@ -127,7 +127,7 @@ do \ #ifndef Exit_Scheme #define Exit_Scheme exit #endif - + /* Used in various places. */ #ifndef Init_Fixed_Objects @@ -140,18 +140,6 @@ do \ 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 - /* Used in debug.c */ #ifndef Back_Trace_Entry_Hook @@ -162,26 +150,6 @@ do \ #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 - /* Used in extern.h */ #ifndef More_Debug_Flag_Externs @@ -211,35 +179,9 @@ do \ 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 /* 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 @@ -255,7 +197,7 @@ extern SCHEME_OBJECT Apply_Primitive(); #ifndef End_GC_Hook #define End_GC_Hook() #endif - + /* Used in storage.c */ #ifndef More_Debug_Flag_Allocs @@ -271,7 +213,7 @@ extern SCHEME_OBJECT Apply_Primitive(); #ifndef Error_Exit_Hook #define Error_Exit_Hook() #endif - + /* Common Lisp Hooks */ #ifndef SITE_EXPRESSION_DISPATCH_HOOK diff --git a/v7/src/microcode/dmpwrld.c b/v7/src/microcode/dmpwrld.c index 759c20953..191511c80 100644 --- a/v7/src/microcode/dmpwrld.c +++ b/v7/src/microcode/dmpwrld.c @@ -1,8 +1,8 @@ /* -*-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 @@ -51,7 +51,7 @@ MIT in each case. */ #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) ? \ @@ -107,7 +107,7 @@ MIT in each case. */ (((((unsigned) &etext) - 1) & ~SEGMENT_MASK) + (SEGMENT_MASK + 1)) #endif -#ifdef hpux +#ifdef _HPUX #define USG #define HPUX #endif @@ -214,7 +214,7 @@ DEFINE_PRIMITIVE ("DUMP-WORLD", Prim_dump_world, 1, 1, 0) Was_Scheme_Dumped = true; Val = SHARP_T; OS_quit (TERM_HALT, false); - Pop_Primitive_Frame(1); + POP_PRIMITIVE_FRAME (1); /* Dump! */ @@ -239,7 +239,7 @@ DEFINE_PRIMITIVE ("DUMP-WORLD", Prim_dump_world, 1, 1, 0) if (Result != 0) { - Push (ARG_REF (1)); /* Since popped above */ + STACK_PUSH (ARG_REF (1)); /* Since popped above */ error_external_return (); } diff --git a/v7/src/microcode/extern.h b/v7/src/microcode/extern.h index 0128d3b98..4ee9a08b4 100644 --- a/v7/src/microcode/extern.h +++ b/v7/src/microcode/extern.h @@ -1,8 +1,8 @@ /* -*-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 @@ -36,16 +36,31 @@ MIT in each case. */ #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 */ @@ -90,19 +105,19 @@ extern SCHEME_OBJECT * 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 */ + +/* 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 (); - + extern long IntCode, /* Interrupts requesting */ IntEnb, /* Interrupts enabled */ @@ -123,11 +138,6 @@ extern char 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; @@ -136,10 +146,10 @@ extern SCHEME_OBJECT * Prev_Restore_History_Stacklet; 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; @@ -205,13 +215,10 @@ extern SCHEME_OBJECT memory_to_string (); 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 */ @@ -221,7 +228,15 @@ extern Boolean Pure_Test (); /* 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 (), @@ -240,9 +255,10 @@ extern SCHEME_OBJECT Find_State_Space (); /* Debugging utilities */ +extern void EXFUN (debug_edit_flags, (void)); + extern void Back_Trace (), - Handle_Debug_Flags (), Show_Env (), Show_Pure (), Print_Return (), diff --git a/v7/src/microcode/fasdump.c b/v7/src/microcode/fasdump.c index 995aba18b..9665448b2 100644 --- a/v7/src/microcode/fasdump.c +++ b/v7/src/microcode/fasdump.c @@ -1,6 +1,6 @@ /* -*-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 @@ -36,11 +36,22 @@ MIT in each case. */ #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 @@ -48,15 +59,12 @@ extern SCHEME_OBJECT *initialize_primitive_table(), *cons_primitive_table(), *cons_whole_primitive_table(); - -extern Boolean - OS_file_remove(); /* 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: @@ -329,7 +337,9 @@ Fasdump_Exit(code, close_p) 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; @@ -339,11 +349,9 @@ Fasdump_Exit(code, close_p) } 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); @@ -402,7 +410,7 @@ DEFINE_PRIMITIVE ("PRIMITIVE-FASDUMP", Prim_prim_fasdump, 3, 3, 0) { 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); @@ -447,10 +455,9 @@ DEFINE_PRIMITIVE ("PRIMITIVE-FASDUMP", Prim_prim_fasdump, 3, 3, 0) { 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, @@ -469,10 +476,10 @@ DEFINE_PRIMITIVE ("PRIMITIVE-FASDUMP", Prim_prim_fasdump, 3, 3, 0) { 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, @@ -525,7 +532,10 @@ DEFINE_PRIMITIVE ("DUMP-BAND", Prim_band_dump, 2, 2, 0) } 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, @@ -535,11 +545,9 @@ DEFINE_PRIMITIVE ("DUMP-BAND", Prim_band_dump, 2, 2, 0) ((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; diff --git a/v7/src/microcode/fasl.h b/v7/src/microcode/fasl.h index e6e042cb3..165f5af8b 100644 --- a/v7/src/microcode/fasl.h +++ b/v7/src/microcode/fasl.h @@ -1,6 +1,6 @@ /* -*-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 @@ -36,9 +36,6 @@ MIT in each case. */ 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(); /* FASL Version */ @@ -88,9 +85,6 @@ extern Boolean Open_Dump_File(), Close_Dump_File(); MAKE_OBJECT (((Band_p) ? TC_TRUE : TC_NULL), \ (((Version) << (DATUM_LENGTH / 2)) | \ (Processor_Type))) - -#define WRITE_FLAG 1 -#define OPEN_FLAG 0 /* "Memorable" FASL versions -- ones where we modified something and want to remain backwards compatible. diff --git a/v7/src/microcode/fasload.c b/v7/src/microcode/fasload.c index b0d353ac3..73471de6e 100644 --- a/v7/src/microcode/fasload.c +++ b/v7/src/microcode/fasload.c @@ -1,6 +1,6 @@ /* -*-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 @@ -39,40 +39,51 @@ MIT in each case. */ #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)); 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. */ @@ -97,7 +108,7 @@ read_file_start(name) 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); } @@ -111,13 +122,13 @@ read_file_start(name) 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); } @@ -126,14 +137,14 @@ read_file_start(name) return (PRIM_DONE); } -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); @@ -141,7 +152,7 @@ read_file_end() 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); @@ -151,20 +162,14 @@ read_file_end() 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); } /* Statics used by Relocate, below */ @@ -269,7 +274,6 @@ void Relocate_Block(Scan, Stop_At) fast SCHEME_OBJECT *Scan, *Stop_At; { - extern SCHEME_OBJECT *load_renumber_table; fast SCHEME_OBJECT Temp; fast long address; @@ -442,17 +446,14 @@ check_primitive_numbers(table, length) 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; } void @@ -479,7 +480,6 @@ Intern_Block(Next_Pointer, Stop_At) 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) { @@ -529,9 +529,6 @@ load_file(from_band_load) *Constant_End, *Orig_Constant, *temp, *primitive_table; - extern void install_primitive_table(); - extern SCHEME_OBJECT *load_renumber_table; - /* Read File */ #ifdef ENABLE_DEBUGGING_TOOLS @@ -565,8 +562,6 @@ load_file(from_band_load) 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); @@ -651,24 +646,25 @@ load_file(from_band_load) 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; /* (RELOAD-BAND-NAME) @@ -687,8 +683,6 @@ DEFINE_PRIMITIVE ("RELOAD-BAND-NAME", Prim_reload_band_name, 0, 0, 0) /* Utility for load band below. */ -extern void compiler_reset_error(); - void compiler_reset_error() { @@ -705,193 +699,135 @@ 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 - + 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; } } - - /* 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 (); - - 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*/ } diff --git a/v7/src/microcode/fhooks.c b/v7/src/microcode/fhooks.c index 5bdad128a..34358fcd5 100644 --- a/v7/src/microcode/fhooks.c +++ b/v7/src/microcode/fhooks.c @@ -1,8 +1,8 @@ /* -*-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 @@ -64,15 +64,15 @@ DEFINE_PRIMITIVE ("WITH-SAVED-FLUID-BINDINGS", Prim_with_saved_fluid_bindings, 1 { 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*/ diff --git a/v7/src/microcode/futures.h b/v7/src/microcode/futures.h index cceb3a7c9..6ba64fb97 100644 --- a/v7/src/microcode/futures.h +++ b/v7/src/microcode/futures.h @@ -1,8 +1,8 @@ /* -*-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 @@ -157,9 +157,9 @@ MIT in each case. */ { \ 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 (); \ } @@ -208,9 +208,9 @@ MIT in each case. */ #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; \ diff --git a/v7/src/microcode/generic.c b/v7/src/microcode/generic.c index ac32534ea..d1989379a 100644 --- a/v7/src/microcode/generic.c +++ b/v7/src/microcode/generic.c @@ -1,6 +1,6 @@ /* -*-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 @@ -39,8 +39,8 @@ MIT in each case. */ { \ 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*/ \ diff --git a/v7/src/microcode/history.h b/v7/src/microcode/history.h index 8b3943ccc..1401b0bb3 100644 --- a/v7/src/microcode/history.h +++ b/v7/src/microcode/history.h @@ -1,8 +1,8 @@ /* -*-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 @@ -69,12 +69,12 @@ MIT in each case. */ #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); \ diff --git a/v7/src/microcode/hooks.c b/v7/src/microcode/hooks.c index 3954a11d5..178eede9c 100644 --- a/v7/src/microcode/hooks.c +++ b/v7/src/microcode/hooks.c @@ -1,6 +1,6 @@ /* -*-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 @@ -32,10 +32,8 @@ Technology nor of any adaptation thereof in any advertising, 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" @@ -85,7 +83,7 @@ DEFINE_PRIMITIVE ("APPLY", Prim_apply, 2, 2, 0) 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; @@ -112,8 +110,8 @@ DEFINE_PRIMITIVE ("APPLY", Prim_apply, 2, 2, 0) 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*/ @@ -132,7 +130,7 @@ DEFINE_PRIMITIVE ("APPLY", Prim_apply, 2, 2, 0) { \ 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; \ @@ -155,9 +153,9 @@ DEFINE_PRIMITIVE ("APPLY", Prim_apply, 2, 2, 0) 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(); */ \ } \ } @@ -203,7 +201,7 @@ DEFINE_PRIMITIVE ("APPLY", Prim_apply, 2, 2, 0) 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); \ @@ -265,8 +263,8 @@ DEFINE_PRIMITIVE ("WITHIN-CONTROL-POINT", Prim_within_control_point, 2, 2, 0) 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); @@ -289,11 +287,11 @@ DEFINE_PRIMITIVE ("ERROR-PROCEDURE", Prim_error_procedure, 3, 3, 0) 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*/ @@ -308,7 +306,7 @@ DEFINE_PRIMITIVE ("SCODE-EVAL", Prim_scode_eval, 2, 2, 0) { 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); } @@ -331,13 +329,13 @@ DEFINE_PRIMITIVE ("FORCE", Prim_force, 1, 1, 0) { /* 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*/ @@ -347,7 +345,7 @@ DEFINE_PRIMITIVE ("FORCE", Prim_force, 1, 1, 0) { /* 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); @@ -394,7 +392,7 @@ DEFINE_PRIMITIVE ("EXECUTE-AT-NEW-STATE-POINT", Prim_execute_at_new_point, 4, 4, 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 */ @@ -403,8 +401,8 @@ DEFINE_PRIMITIVE ("EXECUTE-AT-NEW-STATE-POINT", Prim_execute_at_new_point, 4, 4, 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); @@ -423,7 +421,7 @@ DEFINE_PRIMITIVE ("TRANSLATE-TO-STATE-POINT", Prim_translate_to_point, 1, 1, 0) 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*/ } @@ -555,14 +553,14 @@ DEFINE_PRIMITIVE ("WITH-INTERRUPT-MASK", Prim_with_interrupt_mask, 2, 2, 0) 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); @@ -578,14 +576,14 @@ DEFINE_PRIMITIVE ("WITH-INTERRUPTS-REDUCED", Prim_with_interrupts_reduced, 2, 2, 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)); @@ -616,7 +614,7 @@ DEFINE_PRIMITIVE ("SET-CURRENT-HISTORY!", Prim_set_current_history, 1, 1, 0) #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*/ } @@ -650,11 +648,11 @@ DEFINE_PRIMITIVE ("WITH-HISTORY-DISABLED", Prim_with_history_disabled, 1, 1, 0) (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*/ diff --git a/v7/src/microcode/intercom.c b/v7/src/microcode/intercom.c index a4b0eb50f..d4280e3e7 100644 --- a/v7/src/microcode/intercom.c +++ b/v7/src/microcode/intercom.c @@ -1,6 +1,8 @@ /* -*-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 @@ -30,11 +32,8 @@ Technology nor of any adaptation thereof in any advertising, 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. */ #include "scheme.h" #include "prims.h" @@ -74,13 +73,13 @@ DEFINE_PRIMITIVE ("GLOBAL-INTERRUPT", Prim_send_global_interrupt, 3, 3, 0) 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); @@ -190,19 +189,19 @@ DEFINE_PRIMITIVE ("GET-WORK", Prim_get_work, 1, 1, 0) 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); } @@ -254,7 +253,7 @@ DEFINE_PRIMITIVE ("ZERO-ZONES", Prim_zero_zones, 0, 0, 0) Time_Meters[i] = 0; } - Old_Time=Sys_Clock(); + Old_Time = (OS_process_clock ()); #endif PRIMITIVE_RETURN (UNSPECIFIC); } @@ -298,11 +297,11 @@ DEFINE_PRIMITIVE ("MASTER-GC-LOOP", Prim_master_gc, 1, 1, 0) 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); } diff --git a/v7/src/microcode/interp.c b/v7/src/microcode/interp.c index 7c601d0b2..989e7ef06 100644 --- a/v7/src/microcode/interp.c +++ b/v7/src/microcode/interp.c @@ -1,8 +1,8 @@ /* -*-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 @@ -43,6 +43,10 @@ MIT in each case. */ #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 /* In order to make the interpreter tail recursive (i.e. * to avoid calling procedures and thus saving unnecessary @@ -128,7 +132,7 @@ if (GC_Check(Amount)) \ #define Prepare_Eval_Repeat() \ { \ Will_Push(CONTINUATION_SIZE+1); \ - Push(Fetch_Env()); \ + STACK_PUSH (Fetch_Env()); \ Store_Return(RC_EVAL_ERROR); \ Save_Cont(); \ Pushed(); \ @@ -206,7 +210,7 @@ if (GC_Check(Amount)) \ { \ 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) \ @@ -293,9 +297,9 @@ if (GC_Check(Amount)) \ 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; \ } \ @@ -313,7 +317,7 @@ if (GC_Check(Amount)) \ { \ 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))); \ @@ -386,6 +390,26 @@ if (GC_Check(Amount)) \ The EVAL/APPLY ying/yang */ +static PTR interpreter_catch_dstack_position; +static jmp_buf interpreter_catch_env; +static int interpreter_throw_argument; + +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; @@ -408,9 +432,10 @@ Interpret(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 (); Repeat_Dispatch: switch (Which_Way) @@ -566,10 +591,10 @@ Do_Expression: { 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; } @@ -644,13 +669,13 @@ Eval_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(); @@ -731,9 +756,9 @@ Eval_Non_Trapping: } 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 @@ -912,7 +937,7 @@ Pop_Return: 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); @@ -932,15 +957,15 @@ Pop_Return: { 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); @@ -950,9 +975,9 @@ Pop_Return: 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); @@ -964,9 +989,9 @@ Pop_Return: { 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! */ @@ -975,7 +1000,7 @@ Pop_Return: 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); } @@ -1064,11 +1089,11 @@ Pop_Return: 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()); case RC_EXECUTE_ACCESS_FINISH: @@ -1328,13 +1353,13 @@ external_assignment_return: ((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; } @@ -1358,14 +1383,14 @@ external_assignment_return: { \ 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); \ } @@ -1376,7 +1401,7 @@ external_assignment_return: 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: @@ -1387,9 +1412,9 @@ 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 (); } @@ -1411,7 +1436,7 @@ Perform_Application: { 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)) { @@ -1428,9 +1453,9 @@ Perform_Application: 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 @@ -1450,7 +1475,7 @@ Perform_Application: { fast long nargs; - nargs = OBJECT_DATUM (Pop()); + nargs = OBJECT_DATUM (STACK_POP ()); Function = FAST_MEMORY_REF (Function, PROCEDURE_LAMBDA_EXPR); { @@ -1463,7 +1488,7 @@ Perform_Application: ((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); } } @@ -1476,7 +1501,7 @@ Perform_Application: 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); } @@ -1488,7 +1513,7 @@ Perform_Application: 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)); } @@ -1500,12 +1525,12 @@ Perform_Application: 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(); @@ -1535,7 +1560,7 @@ Perform_Application: /* 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)) { @@ -1546,14 +1571,12 @@ Perform_Application: 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); @@ -1577,7 +1600,7 @@ Perform_Application: 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) { @@ -1598,7 +1621,7 @@ Perform_Application: 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); } @@ -1608,7 +1631,7 @@ Perform_Application: (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)) : @@ -1626,7 +1649,7 @@ Perform_Application: 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) @@ -1641,14 +1664,14 @@ Perform_Application: 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; } @@ -1666,7 +1689,7 @@ Perform_Application: 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(); @@ -1684,7 +1707,7 @@ return_from_compiled_code: { compiler_apply_procedure (STACK_ENV_EXTRA_SLOTS + - OBJECT_DATUM (Stack_Ref (STACK_ENV_HEADER))); + OBJECT_DATUM (STACK_REF (STACK_ENV_HEADER))); goto Internal_Apply; } @@ -1774,17 +1797,17 @@ return_from_compiled_code: 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 @@ -1794,8 +1817,8 @@ return_from_compiled_code: 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 = @@ -1803,10 +1826,10 @@ return_from_compiled_code: } 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 { @@ -1823,8 +1846,8 @@ return_from_compiled_code: 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; } @@ -1836,9 +1859,9 @@ return_from_compiled_code: 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; @@ -1857,9 +1880,7 @@ return_from_compiled_code: 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(); @@ -1867,7 +1888,7 @@ return_from_compiled_code: 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)); @@ -1880,9 +1901,9 @@ Primitive_Internal_Apply: 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(); @@ -1899,39 +1920,36 @@ Primitive_Internal_Apply: */ { - 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; } 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; @@ -1944,16 +1962,16 @@ 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: @@ -1994,8 +2012,8 @@ Primitive_Internal_Apply: 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; } @@ -2008,7 +2026,7 @@ Primitive_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; @@ -2030,8 +2048,8 @@ Primitive_Internal_Apply: { 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) { @@ -2069,8 +2087,8 @@ Primitive_Internal_Apply: 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 @@ -2121,9 +2139,9 @@ Primitive_Internal_Apply: 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; diff --git a/v7/src/microcode/interp.h b/v7/src/microcode/interp.h index 88e132672..3891a5901 100644 --- a/v7/src/microcode/interp.h +++ b/v7/src/microcode/interp.h @@ -1,8 +1,8 @@ /* -*-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 @@ -33,6 +33,9 @@ promotional, or sales literature without prior written consent from 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)); /********************/ /* OPEN CODED RACKS */ @@ -80,8 +83,8 @@ MIT in each case. */ #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] @@ -97,7 +100,7 @@ MIT in each case. */ 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) \ @@ -144,20 +147,6 @@ MIT in each case. */ #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) /* Fetch from register */ @@ -172,23 +161,23 @@ MIT in each case. */ #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); \ @@ -255,55 +244,53 @@ MIT in each case. */ (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) - -#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)) diff --git a/v7/src/microcode/intrpt.h b/v7/src/microcode/intrpt.h index d813da2a5..b28e77039 100644 --- a/v7/src/microcode/intrpt.h +++ b/v7/src/microcode/intrpt.h @@ -1,8 +1,8 @@ /* -*-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 @@ -107,66 +107,3 @@ MIT in each case. */ /* Compatibility */ #define COMPILER_SET_MEMTOP() COMPILER_SETUP_INTERRUPT() - -/* 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) diff --git a/v7/src/microcode/memmag.c b/v7/src/microcode/memmag.c index e7274f8eb..dc1728089 100644 --- a/v7/src/microcode/memmag.c +++ b/v7/src/microcode/memmag.c @@ -1,6 +1,6 @@ /* -*-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 @@ -419,7 +419,7 @@ DEFINE_PRIMITIVE ("GARBAGE-COLLECT", Prim_garbage_collect, 1, 1, 0) 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) @@ -436,8 +436,8 @@ DEFINE_PRIMITIVE ("GARBAGE-COLLECT", Prim_garbage_collect, 1, 1, 0) 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. */ diff --git a/v7/src/microcode/mul.c b/v7/src/microcode/mul.c index ea6c62d03..d7235c44f 100644 --- a/v7/src/microcode/mul.c +++ b/v7/src/microcode/mul.c @@ -1,6 +1,6 @@ /* -*-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 @@ -41,7 +41,7 @@ extern SCHEME_OBJECT Mul (); #if (TYPE_CODE_LENGTH == 8) -#if defined(vax) && defined(bsd) +#if defined(vax) && defined(_BSD) #define MUL_HANDLED @@ -99,11 +99,11 @@ Mul (Arg1, Arg2) : SHARP_F); } -#endif /* vax+bsd */ +#endif /* vax and _BSD */ -/* 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 @@ -197,7 +197,7 @@ static long Fixnum_Range[2] = {SMALLEST_FIXNUM , BIGGEST_FIXNUM}; asm(" data"); #endif /* not MC68020 */ -#endif /* hp9000s200 */ +#endif /* hp9000s300 */ #endif /* (TYPE_CODE_LENGTH == 8) */ diff --git a/v7/src/microcode/ppband.c b/v7/src/microcode/ppband.c index d2fc6c79c..8a91d00c7 100644 --- a/v7/src/microcode/ppband.c +++ b/v7/src/microcode/ppband.c @@ -1,8 +1,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 @@ -43,7 +43,7 @@ MIT in each case. */ #include "sdata.h" #define fast register - + /* These are needed by load.c */ static SCHEME_OBJECT * memory_base; @@ -56,37 +56,16 @@ Load_Data(Count, To_Where) 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); -} - #define INHIBIT_COMPILED_VERSION_CHECK #include "load.c" - + #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 diff --git a/v7/src/microcode/prename.h b/v7/src/microcode/prename.h index 55bda865d..1aedce227 100644 --- a/v7/src/microcode/prename.h +++ b/v7/src/microcode/prename.h @@ -1,8 +1,8 @@ /* -*-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 @@ -39,32 +39,23 @@ static struct primitive_alias aliases [] = { "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 diff --git a/v7/src/microcode/prims.h b/v7/src/microcode/prims.h index b9c3c8734..877122827 100644 --- a/v7/src/microcode/prims.h +++ b/v7/src/microcode/prims.h @@ -1,8 +1,8 @@ /* -*-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 @@ -55,7 +55,7 @@ SCHEME_OBJECT fn_name () /* 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 diff --git a/v7/src/microcode/purify.c b/v7/src/microcode/purify.c index 72b90e39b..313e9c15b 100644 --- a/v7/src/microcode/purify.c +++ b/v7/src/microcode/purify.c @@ -1,6 +1,8 @@ /* -*-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 @@ -30,12 +32,8 @@ Technology nor of any adaptation thereof in any advertising, 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" @@ -521,7 +519,7 @@ DEFINE_PRIMITIVE ("PRIMITIVE-PURIFY", Prim_primitive_purify, 3, 3, 0) 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) { @@ -541,8 +539,8 @@ DEFINE_PRIMITIVE ("PRIMITIVE-PURIFY", Prim_primitive_purify, 3, 3, 0) 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*/ diff --git a/v7/src/microcode/scheme.h b/v7/src/microcode/scheme.h index 6a7e62e26..7834411bc 100644 --- a/v7/src/microcode/scheme.h +++ b/v7/src/microcode/scheme.h @@ -1,8 +1,8 @@ /* -*-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 @@ -64,9 +64,12 @@ MIT in each case. */ #define forward extern /* For forward references */ -#include #include +#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 @@ -77,6 +80,7 @@ MIT in each case. */ #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 */ diff --git a/v7/src/microcode/stack.h b/v7/src/microcode/stack.h index 3b7477f51..f371cad6d 100644 --- a/v7/src/microcode/stack.h +++ b/v7/src/microcode/stack.h @@ -1,8 +1,8 @@ /* -*-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 @@ -141,9 +141,9 @@ Will_Push((2 * CONTINUATION_SIZE) + (STACK_ENV_EXTRA_SLOTS + 2)); \ 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() diff --git a/v7/src/microcode/step.c b/v7/src/microcode/step.c index 2336a5d3e..bf89fb12a 100644 --- a/v7/src/microcode/step.c +++ b/v7/src/microcode/step.c @@ -1,6 +1,8 @@ /* -*-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 @@ -30,10 +32,7 @@ Technology nor of any adaptation thereof in any advertising, 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" @@ -66,9 +65,9 @@ Install_Traps(Hunk3, Return_Hook_Too) 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; @@ -89,7 +88,7 @@ DEFINE_PRIMITIVE ("PRIMITIVE-EVAL-STEP", Prim_eval_step, 3, 3, 0) 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); } @@ -127,7 +126,7 @@ DEFINE_PRIMITIVE ("PRIMITIVE-APPLY-STEP", Prim_apply_step, 3, 3, 0) 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; @@ -140,8 +139,8 @@ DEFINE_PRIMITIVE ("PRIMITIVE-APPLY-STEP", Prim_apply_step, 3, 3, 0) (*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 (); } } diff --git a/v7/src/microcode/storage.c b/v7/src/microcode/storage.c index b44685689..8563d1790 100644 --- a/v7/src/microcode/storage.c +++ b/v7/src/microcode/storage.c @@ -1,8 +1,8 @@ /* -*-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 @@ -73,32 +73,22 @@ long /* 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 /**********************/ diff --git a/v7/src/microcode/sysprim.c b/v7/src/microcode/sysprim.c index d97e83cf0..8039324f6 100644 --- a/v7/src/microcode/sysprim.c +++ b/v7/src/microcode/sysprim.c @@ -1,8 +1,8 @@ /* -*-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 @@ -37,114 +37,29 @@ MIT in each case. */ #include "scheme.h" #include "prims.h" +#include "ostty.h" +#include "ostop.h" -/* 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)); -} - -/* 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) - -/* 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) @@ -157,25 +72,13 @@ DEFINE_PRIMITIVE ("SET-RUN-LIGHT!", Prim_set_run_light, 1, 1, 0) { 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 ())); -} - #define CONVERT_ADDRESS(address) \ (long_to_integer (ADDRESS_TO_DATUM (address))) @@ -228,7 +131,7 @@ DEFINE_PRIMITIVE ("GC-SPACE-STATUS", Prim_gc_space_status, 0, 0, 0) #endif /* USE_STACKLETS */ PRIMITIVE_RETURN (result); } - + DEFINE_PRIMITIVE ("SET-TRAP-STATE!", Prim_set_trap_state, 1, 1, 0) { long result; diff --git a/v7/src/microcode/unxutl/config b/v7/src/microcode/unxutl/config index 3e361bb6a..362a970d4 100755 --- a/v7/src/microcode/unxutl/config +++ b/v7/src/microcode/unxutl/config @@ -1,6 +1,6 @@ #!/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. @@ -42,6 +42,7 @@ symbolic_link='ln -s' #hard_link="echo ln" #symbolic_link="echo ln -s" +cmpint_file=nothing_special cmp_file=nothing_special case $# in @@ -49,62 +50,76 @@ 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 @@ -132,6 +147,20 @@ case $# in 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) ;; @@ -153,8 +182,9 @@ case $# in ;; *) 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 diff --git a/v7/src/microcode/unxutl/ymkfile b/v7/src/microcode/unxutl/ymkfile index 717c92a59..828704e6c 100644 --- a/v7/src/microcode/unxutl/ymkfile +++ b/v7/src/microcode/unxutl/ymkfile @@ -1,6 +1,6 @@ /* -*-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 @@ -284,10 +284,10 @@ char.c \ comutl.c \ daemon.c \ debug.c \ +error.c \ extern.c \ fasdump.c \ fasload.c \ -fileio.c \ fixnum.c \ flonum.c \ gcloop.c \ @@ -301,9 +301,12 @@ list.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 \ @@ -313,9 +316,40 @@ storage.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 @@ -331,9 +365,9 @@ char.o \ comutl.o \ daemon.o \ debug.o \ +error.o \ extern.o \ fasload.o \ -fileio.o \ fixnum.o \ flonum.o \ generic.o \ @@ -345,9 +379,12 @@ intprm.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 \ @@ -356,9 +393,40 @@ storage.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 \ @@ -372,8 +440,8 @@ bchgcl.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. */ @@ -424,33 +492,35 @@ install: scheme bchscheme /* 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 @@ -494,21 +564,20 @@ fixnum.o : scheme.touch prims.h mul.c 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 @@ -535,4 +604,36 @@ cmpaux-hppa.s : cmpaux-hppa.m4 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 diff --git a/v7/src/microcode/utils.c b/v7/src/microcode/utils.c index 9c22906da..768595455 100644 --- a/v7/src/microcode/utils.c +++ b/v7/src/microcode/utils.c @@ -1,6 +1,6 @@ /* -*-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 @@ -115,10 +115,10 @@ Passed_Checks: /* This label may be used in Global_Interrupt_Hook */ * 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); @@ -156,7 +156,7 @@ error_death (code, message) 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*/ } @@ -189,10 +189,10 @@ Back_Out_Of_Primitive () 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); @@ -226,7 +226,7 @@ canonicalize_primitive_context () 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); @@ -527,7 +527,7 @@ Do_Micro_Error (Err, From_Pop_Return) } else { - Push(Fetch_Env()); + STACK_PUSH (Fetch_Env()); } Store_Return((From_Pop_Return) ? @@ -542,19 +542,19 @@ Do_Micro_Error (Err, 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 */ @@ -713,46 +713,40 @@ Restore_History (Hist_Obj) return (true); } -/* 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 */ @@ -974,10 +968,10 @@ Translate_To_Point (Target) 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(); diff --git a/v7/src/microcode/version.h b/v7/src/microcode/version.h index e87010dbe..6eb7616c8 100644 --- a/v7/src/microcode/version.h +++ b/v7/src/microcode/version.h @@ -1,6 +1,6 @@ /* -*-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 @@ -46,7 +46,7 @@ MIT in each case. */ #define VERSION 11 #endif #ifndef SUBVERSION -#define SUBVERSION 31 +#define SUBVERSION 32 #endif #ifndef UCODE_TABLES_FILENAME diff --git a/v7/src/microcode/x11term.c b/v7/src/microcode/x11term.c index 75558d190..25a614edd 100644 --- a/v7/src/microcode/x11term.c +++ b/v7/src/microcode/x11term.c @@ -1,8 +1,8 @@ /* -*-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 @@ -575,13 +575,13 @@ DEFINE_PRIMITIVE ("XTERM-READ-CHARS", Prim_xterm_read_chars, 2, 2, 0) 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)) || diff --git a/v7/src/microcode/xdebug.c b/v7/src/microcode/xdebug.c index 3c1bc4e98..b2a2e7d58 100644 --- a/v7/src/microcode/xdebug.c +++ b/v7/src/microcode/xdebug.c @@ -1,6 +1,6 @@ /* -*-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 @@ -268,20 +268,18 @@ DEFINE_PRIMITIVE ("DEBUG-FIND-SYMBOL", Prim_debug_find_symbol, 1, 1, 0) PRIMITIVE_RETURN (UNSPECIFIC); } -/* 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)), @@ -293,7 +291,6 @@ DEFINE_PRIMITIVE ("DEBUG-PRINT-MEMORY", Prim_debug_print_memory, 2, 2, 0) { SCHEME_OBJECT object; PRIMITIVE_HEADER (2); - object = (ARG_REF (1)); Print_Memory (((GC_Type_Non_Pointer (object)) diff --git a/v7/src/microcode/zones.h b/v7/src/microcode/zones.h index 6cef8843b..d8541d89a 100644 --- a/v7/src/microcode/zones.h +++ b/v7/src/microcode/zones.h @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, 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. @@ -42,11 +42,12 @@ MIT in each case. */ 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; diff --git a/v8/src/microcode/cmpint.c b/v8/src/microcode/cmpint.c index 823341f54..e0d143bea 100644 --- a/v8/src/microcode/cmpint.c +++ b/v8/src/microcode/cmpint.c @@ -1,6 +1,6 @@ /* -*-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 @@ -75,8 +75,10 @@ MIT in each case. */ /* Macro imports */ -#include #include +#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 */ @@ -89,7 +91,7 @@ MIT in each case. */ #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 */ @@ -165,9 +167,6 @@ MAKE_POINTER_OBJECT(TC_COMPILED_ENTRY, ((SCHEME_OBJECT *) (entry))) /* Imports from the rest of the "microcode" */ -extern term_type - Microcode_Termination(); - extern long compiler_cache_operator(), compiler_cache_lookup(), @@ -588,7 +587,6 @@ setup_lexpr_invocation (nactuals, nmax, entry_address) *local_free = EMPTY_LIST; return (PRIM_DONE); } - else /* (delta > 0) */ { /* The number of arguments passed is greater than the number of @@ -688,8 +686,8 @@ comutil_primitive_apply (primitive, ignore_2, ignore_3, ignore_4) 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 ())); } @@ -706,8 +704,8 @@ comutil_primitive_lexpr_apply (primitive, ignore_2, ignore_3, ignore_4) 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 ())); } @@ -749,7 +747,6 @@ comutil_apply (procedure, nactuals, ignore_3, ignore_4) nactuals += 1; goto callee_is_compiled; } - case TC_PRIMITIVE: { /* This code depends on the fact that unimplemented @@ -889,7 +886,6 @@ link_cc_block (block_address, offset, last_header_offset, block_address[last_header_offset] = (MAKE_LINKAGE_SECTION_HEADER (kind, total_count)); - for (offset += 1; ((--count) >= 0); offset += entry_size) { SCHEME_OBJECT name; @@ -1134,7 +1130,6 @@ comutil_operator_lookup_trap (tramp_data, ignore_2, ignore_3, ignore_4) { return (comutil_apply (true_operator, nargs, 0, 0)); } - else /* Error or interrupt */ { SCHEME_OBJECT trampoline, environment, name; @@ -1172,7 +1167,7 @@ comp_op_lookup_trap_restart () /* 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])); @@ -2097,7 +2092,6 @@ compiled_entry_type (entry, buffer) { kind = KIND_ILLEGAL; } - else { switch (((unsigned long) max_arity) & 0xff) @@ -2349,7 +2343,6 @@ make_uuo_link (procedure, extension, block, offset) return (PRIM_DONE); } nmin = (COMPILED_ENTRY_MINIMUM_ARITY (entry)); - if ((nmax > 1) && (nmin > 0) && (nmin <= nactuals) && (nactuals <= TRAMPOLINE_TABLE_SIZE) && (nmax <= (TRAMPOLINE_TABLE_SIZE + 1))) @@ -2639,8 +2632,7 @@ extern SCHEME_OBJECT extern void store_variable_cache(), - compiled_entry_type(), - Microcode_Termination(); + compiled_entry_type(); SCHEME_OBJECT Registers[REGBLOCK_MINIMUM_LENGTH], diff --git a/v8/src/microcode/const.h b/v8/src/microcode/const.h index 93fb1a534..a1a0de34f 100644 --- a/v8/src/microcode/const.h +++ b/v8/src/microcode/const.h @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, 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 * @@ -75,7 +75,6 @@ MIT in each case. */ #endif /* SHARP_F */ #define EMPTY_LIST SHARP_F -#define NOT_THERE -1 /* Command line parser */ /* Assorted sizes used in various places */ diff --git a/v8/src/microcode/fasl.h b/v8/src/microcode/fasl.h index ac1546402..540db7c4f 100644 --- a/v8/src/microcode/fasl.h +++ b/v8/src/microcode/fasl.h @@ -1,6 +1,6 @@ /* -*-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 @@ -36,9 +36,6 @@ MIT in each case. */ 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(); /* FASL Version */ @@ -88,9 +85,6 @@ extern Boolean Open_Dump_File(), Close_Dump_File(); MAKE_OBJECT (((Band_p) ? TC_TRUE : TC_NULL), \ (((Version) << (DATUM_LENGTH / 2)) | \ (Processor_Type))) - -#define WRITE_FLAG 1 -#define OPEN_FLAG 0 /* "Memorable" FASL versions -- ones where we modified something and want to remain backwards compatible. diff --git a/v8/src/microcode/interp.c b/v8/src/microcode/interp.c index d4706847b..181e90bf7 100644 --- a/v8/src/microcode/interp.c +++ b/v8/src/microcode/interp.c @@ -1,8 +1,8 @@ /* -*-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 @@ -43,6 +43,10 @@ MIT in each case. */ #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 /* In order to make the interpreter tail recursive (i.e. * to avoid calling procedures and thus saving unnecessary @@ -128,7 +132,7 @@ if (GC_Check(Amount)) \ #define Prepare_Eval_Repeat() \ { \ Will_Push(CONTINUATION_SIZE+1); \ - Push(Fetch_Env()); \ + STACK_PUSH (Fetch_Env()); \ Store_Return(RC_EVAL_ERROR); \ Save_Cont(); \ Pushed(); \ @@ -206,7 +210,7 @@ if (GC_Check(Amount)) \ { \ 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) \ @@ -293,9 +297,9 @@ if (GC_Check(Amount)) \ 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; \ } \ @@ -313,7 +317,7 @@ if (GC_Check(Amount)) \ { \ 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))); \ @@ -386,6 +390,26 @@ if (GC_Check(Amount)) \ The EVAL/APPLY ying/yang */ +static PTR interpreter_catch_dstack_position; +static jmp_buf interpreter_catch_env; +static int interpreter_throw_argument; + +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; @@ -408,9 +432,10 @@ Interpret(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 (); Repeat_Dispatch: switch (Which_Way) @@ -566,10 +591,10 @@ Do_Expression: { 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; } @@ -644,13 +669,13 @@ Eval_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(); @@ -731,9 +756,9 @@ Eval_Non_Trapping: } 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 @@ -912,7 +937,7 @@ Pop_Return: 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); @@ -932,15 +957,15 @@ Pop_Return: { 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); @@ -950,9 +975,9 @@ Pop_Return: 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); @@ -964,9 +989,9 @@ Pop_Return: { 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! */ @@ -975,7 +1000,7 @@ Pop_Return: 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); } @@ -1064,11 +1089,11 @@ Pop_Return: 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()); case RC_EXECUTE_ACCESS_FINISH: @@ -1328,13 +1353,13 @@ external_assignment_return: ((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; } @@ -1358,14 +1383,14 @@ external_assignment_return: { \ 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); \ } @@ -1376,7 +1401,7 @@ external_assignment_return: 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: @@ -1387,9 +1412,9 @@ 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 (); } @@ -1411,7 +1436,7 @@ Perform_Application: { 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)) { @@ -1428,9 +1453,9 @@ Perform_Application: 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 @@ -1450,7 +1475,7 @@ Perform_Application: { fast long nargs; - nargs = OBJECT_DATUM (Pop()); + nargs = OBJECT_DATUM (STACK_POP ()); Function = FAST_MEMORY_REF (Function, PROCEDURE_LAMBDA_EXPR); { @@ -1463,7 +1488,7 @@ Perform_Application: ((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); } } @@ -1476,7 +1501,7 @@ Perform_Application: 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); } @@ -1488,7 +1513,7 @@ Perform_Application: 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)); } @@ -1500,12 +1525,12 @@ Perform_Application: 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(); @@ -1535,7 +1560,7 @@ Perform_Application: /* 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)) { @@ -1546,14 +1571,12 @@ Perform_Application: 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); @@ -1577,7 +1600,7 @@ Perform_Application: 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) { @@ -1598,7 +1621,7 @@ Perform_Application: 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); } @@ -1608,7 +1631,7 @@ Perform_Application: (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)) : @@ -1626,7 +1649,7 @@ Perform_Application: 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) @@ -1641,14 +1664,14 @@ Perform_Application: 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; } @@ -1666,7 +1689,7 @@ Perform_Application: 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(); @@ -1684,7 +1707,7 @@ return_from_compiled_code: { compiler_apply_procedure (STACK_ENV_EXTRA_SLOTS + - OBJECT_DATUM (Stack_Ref (STACK_ENV_HEADER))); + OBJECT_DATUM (STACK_REF (STACK_ENV_HEADER))); goto Internal_Apply; } @@ -1774,17 +1797,17 @@ return_from_compiled_code: 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 @@ -1794,8 +1817,8 @@ return_from_compiled_code: 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 = @@ -1803,10 +1826,10 @@ return_from_compiled_code: } 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 { @@ -1823,8 +1846,8 @@ return_from_compiled_code: 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; } @@ -1836,9 +1859,9 @@ return_from_compiled_code: 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; @@ -1857,9 +1880,7 @@ return_from_compiled_code: 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(); @@ -1867,7 +1888,7 @@ return_from_compiled_code: 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)); @@ -1880,9 +1901,9 @@ Primitive_Internal_Apply: 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(); @@ -1899,39 +1920,36 @@ Primitive_Internal_Apply: */ { - 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; } 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; @@ -1944,16 +1962,16 @@ 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: @@ -1994,8 +2012,8 @@ Primitive_Internal_Apply: 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; } @@ -2008,7 +2026,7 @@ Primitive_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; @@ -2030,8 +2048,8 @@ Primitive_Internal_Apply: { 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) { @@ -2069,8 +2087,8 @@ Primitive_Internal_Apply: 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 @@ -2121,9 +2139,9 @@ Primitive_Internal_Apply: 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; diff --git a/v8/src/microcode/mul.c b/v8/src/microcode/mul.c index a4b2e6c2b..04a2843d2 100644 --- a/v8/src/microcode/mul.c +++ b/v8/src/microcode/mul.c @@ -1,6 +1,6 @@ /* -*-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 @@ -41,7 +41,7 @@ extern SCHEME_OBJECT Mul (); #if (TYPE_CODE_LENGTH == 8) -#if defined(vax) && defined(bsd) +#if defined(vax) && defined(_BSD) #define MUL_HANDLED @@ -99,11 +99,11 @@ Mul (Arg1, Arg2) : SHARP_F); } -#endif /* vax+bsd */ +#endif /* vax and _BSD */ -/* 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 @@ -197,7 +197,7 @@ static long Fixnum_Range[2] = {SMALLEST_FIXNUM , BIGGEST_FIXNUM}; asm(" data"); #endif /* not MC68020 */ -#endif /* hp9000s200 */ +#endif /* hp9000s300 */ #endif /* (TYPE_CODE_LENGTH == 8) */ diff --git a/v8/src/microcode/ppband.c b/v8/src/microcode/ppband.c index 25880a90c..647a6472b 100644 --- a/v8/src/microcode/ppband.c +++ b/v8/src/microcode/ppband.c @@ -1,8 +1,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 @@ -43,7 +43,7 @@ MIT in each case. */ #include "sdata.h" #define fast register - + /* These are needed by load.c */ static SCHEME_OBJECT * memory_base; @@ -56,37 +56,16 @@ Load_Data(Count, To_Where) 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); -} - #define INHIBIT_COMPILED_VERSION_CHECK #include "load.c" - + #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 diff --git a/v8/src/microcode/version.h b/v8/src/microcode/version.h index 3fe71f40c..703ff2fa3 100644 --- a/v8/src/microcode/version.h +++ b/v8/src/microcode/version.h @@ -1,6 +1,6 @@ /* -*-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 @@ -46,7 +46,7 @@ MIT in each case. */ #define VERSION 11 #endif #ifndef SUBVERSION -#define SUBVERSION 31 +#define SUBVERSION 32 #endif #ifndef UCODE_TABLES_FILENAME -- 2.25.1