From: Guillermo J. Rozas Date: Fri, 9 Oct 1987 16:15:41 +0000 (+0000) Subject: Eliminate all remnants of danger bits. X-Git-Tag: 20090517-FFI~13084 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=7ef76146f2e7fe68b17c27c2910e68d05bd0f45a;p=mit-scheme.git Eliminate all remnants of danger bits. - History now uses two distinct types for marked and unmarked versions. - Stacklets/control points have a separate word used as the reuse flag. --- diff --git a/v7/src/microcode/bchmmg.c b/v7/src/microcode/bchmmg.c index 85dcb2061..8411d4bdb 100644 --- a/v7/src/microcode/bchmmg.c +++ b/v7/src/microcode/bchmmg.c @@ -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/bchmmg.c,v 9.36 1987/08/25 20:37:58 jinx Exp $ */ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchmmg.c,v 9.37 1987/10/09 16:08:36 jinx Rel $ */ /* Memory management top level. Garbage collection to disk. @@ -589,7 +589,7 @@ GC(initial_weak_chain) Set_Fixed_Obj_Slot(Lost_Objects_Base, NIL); *free_buffer++ = Fixed_Objects; - *free_buffer++ = Make_Pointer(TC_HUNK3, History); + *free_buffer++ = Make_Pointer(UNMARKED_HISTORY_TYPE, History); *free_buffer++ = Undefined_Externals; *free_buffer++ = Get_Current_Stacklet(); *free_buffer++ = ((Prev_Restore_History_Stacklet == NULL) ? diff --git a/v7/src/microcode/bitstr.c b/v7/src/microcode/bitstr.c index 520691a50..840c6ad45 100644 --- a/v7/src/microcode/bitstr.c +++ b/v7/src/microcode/bitstr.c @@ -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/bitstr.c,v 9.33 1987/08/17 19:31:42 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/bitstr.c,v 9.34 1987/10/09 16:08:51 jinx Rel $ Bit string primitives. @@ -644,7 +644,9 @@ long_to_bit_string (length, number) error_bad_range_arg (2); if (number == 0) - zero_to_bit_string (length); + { + return (zero_to_bit_string (length)); + } else { Pointer result; diff --git a/v7/src/microcode/boot.c b/v7/src/microcode/boot.c index c21033bd3..79a4d1bab 100644 --- a/v7/src/microcode/boot.c +++ b/v7/src/microcode/boot.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/boot.c,v 9.38 1987/06/22 20:19:58 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/boot.c,v 9.39 1987/10/09 16:09:14 jinx Rel $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -88,99 +88,145 @@ for details. They are created by defining a macro Command_Line_Args. #define STRING_SIZE 512 #define BLOCKSIZE 1024 #define blocks(n) ((n)*BLOCKSIZE) - + /* Utilities for command line parsing */ #define upcase(c) ((islower(c)) ? (toupper(c)) : c) void uppercase(to_where, from_where) -fast char *to_where, *from_where; -{ fast char c; - while((c = *from_where++) != '\0') *to_where++ = upcase(c); + fast char *to_where, *from_where; +{ + fast char c; + + while((c = *from_where++) != '\0') + { + *to_where++ = upcase(c); + } *to_where = '\0'; return; } - + int Parse_Option(opt_key, nargs, args, casep) -char *opt_key, **args; -Boolean casep; -int nargs; -{ int i; + char *opt_key, **args; + Boolean casep; + int nargs; +{ + int i; char key[STRING_SIZE], current[STRING_SIZE]; - if (casep) uppercase(key, opt_key); else strcpy(key, opt_key); + + if (casep) + { + uppercase(key, opt_key); + } + else + { + strcpy(key, opt_key); + } for(i = 0; i < nargs; i++) - { if (casep) uppercase(current, args[i]); else strcpy(current, args[i]); - if (strcmp(key, current) == 0) return i; + { + if (casep) + { + uppercase(current, args[i]); + } + else + { + strcpy(current, args[i]); + } + if (strcmp(key, current) == 0) + { + return i; + } } return NOT_THERE; } long Def_Number(key, nargs, args, def) -char *key, **args; -long def; -int nargs; -{ int position = Parse_Option(key, nargs, args, true); - if ((position == NOT_THERE) || (position == (nargs-1))) return def; - else return atoi(args[position+1]); + char *key, **args; + long def; + int nargs; +{ + int position; + + position = Parse_Option(key, nargs, args, true); + if ((position == NOT_THERE) || (position == (nargs-1))) + { + return def; + } + else + { + return atoi(args[position+1]); + } } -/* Obviously, the main program */ - /* Used to test whether it is a dumped executable version */ extern Boolean Was_Scheme_Dumped; Boolean Was_Scheme_Dumped = false; /* Exit is done in a different way on some operating systems (eg. VMS) */ -Exit_Scheme_Declarations; -/* Main program */ +Exit_Scheme_Declarations; forward void Start_Scheme(); extern void Clear_Memory(), Setup_Memory(), Reset_Memory(); + +/* + THE MAIN PROGRAM + */ main_type main(argc, argv) int argc; char **argv; { - Boolean FASL_It = false; - char *File_Name = NULL; + Boolean FASL_It; + char *File_Name; int Saved_Heap_Size, Saved_Stack_Size, Saved_Constant_Size; extern void compiler_initialize(); + FASL_It = false; + File_Name = NULL; Saved_argc = argc; Saved_argv = argv; - Init_Exit_Scheme(); if (argc > 2) - { int position; + { + int position; + if (((position = Parse_Option("-band", argc, argv, true)) != NOT_THERE) && (position != (argc-1))) + { File_Name = argv[position+1]; + } else if ((((position = Parse_Option("-fasl", argc, argv, true)) != NOT_THERE) || ((position = Parse_Option("fasl", argc, argv, true)) != NOT_THERE)) && (position != (argc-1))) - { File_Name = argv[position + 1]; + { + File_Name = argv[position + 1]; FASL_It = true; } } - else if ((argc == 2) && (argv[1][0] != '-')) File_Name = argv[1]; - + else if ((argc == 2) && (argv[1][0] != '-')) + { + File_Name = argv[1]; + } + if (!Was_Scheme_Dumped) - { Heap_Size = HEAP_SIZE; + { + Heap_Size = HEAP_SIZE; Stack_Size = STACK_SIZE; Constant_Size = CONSTANT_SIZE; } else - { Saved_Heap_Size = Heap_Size; + { + Saved_Heap_Size = Heap_Size; Saved_Stack_Size = Stack_Size; Saved_Constant_Size = Constant_Size; } @@ -190,12 +236,16 @@ main(argc, argv) Constant_Size = Def_Number("-constant", argc, argv, Constant_Size); if (Was_Scheme_Dumped) - { Boolean warned = false; + { + Boolean warned; + + warned = false; printf("Executable Scheme"); if ((Heap_Size != Saved_Heap_Size) || (Stack_Size != Saved_Stack_Size) || (Constant_Size != Saved_Constant_Size)) - { printf(".\n"); + { + printf(".\n"); fprintf(stderr, "Warning: Allocation parameters (heap, stack, and constant) ignored.\n"); Heap_Size = Saved_Heap_Size; @@ -204,13 +254,26 @@ main(argc, argv) warned = true; } if (File_Name == NULL) - { if (!warned) printf("; "); + { + if (!warned) + { + printf("; "); + } printf("Microcode Version %d.%d\n", VERSION, SUBVERSION); OS_Init(true); Enter_Interpreter(); } + +/* main continues on the next page */ + +/* main, continued */ + else - { if (!warned) printf(".\n"); + { + if (!warned) + { + printf(".\n"); + } Clear_Memory(blocks(Heap_Size), blocks(Stack_Size), blocks(Constant_Size)); /* We are reloading from scratch anyway. */ @@ -218,12 +281,12 @@ main(argc, argv) Start_Scheme((FASL_It ? BOOT_FASLOAD : BOOT_LOAD_BAND), File_Name); } } - if (File_Name == NULL) File_Name = DEFAULT_BAND_NAME; - Command_Line_Hook(); -/* main continues on the next page */ - -/* main, continued */ + if (File_Name == NULL) + { + File_Name = DEFAULT_BAND_NAME; + } + Command_Line_Hook(); Setup_Memory(blocks(Heap_Size), blocks(Stack_Size), blocks(Constant_Size)); @@ -232,49 +295,87 @@ main(argc, argv) } #define Default_Init_Fixed_Objects(Fixed_Objects) \ -{ Pointer Int_Vec, OB_Array, Error, Bad_Object, \ - The_Queue, *Dummy_Hist, The_Utilities; \ - fast long i; \ - /* Interrupt vector */ \ - Int_Vec = (Make_Pointer (TC_VECTOR, Free)); \ - *Free++ = (Make_Non_Pointer (TC_MANIFEST_VECTOR, \ - (MAX_INTERRUPT_NUMBER + 2))); \ - for (i = 0; (i <= (MAX_INTERRUPT_NUMBER + 1)); i += 1) *Free++ = NIL; \ - /* Error vector is not needed at boot time */ \ - Error = NIL; \ - /* Dummy History Structure */ \ - History = Make_Dummy_History(); \ - Dummy_Hist = Make_Dummy_History(); \ - /* OBArray */ \ - OB_Array = Make_Pointer(TC_VECTOR, Free); \ - *Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, OBARRAY_SIZE); \ - for (i=0; i < OBARRAY_SIZE; i++) *Free++ = NIL; \ - /* Initial empty work queue */ \ - The_Queue = Make_Pointer(TC_LIST, Free); \ - *Free++ = NIL; \ - *Free++ = NIL; \ - /* Empty utilities vector */ \ - The_Utilities = Make_Pointer(TC_VECTOR, Free); \ - *Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, 0); \ - \ - /* Now make the fixed objects vector */ \ - Fixed_Objects = Make_Pointer(TC_VECTOR, Free); \ - /* Create the vector with 4 extra slots for expansion and debugging. */ \ - *Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, (NFixed_Objects + 4)); \ - for (i=1; i <= (NFixed_Objects + 4); i++) *Free++ = NIL; \ - User_Vector_Set(Fixed_Objects, Non_Object, \ - (Make_Non_Pointer (TC_TRUE, 2))); \ - User_Vector_Set(Fixed_Objects, System_Interrupt_Vector, Int_Vec); \ - User_Vector_Set(Fixed_Objects, System_Error_Vector, Error); \ - User_Vector_Set(Fixed_Objects, OBArray, OB_Array); \ - User_Vector_Set(Fixed_Objects, Dummy_History, \ - Make_Pointer(TC_HUNK3, Dummy_Hist)); \ - User_Vector_Set(Fixed_Objects, State_Space_Tag, TRUTH); \ - User_Vector_Set(Fixed_Objects, Bignum_One, \ - Fix_To_Big(Make_Unsigned_Fixnum(1))); \ - User_Vector_Set(Fixed_Objects, Me_Myself, Fixed_Objects); \ - User_Vector_Set(Fixed_Objects, The_Work_Queue, The_Queue); \ - User_Vector_Set(Fixed_Objects, Utilities_Vector, The_Utilities); \ +{ \ + Fixed_Objects = make_fixed_objects_vector(); \ +} + +Pointer +make_fixed_objects_vector() +{ + fast Pointer fixed_objects_vector; + Pointer Int_Vec, OB_Array, Error, Bad_Object, + The_Queue, *Dummy_Hist, The_Utilities; + fast long i; + + /* Interrupt vector */ + + Int_Vec = (Make_Pointer (TC_VECTOR, Free)); + *Free++ = (Make_Non_Pointer (TC_MANIFEST_VECTOR, + (MAX_INTERRUPT_NUMBER + 2))); + for (i = 0; (i <= (MAX_INTERRUPT_NUMBER + 1)); i += 1) + { + *Free++ = NIL; + } + + /* Error vector is not needed at boot time */ + + Error = NIL; + + /* Dummy History Structure */ + + History = Make_Dummy_History(); + Dummy_Hist = Make_Dummy_History(); + + /* OBArray */ + + OB_Array = Make_Pointer(TC_VECTOR, Free); + *Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, OBARRAY_SIZE); + for (i = 0; i < OBARRAY_SIZE; i++) + { + *Free++ = NIL; + } + + /* Initial empty work queue */ + + The_Queue = Make_Pointer(TC_LIST, Free); + *Free++ = NIL; + *Free++ = NIL; + + /* Empty utilities vector */ + + The_Utilities = Make_Pointer(TC_VECTOR, Free); + *Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, 0); + + /* Cons the FIXED OBJECTS VECTOR */ + + fixed_objects_vector = Make_Pointer(TC_VECTOR, Free); + + /* Create the vector with 4 extra slots for expansion and + debugging. + */ + + *Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, (NFixed_Objects + 4)); + for (i=1; i <= (NFixed_Objects + 4); i++) + { + *Free++ = NIL; + } + + /* Initialize components */ + + User_Vector_Set(fixed_objects_vector, Non_Object, + (Make_Non_Pointer (TC_TRUE, 2))); + User_Vector_Set(fixed_objects_vector, System_Interrupt_Vector, Int_Vec); + User_Vector_Set(fixed_objects_vector, System_Error_Vector, Error); + User_Vector_Set(fixed_objects_vector, OBArray, OB_Array); + User_Vector_Set(fixed_objects_vector, Dummy_History, + Make_Pointer(UNMARKED_HISTORY_TYPE, Dummy_Hist)); + User_Vector_Set(fixed_objects_vector, State_Space_Tag, TRUTH); + User_Vector_Set(fixed_objects_vector, Bignum_One, + Fix_To_Big(Make_Unsigned_Fixnum(1))); + User_Vector_Set(fixed_objects_vector, Me_Myself, fixed_objects_vector); + User_Vector_Set(fixed_objects_vector, The_Work_Queue, The_Queue); + User_Vector_Set(fixed_objects_vector, Utilities_Vector, The_Utilities); + return fixed_objects_vector; } /* Boot Scheme */ @@ -287,11 +388,13 @@ Start_Scheme(Start_Prim, File_Name) extern Pointer make_primitive(); Pointer FName, Init_Prog, *Fasload_Call, prim; fast long i; - Boolean I_Am_Master; /* Butterfly test */ + Boolean I_Am_Master; /* Parallel processor test */ I_Am_Master = (Start_Prim != BOOT_GET_WORK); if (I_Am_Master) + { printf("Scheme Microcode Version %d.%d\n", VERSION, SUBVERSION); + } OS_Init(I_Am_Master); if (I_Am_Master) { @@ -387,117 +490,25 @@ Enter_Interpreter() /*NOTREACHED*/ } -#define IDENTITY_LENGTH 20 /* Plenty of room */ -#define ID_RELEASE 0 /* Scheme system release */ -#define ID_MICRO_VERSION 1 /* Microcode version */ -#define ID_MICRO_MOD 2 /* Microcode modification */ -#define ID_PRINTER_WIDTH 3 /* Width of console (chars) */ -#define ID_PRINTER_LENGTH 4 /* Height of console (chars) */ -#define ID_NEW_LINE_CHARACTER 5 /* #\Newline */ -#define ID_FLONUM_PRECISION 6 /* Flonum mantissa (bits) */ -#define ID_FLONUM_EXPONENT 7 /* Flonum exponent (bits) */ -#define ID_OS_NAME 8 /* OS name (string) */ -#define ID_OS_VARIANT 9 /* OS variant (string) */ - -Built_In_Primitive (Prim_Microcode_Identify, 0, "MICROCODE-IDENTIFY", 0xE5) -{ - Pointer *Result; - long i; - Primitive_0_Args (); - - Primitive_GC_If_Needed (IDENTITY_LENGTH + VECTOR_DATA); - Result = Free; - *Free++ = (Make_Non_Pointer (TC_MANIFEST_VECTOR, IDENTITY_LENGTH)); - for (i = 0; (i < IDENTITY_LENGTH); i += 1) - *Free++ = NIL; - Result[(ID_RELEASE + VECTOR_DATA)] - = (C_String_To_Scheme_String (RELEASE)); - Result[(ID_MICRO_VERSION + VECTOR_DATA)] - = (Make_Unsigned_Fixnum (VERSION)); - Result[(ID_MICRO_MOD + VECTOR_DATA)] - = (Make_Unsigned_Fixnum (SUBVERSION)); - Result[(ID_PRINTER_WIDTH + VECTOR_DATA)] - = (Make_Unsigned_Fixnum (NColumns ())); - Result[(ID_PRINTER_LENGTH + VECTOR_DATA)] - = (Make_Unsigned_Fixnum (NLines ())); - Result[(ID_NEW_LINE_CHARACTER + VECTOR_DATA)] - = (c_char_to_scheme_char ('\n')); - Result[(ID_FLONUM_PRECISION + VECTOR_DATA)] - = (Make_Unsigned_Fixnum (FLONUM_MANTISSA_BITS)); - Result[(ID_FLONUM_EXPONENT + VECTOR_DATA)] - = (Make_Unsigned_Fixnum (FLONUM_EXPT_SIZE)); - Result[(ID_OS_NAME + VECTOR_DATA)] - = (C_String_To_Scheme_String (OS_Name)); - Result[(ID_OS_VARIANT + VECTOR_DATA)] - = (C_String_To_Scheme_String (OS_Variant)); - return (Make_Pointer (TC_VECTOR, Result)); -} - -Built_In_Primitive(Prim_Microcode_Tables_Filename, - 0, "MICROCODE-TABLES-FILENAME", 0x180) -{ fast char *From, *To; - char *Prefix, *Suffix; - fast long Count; - long position; - Pointer Result; - Primitive_0_Args(); - - 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)))) - { Prefix = ""; - Suffix = Saved_argv[position + 1]; - } - else - { Prefix = SCHEME_SOURCES_PATH; - Suffix = UCODE_TABLES_FILENAME; - } - /* 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; - } - Primitive_GC_If_Needed(STRING_CHARS + - ((Count + sizeof(Pointer)) / - sizeof(Pointer))); - - /* Append both substrings. */ - Result = Make_Pointer(TC_CHARACTER_STRING, Free); - To = (char *) &(Free[STRING_CHARS]); - for (From = &(Prefix[0]); *From != '\0'; ) - { *To++ = *From++; - } - for (From = &(Suffix[0]); *From != '\0'; ) - { *To++ = *From++; - } - *To = '\0'; - Free += STRING_CHARS + ((Count + sizeof(Pointer)) / sizeof(Pointer)); - Vector_Set(Result, STRING_LENGTH, Make_Unsigned_Fixnum(Count)); - Vector_Set(Result, STRING_HEADER, - Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, - ((Free - Get_Pointer(Result)) - 1))); - return Result; -} - /*VARARGS1*/ term_type Microcode_Termination(Err, Micro_Error) -long Err, Micro_Error; -{ long value = 1; + long Err, Micro_Error; +{ + long value; Pointer Term_Vector; + + value = 1; if ((Err != TERM_HALT) && (Valid_Fixed_Obj_Vector()) && (Type_Code(Term_Vector = Get_Fixed_Obj_Slot(Termination_Proc_Vector)) == TC_VECTOR) && (Vector_Length(Term_Vector) > Err)) - { Pointer Handler = User_Vector_Ref(Term_Vector, Err); + { + Pointer Handler; + + Handler = User_Vector_Ref(Term_Vector, Err); if (Handler != NIL) { Will_Push(CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS + @@ -558,12 +569,13 @@ long Err, Micro_Error; Get_Integer(Fetch_Expression()), Space_Before_GC()); break; case TERM_HALT: - printf("User halt code."); + printf("Moriturus te saluto."); value = 0; break; case TERM_INVALID_TYPE_CODE: printf("Bad Type: check GC_Type map."); break; + case TERM_NO_ERROR_HANDLER: printf("No handler for error code: %d", Micro_Error); break; @@ -599,7 +611,8 @@ long Err, Micro_Error; } putchar ('\n'); if ((Trace_On_Error) && (Err != TERM_HALT)) - { printf( "\n\nStack trace:\n\n"); + { + printf( "\n\nStack trace:\n\n"); Back_Trace(); } OS_Flush_Output_Buffer(); @@ -608,3 +621,134 @@ long Err, Micro_Error; Exit_Hook(); Exit_Scheme(value); } + +/* Utility primitives. */ + +#define IDENTITY_LENGTH 20 /* Plenty of room */ +#define ID_RELEASE 0 /* Scheme system release */ +#define ID_MICRO_VERSION 1 /* Microcode version */ +#define ID_MICRO_MOD 2 /* Microcode modification */ +#define ID_PRINTER_WIDTH 3 /* Width of console (chars) */ +#define ID_PRINTER_LENGTH 4 /* Height of console (chars) */ +#define ID_NEW_LINE_CHARACTER 5 /* #\Newline */ +#define ID_FLONUM_PRECISION 6 /* Flonum mantissa (bits) */ +#define ID_FLONUM_EXPONENT 7 /* Flonum exponent (bits) */ +#define ID_OS_NAME 8 /* OS name (string) */ +#define ID_OS_VARIANT 9 /* OS variant (string) */ + +Built_In_Primitive (Prim_Microcode_Identify, 0, "MICROCODE-IDENTIFY", 0xE5) +{ + Pointer *Result; + long i; + Primitive_0_Args (); + + Primitive_GC_If_Needed (IDENTITY_LENGTH + VECTOR_DATA); + Result = Free; + *Free++ = (Make_Non_Pointer (TC_MANIFEST_VECTOR, IDENTITY_LENGTH)); + for (i = 0; (i < IDENTITY_LENGTH); i += 1) + { + *Free++ = NIL; + } + Result[(ID_RELEASE + VECTOR_DATA)] + = (C_String_To_Scheme_String (RELEASE)); + Result[(ID_MICRO_VERSION + VECTOR_DATA)] + = (Make_Unsigned_Fixnum (VERSION)); + Result[(ID_MICRO_MOD + VECTOR_DATA)] + = (Make_Unsigned_Fixnum (SUBVERSION)); + Result[(ID_PRINTER_WIDTH + VECTOR_DATA)] + = (Make_Unsigned_Fixnum (NColumns ())); + Result[(ID_PRINTER_LENGTH + VECTOR_DATA)] + = (Make_Unsigned_Fixnum (NLines ())); + Result[(ID_NEW_LINE_CHARACTER + VECTOR_DATA)] + = (c_char_to_scheme_char ('\n')); + Result[(ID_FLONUM_PRECISION + VECTOR_DATA)] + = (Make_Unsigned_Fixnum (FLONUM_MANTISSA_BITS)); + Result[(ID_FLONUM_EXPONENT + VECTOR_DATA)] + = (Make_Unsigned_Fixnum (FLONUM_EXPT_SIZE)); + Result[(ID_OS_NAME + VECTOR_DATA)] + = (C_String_To_Scheme_String (OS_Name)); + Result[(ID_OS_VARIANT + VECTOR_DATA)] + = (C_String_To_Scheme_String (OS_Variant)); + return (Make_Pointer (TC_VECTOR, Result)); +} + +Built_In_Primitive(Prim_Microcode_Tables_Filename, + 0, "MICROCODE-TABLES-FILENAME", 0x180) +{ + fast char *From, *To; + char *Prefix, *Suffix; + fast long Count; + long position; + Pointer Result; + Primitive_0_Args(); + + 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)))) + { + Prefix = ""; + Suffix = Saved_argv[position + 1]; + } + else + { + Prefix = SCHEME_SOURCES_PATH; + Suffix = UCODE_TABLES_FILENAME; + } + + /* 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; + } + Primitive_GC_If_Needed(STRING_CHARS + + ((Count + sizeof(Pointer)) / + sizeof(Pointer))); + + /* Append both substrings. */ + + Result = Make_Pointer(TC_CHARACTER_STRING, Free); + To = (char *) &(Free[STRING_CHARS]); + for (From = &(Prefix[0]); *From != '\0'; ) + { + *To++ = *From++; + } + for (From = &(Suffix[0]); *From != '\0'; ) + { + *To++ = *From++; + } + *To = '\0'; + Free += STRING_CHARS + ((Count + sizeof(Pointer)) / sizeof(Pointer)); + Vector_Set(Result, STRING_LENGTH, Make_Unsigned_Fixnum(Count)); + Vector_Set(Result, STRING_HEADER, + Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, + ((Free - Get_Pointer(Result)) - 1))); + return Result; +} + +Built_In_Primitive(Prim_Get_Command_Line, 0, "GET-COMMAND-LINE", 0x25) +{ + fast int i; + Pointer result; + Primitive_0_Args(); + + Primitive_GC_If_Needed(1 + Saved_argc); + + result = Make_Pointer(TC_VECTOR, Free); + *Free = Make_Non_Pointer(TC_MANIFEST_VECTOR, Saved_argc); + Free += (1 + Saved_argc); + + for (i = 0; i < Saved_argc; i++) + { + User_Vector_Set(result, i, C_String_To_Scheme_String(Saved_argv[i])); + } + return result; +} diff --git a/v7/src/microcode/future.c b/v7/src/microcode/future.c index aba0150ca..0448d92e2 100644 --- a/v7/src/microcode/future.c +++ b/v7/src/microcode/future.c @@ -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/future.c,v 9.23 1987/07/07 02:37:36 jinx Rel $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/future.c,v 9.24 1987/10/09 16:10:27 jinx Rel $ Support code for futures */ @@ -62,16 +62,20 @@ where is #!false if no value is known yet, and where is #!true if someone wants slot kept for a time. */ - + Define_Primitive(Prim_Touch, 1, "TOUCH") -{ Pointer Result; +{ + Pointer Result; Primitive_1_Arg(); + Touch_In_Primitive(Arg1, Result); return Result; } Define_Primitive(Prim_Future_P, 1, "FUTURE?") -{ Primitive_1_Arg(); +{ + Primitive_1_Arg(); + return (Type_Code(Arg1) == TC_FUTURE) ? TRUTH : NIL; } @@ -79,10 +83,12 @@ Define_Primitive(Prim_Future_P, 1, "FUTURE?") equal operators. */ -long Set_If_Equal(Base, Offset, New, Wanted) -Pointer Base, Wanted, New; -long Offset; -{ Lock_Handle lock; +long +Set_If_Equal(Base, Offset, New, Wanted) + Pointer Base, Wanted, New; + long Offset; +{ + Lock_Handle lock; Pointer Old_Value, Desired, Remember_Value; long success; @@ -92,83 +98,122 @@ Try_Again: Touch_In_Primitive(Remember_Value, Old_Value); lock = Lock_Cell(Nth_Vector_Loc(Base, Offset)); if (Remember_Value != Fast_Vector_Ref(Base, Offset)) - { Unlock_Cell(lock); + { + Unlock_Cell(lock); goto Try_Again; } if (Old_Value == Desired) - { Do_Store_No_Lock(Nth_Vector_Loc(Base, Offset), New); + { + Do_Store_No_Lock(Nth_Vector_Loc(Base, Offset), New); success = true; } - else success = false; + else + { + success = false; + } Unlock_Cell(lock); return success; } - -Define_Primitive(Prim_Set_Car_If_Eq, 3, "SET-CAR-IF-EQ?!") + /* (SET-CAR-IF-EQ?! ) Replaces the CAR of with if it used to contain . The value returned is either (if the modification takes place) or '() if it does not. */ -{ Primitive_3_Args(); +Define_Primitive(Prim_Set_Car_If_Eq, 3, "SET-CAR-IF-EQ?!") +{ + Primitive_3_Args(); + Arg_1_Type(TC_LIST); - if (Set_If_Equal(Arg1, CONS_CAR, Arg2, Arg3)) return Arg1; - else return NIL; + if (Set_If_Equal(Arg1, CONS_CAR, Arg2, Arg3)) + { + return Arg1; + } + else + { + return NIL; + } } - -Define_Primitive(Prim_Set_Cdr_If_Eq, 3, "SET-CDR-IF-EQ?!") + /* (SET-CDR-IF-EQ?! ) Replaces the CDR of with if it used to contain . The value returned is either (if the modification takes place) or '() if it does not. */ -{ Primitive_3_Args(); +Define_Primitive(Prim_Set_Cdr_If_Eq, 3, "SET-CDR-IF-EQ?!") +{ + Primitive_3_Args(); Arg_1_Type(TC_LIST); - if (Set_If_Equal(Arg1, CONS_CDR, Arg2, Arg3)) return Arg1; - else return NIL; -} -Define_Primitive(Prim_Vector_Set_If_Eq, 4, "VECTOR-SET-IF-EQ?!") + if (Set_If_Equal(Arg1, CONS_CDR, Arg2, Arg3)) + { + return Arg1; + } + else + { + return NIL; + } +} + /* (VECTOR-SET-IF-EQ?! ) Replaces the th element of with if it used to contain . The value returned is either (if the modification takes place) or '() if it does not. */ -{ long Offset; +Define_Primitive(Prim_Vector_Set_If_Eq, 4, "VECTOR-SET-IF-EQ?!") +{ + long Offset; Primitive_4_Args(); + Arg_1_Type(TC_VECTOR); Arg_2_Type(TC_FIXNUM); Range_Check(Offset, Arg2, 0, Vector_Length(Arg1)-1, ERR_ARG_2_BAD_RANGE); - if (Set_If_Equal(Arg1, Offset, Arg3, Arg4)) return Arg1; - else return NIL; + if (Set_If_Equal(Arg1, Offset, Arg3, Arg4)) + { + return Arg1; + } + else + { + return NIL; + } } -Define_Primitive(Prim_Set_Cxr_If_Eq, 4, "SET-CXR-IF-EQ?!") /* (SET-CXR-IF-EQ?! ) Replaces the th CXR of with if it used to contain . The value returned is either (if the modification takes place) or '() if it does not. */ -{ Pointer Arg4; +Define_Primitive(Prim_Set_Cxr_If_Eq, 4, "SET-CXR-IF-EQ?!") +{ + Pointer Arg4; long Offset; Primitive_3_Args(); + Arg4 = Stack_Ref(3); Arg_1_Type(TC_HUNK3); Arg_2_Type(TC_FIXNUM); Range_Check(Offset, Arg2, 0, 2, ERR_ARG_2_BAD_RANGE); - if (Set_If_Equal(Arg1, Offset, Arg3, Arg4)) return Arg1; - else return NIL; + if (Set_If_Equal(Arg1, Offset, Arg3, Arg4)) + { + return Arg1; + } + else + { + return NIL; + } } -Define_Primitive(Prim_Future_Ref, 2, "FUTURE-REF") /* (FUTURE-REF ) Returns the th slot from the future object. This is the equivalent of SYSTEM-VECTOR-REF but works only on future objects and doesn't touch. */ -{ long Offset; +Define_Primitive(Prim_Future_Ref, 2, "FUTURE-REF") +{ + long Offset; Primitive_2_Args(); + Arg_1_Type(TC_FUTURE); Arg_2_Type(TC_FIXNUM); Range_Check(Offset, Arg2, @@ -176,15 +221,17 @@ Define_Primitive(Prim_Future_Ref, 2, "FUTURE-REF") return User_Vector_Ref(Arg1, Offset); } -Define_Primitive(Prim_Future_Set, 3, "FUTURE-SET!") /* (FUTURE-SET! ) Modifies the th slot from the future object. This is the equivalent of SYSTEM-VECTOR-SET! but works only on future objects and doesn't touch. */ -{ long Offset; +Define_Primitive(Prim_Future_Set, 3, "FUTURE-SET!") +{ + long Offset; Pointer Result; Primitive_3_Args(); + Arg_1_Type(TC_FUTURE); Arg_2_Type(TC_FIXNUM); Range_Check(Offset, Arg2, @@ -193,19 +240,20 @@ Define_Primitive(Prim_Future_Set, 3, "FUTURE-SET!") User_Vector_Set(Arg1, Offset,Arg3); return Result; } - -Define_Primitive(Prim_Future_Size, 1, "FUTURE-SIZE") + /* (FUTURE-SIZE ) Returns the number of slots in the future object. This is the equivalent of SYSTEM-VECTOR-SIZE but works only on future objects and doesn't touch. */ -{ Primitive_1_Arg(); +Define_Primitive(Prim_Future_Size, 1, "FUTURE-SIZE") +{ + Primitive_1_Arg(); + Arg_1_Type(TC_FUTURE); return Make_Unsigned_Fixnum(Vector_Length(Arg1)); } - -Define_Primitive(Prim_Lock_Future, 1, "LOCK-FUTURE!") + /* (LOCK-FUTURE! ) Sets the lock flag on the future object, so that it won't be spliced-out by the garbage collector. Returns #!false if the @@ -214,85 +262,132 @@ Define_Primitive(Prim_Lock_Future, 1, "LOCK-FUTURE!") for the lock to take, since Scheme code operates while locked. Opposite of UNLOCK-FUTURE!. */ -{ Primitive_1_Arg(); - if (Type_Code(Arg1) != TC_FUTURE) return NIL; + +Define_Primitive(Prim_Lock_Future, 1, "LOCK-FUTURE!") +{ + Primitive_1_Arg(); + + if (Type_Code(Arg1) != TC_FUTURE) + { + return NIL; + } while ((IntEnb & IntCode) == 0) + { if (Swap_Pointers(Nth_Vector_Loc(Arg1, FUTURE_LOCK), TRUTH) == NIL) - return TRUTH; - else Sleep(CONTENTION_DELAY); + { + return TRUTH; + } + else + { + Sleep(CONTENTION_DELAY); + } + } Primitive_Interrupt(); } -Define_Primitive(Prim_Unlock_Future, 1, "UNLOCK-FUTURE!") /* (UNLOCK-FUTURE! ) Clears the lock flag on a locked future object, otherwise nothing. */ -{ Primitive_1_Arg(); - if (Type_Code(Arg1) != TC_FUTURE) return NIL; + +Define_Primitive(Prim_Unlock_Future, 1, "UNLOCK-FUTURE!") +{ + Primitive_1_Arg(); + + if (Type_Code(Arg1) != TC_FUTURE) + { + return NIL; + } if (!Future_Is_Locked(Arg1)) - Primitive_Error(ERR_ARG_1_WRONG_TYPE) + { + Primitive_Error(ERR_ARG_1_WRONG_TYPE); + } else - { Vector_Set(Arg1, FUTURE_LOCK, NIL); + { + Vector_Set(Arg1, FUTURE_LOCK, NIL); return TRUTH; - }; + } } -Define_Primitive(Prim_Future_To_Vector, 1, "FUTURE->VECTOR") /* (FUTURE->VECTOR ) Create a COPY of but with type code vector. */ -{ Pointer Result = Make_Pointer(TC_VECTOR, Free); +Define_Primitive(Prim_Future_To_Vector, 1, "FUTURE->VECTOR") +{ + Pointer Result; long Size, i; Primitive_1_Arg(); - if (Type_Code(Arg1) != TC_FUTURE) return NIL; + + Result = Make_Pointer(TC_VECTOR, Free); + if (Type_Code(Arg1) != TC_FUTURE) + { + return NIL; + } Size = Vector_Length(Arg1); Primitive_GC_If_Needed(Size + 1); - for (i=0; i <= Size; i++) *Free++ = Vector_Ref(Arg1, i); + for (i = 0; i <= Size; i++) + { + *Free++ = Vector_Ref(Arg1, i); + } return Result; } Define_Primitive(Prim_Future_Eq, 2, "NON-TOUCHING-EQ?") -{ Primitive_2_Args(); +{ + Primitive_2_Args(); + return ((Arg1==Arg2) ? TRUTH : NIL); } - + /* MAKE-INITIAL-PROCESS is called to create a small stacklet which * will just call the specified thunk and then end the computation */ Define_Primitive(Prim_Make_Initial_Process, 1, "MAKE-INITIAL-PROCESS") -{ Pointer Result; - long Useful_Length, Allocated_Length, Waste_Length; +{ + Pointer Result; + long Useful_Length; Primitive_1_Arg(); Result = Make_Pointer(TC_CONTROL_POINT, Free); - Useful_Length = 3*CONTINUATION_SIZE+STACK_ENV_EXTRA_SLOTS+1; + Useful_Length = (3 * CONTINUATION_SIZE) + STACK_ENV_EXTRA_SLOTS + 1; + #ifdef USE_STACKLETS - if ((Useful_Length+STACKLET_SLACK+STACKLET_HEADER_SIZE) < - Default_Stacklet_Size) + +{ + long Allocated_Length, Waste_Length; + + Allocated_Length = (Useful_Length + STACKLET_SLACK + STACKLET_HEADER_SIZE); + if (Allocated_Length < Default_Stacklet_Size) + { Allocated_Length = Default_Stacklet_Size; - else Allocated_Length = - Useful_Length+STACKLET_SLACK+STACKLET_HEADER_SIZE; - Primitive_GC_If_Needed(Allocated_Length+1); - Waste_Length = (Allocated_Length-Useful_Length-STACKLET_HEADER_SIZE)+1; + Waste_Length = ((Allocated_Length + 1) - + (Useful_Length + STACKLET_HEADER_SIZE)); + } + else + { + Waste_Length = (STACKLET_SLACK + 1); + } + Primitive_GC_If_Needed(Allocated_Length + 1); Free[STACKLET_LENGTH] = Make_Pointer(TC_MANIFEST_VECTOR, Allocated_Length); + Free[STACKLET_REUSE_FLAG] = TRUTH; Free[STACKLET_UNUSED_LENGTH] = - DANGER_BIT | (Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, - Waste_Length)); - Free += Allocated_Length-Useful_Length+1; -#else + Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, Waste_Length); + Free += (Allocated_Length + 1) - Useful_Length; +} + +#else /* not USE_STACKLETS */ + Free[STACKLET_LENGTH] = Make_Non_Pointer(TC_MANIFEST_VECTOR, Useful_Length + STACKLET_HEADER_SIZE - 1); + Free[STACKLET_REUSE_FLAG] = NIL; Free[STACKLET_UNUSED_LENGTH] = Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, 0); Free += STACKLET_HEADER_SIZE; -#endif -/* Make_Initial_Process continues on the next page */ - -/* Make_Initial_Process continued */ + +#endif /* USE_STACKLETS */ Free[CONTINUATION_EXPRESSION] = Make_Non_Pointer(TC_FIXNUM, IntEnb); Free[CONTINUATION_RETURN_CODE] = @@ -320,45 +415,47 @@ Define_Primitive(Prim_Make_Initial_Process, 1, "MAKE-INITIAL-PROCESS") */ Define_Primitive(Prim_Make_Cheap_Future, 3, "MAKE-CHEAP-FUTURE") -{ Pointer The_Future; +{ + Pointer The_Future; Pointer IO_Vector, IO_Cons, IO_Hunk3, Empty_Queue, IO_String; Primitive_3_Args(); Primitive_GC_If_Needed(21); - Empty_Queue=Make_Pointer(TC_LIST,Free); - *Free++=NIL; - *Free++=NIL; - - IO_String=Make_Pointer(TC_CHARACTER_STRING,Free); - *Free++=Make_Non_Pointer(TC_MANIFEST_NM_VECTOR,1); - *Free++=Make_Unsigned_Fixnum(0); - - IO_Cons=Make_Pointer(TC_LIST,Free); - *Free++=Make_Unsigned_Fixnum(0); - *Free++=IO_String; - - IO_Hunk3=Make_Pointer(TC_HUNK3,Free); - *Free++=NIL; - *Free++=Arg3; - *Free++=IO_Cons; - - IO_Vector=Make_Pointer(TC_VECTOR,Free); - *Free++=Make_Non_Pointer(TC_MANIFEST_VECTOR,1); - *Free++=IO_Hunk3; - - The_Future=Make_Pointer(TC_FUTURE,Free); - *Free++=Make_Non_Pointer(TC_MANIFEST_VECTOR,10); - *Free++=NIL; /* No value yet. */ - *Free++=NIL; /* Not locked. */ - *Free++=Empty_Queue; /* Put the empty queue here. */ - *Free++=Arg1; /* The process slot. */ - *Free++=TRUTH; /* Status slot. */ - *Free++=Arg2; /* Original code. */ - *Free++=IO_Vector; /* Put the I/O system stuff here. */ - *Free++=NIL; /* Waiting on list. */ - *Free++=New_Future_Number(); /* Metering number. */ - *Free++=NIL; /* User data slot */ - - return The_Future; } + Empty_Queue = Make_Pointer(TC_LIST,Free); + *Free++ = NIL; + *Free++ = NIL; + + IO_String = Make_Pointer(TC_CHARACTER_STRING,Free); + *Free++ = Make_Non_Pointer(TC_MANIFEST_NM_VECTOR,1); + *Free++ = Make_Unsigned_Fixnum(0); + + IO_Cons = Make_Pointer(TC_LIST,Free); + *Free++ = Make_Unsigned_Fixnum(0); + *Free++ = IO_String; + + IO_Hunk3 = Make_Pointer(TC_HUNK3,Free); + *Free++ = NIL; + *Free++ = Arg3; + *Free++ = IO_Cons; + + IO_Vector = Make_Pointer(TC_VECTOR,Free); + *Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR,1); + *Free++ = IO_Hunk3; + + The_Future = Make_Pointer(TC_FUTURE,Free); + *Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR,10); + *Free++ = NIL; /* No value yet. */ + *Free++ = NIL; /* Not locked. */ + *Free++ = Empty_Queue; /* Put the empty queue here. */ + *Free++ = Arg1; /* The process slot. */ + *Free++ = TRUTH; /* Status slot. */ + *Free++ = Arg2; /* Original code. */ + *Free++ = IO_Vector; /* Put the I/O system stuff here. */ + *Free++ = NIL; /* Waiting on list. */ + *Free++ = New_Future_Number(); /* Metering number. */ + *Free++ = NIL; /* User data slot */ + + return The_Future; +} diff --git a/v7/src/microcode/gc.h b/v7/src/microcode/gc.h index abdd9ad5e..9c43463cb 100644 --- a/v7/src/microcode/gc.h +++ b/v7/src/microcode/gc.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/gc.h,v 9.22 1987/04/03 00:13:13 jinx Rel $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/gc.h,v 9.23 1987/10/09 16:10:46 jinx Rel $ * * Garbage collection related macros of sufficient utility to be * included in all compilations. @@ -56,7 +56,7 @@ MIT in each case. */ (fprintf(stderr, "Bad Type code = 0x%02x\n", TC), \ Invalid_Type_Code(), GC_Undefined)) -#define GC_Type(Object) GC_Type_Code(Safe_Type_Code(Object)) +#define GC_Type(Object) GC_Type_Code(OBJECT_TYPE(Object)) #define GC_Type_Non_Pointer(Object) (GC_Type(Object) == GC_Non_Pointer) #define GC_Type_Cell(Object) (GC_Type(Object) == GC_Cell) diff --git a/v7/src/microcode/gccode.h b/v7/src/microcode/gccode.h index d95a29a85..a5249846d 100644 --- a/v7/src/microcode/gccode.h +++ b/v7/src/microcode/gccode.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/gccode.h,v 9.29 1987/10/05 18:32:24 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/gccode.h,v 9.30 1987/10/09 16:10:56 jinx Rel $ * * This file contains the macros for use in code which does GC-like * loops over memory. It is only included in a few files, unlike @@ -45,7 +45,7 @@ MIT in each case. */ */ #define Switch_by_GC_Type(P) \ - switch(Safe_Type_Code(P)) + switch(OBJECT_TYPE(P)) #define case_simple_Non_Pointer \ case TC_NULL: \ diff --git a/v7/src/microcode/gctype.c b/v7/src/microcode/gctype.c index fc73eeb9d..df523f591 100644 --- a/v7/src/microcode/gctype.c +++ b/v7/src/microcode/gctype.c @@ -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/gctype.c,v 9.24 1987/10/05 18:32:37 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/gctype.c,v 9.25 1987/10/09 16:11:06 jinx Rel $ * * This file contains the table which maps between Types and * GC Types. @@ -41,7 +41,7 @@ MIT in each case. */ /* Mapping GC_Type to Type_Codes */ /*********************************/ -int GC_Type_Map[MAX_SAFE_TYPE + 1] = { +int GC_Type_Map[MAX_TYPE_CODE + 1] = { GC_Non_Pointer, /* TC_NULL,etc */ GC_Pair, /* TC_LIST */ GC_Non_Pointer, /* TC_CHARACTER */ @@ -179,9 +179,141 @@ int GC_Type_Map[MAX_SAFE_TYPE + 1] = { GC_Undefined, /* 0x7C */ GC_Undefined, /* 0x7D */ GC_Undefined, /* 0x7E */ - GC_Undefined /* 0x7F */ + GC_Undefined, /* 0x7F */ + + GC_Undefined, /* 0x80 */ + GC_Undefined, /* 0x81 */ + GC_Undefined, /* 0x82 */ + GC_Undefined, /* 0x83 */ + GC_Undefined, /* 0x84 */ + GC_Undefined, /* 0x85 */ + GC_Undefined, /* 0x86 */ + GC_Undefined, /* 0x87 */ + GC_Undefined, /* 0x88 */ + GC_Undefined, /* 0x89 */ + GC_Undefined, /* 0x8A */ + GC_Undefined, /* 0x8B */ + GC_Undefined, /* 0x8C */ + GC_Undefined, /* 0x8D */ + GC_Undefined, /* 0x8E */ + GC_Undefined, /* 0x8F */ + GC_Undefined, /* 0x90 */ + GC_Undefined, /* 0x91 */ + GC_Undefined, /* 0x92 */ + GC_Undefined, /* 0x93 */ + GC_Undefined, /* 0x94 */ + GC_Undefined, /* 0x95 */ + GC_Undefined, /* 0x96 */ + GC_Undefined, /* 0x97 */ + GC_Undefined, /* 0x98 */ + GC_Undefined, /* 0x99 */ + GC_Undefined, /* 0x9A */ + GC_Undefined, /* 0x9B */ + GC_Undefined, /* 0x9C */ + GC_Undefined, /* 0x9D */ + GC_Undefined, /* 0x9E */ + GC_Undefined, /* 0x9F */ + GC_Undefined, /* 0xA0 */ + GC_Undefined, /* 0xA1 */ + GC_Undefined, /* 0xA2 */ + GC_Undefined, /* 0xA3 */ + GC_Undefined, /* 0xA4 */ + GC_Undefined, /* 0xA5 */ + GC_Undefined, /* 0xA6 */ + GC_Undefined, /* 0xA7 */ + GC_Undefined, /* 0xA8 */ + GC_Undefined, /* 0xA9 */ + GC_Undefined, /* 0xAA */ + GC_Undefined, /* 0xAB */ + GC_Undefined, /* 0xAC */ + GC_Undefined, /* 0xAD */ + GC_Undefined, /* 0xAE */ + GC_Undefined, /* 0xAF */ + + GC_Undefined, /* 0xB0 */ + GC_Undefined, /* 0xB1 */ + GC_Undefined, /* 0xB2 */ + GC_Undefined, /* 0xB3 */ + GC_Undefined, /* 0xB4 */ + GC_Undefined, /* 0xB5 */ + GC_Undefined, /* 0xB6 */ + GC_Undefined, /* 0xB7 */ + GC_Undefined, /* 0xB8 */ + GC_Undefined, /* 0xB9 */ + GC_Undefined, /* 0xBA */ + GC_Undefined, /* 0xBB */ + GC_Undefined, /* 0xBC */ + GC_Undefined, /* 0xBD */ + GC_Undefined, /* 0xBE */ + GC_Undefined, /* 0xBF */ + GC_Undefined, /* 0xC0 */ + GC_Undefined, /* 0xC1 */ + GC_Undefined, /* 0xC2 */ + GC_Undefined, /* 0xC3 */ + GC_Undefined, /* 0xC4 */ + GC_Undefined, /* 0xC5 */ + GC_Undefined, /* 0xC6 */ + GC_Undefined, /* 0xC7 */ + GC_Undefined, /* 0xC8 */ + GC_Undefined, /* 0xC9 */ + GC_Undefined, /* 0xCA */ + GC_Undefined, /* 0xCB */ + GC_Undefined, /* 0xCC */ + GC_Undefined, /* 0xCD */ + GC_Undefined, /* 0xCE */ + GC_Undefined, /* 0xCF */ + GC_Undefined, /* 0xD0 */ + GC_Undefined, /* 0xD1 */ + GC_Undefined, /* 0xD2 */ + GC_Undefined, /* 0xD3 */ + GC_Undefined, /* 0xD4 */ + GC_Undefined, /* 0xD5 */ + GC_Undefined, /* 0xD6 */ + GC_Undefined, /* 0xD7 */ + GC_Undefined, /* 0xD8 */ + GC_Undefined, /* 0xD9 */ + GC_Undefined, /* 0xDA */ + GC_Undefined, /* 0xDB */ + GC_Undefined, /* 0xDC */ + GC_Undefined, /* 0xDD */ + GC_Undefined, /* 0xDE */ + GC_Undefined, /* 0xDF */ + + GC_Undefined, /* 0xE0 */ + GC_Undefined, /* 0xE1 */ + GC_Undefined, /* 0xE2 */ + GC_Undefined, /* 0xE3 */ + GC_Undefined, /* 0xE4 */ + GC_Undefined, /* 0xE5 */ + GC_Undefined, /* 0xE6 */ + GC_Undefined, /* 0xE7 */ + GC_Undefined, /* 0xE8 */ + GC_Undefined, /* 0xE9 */ + GC_Undefined, /* 0xEA */ + GC_Undefined, /* 0xEB */ + GC_Undefined, /* 0xEC */ + GC_Undefined, /* 0xED */ + GC_Undefined, /* 0xEE */ + GC_Undefined, /* 0xEF */ + GC_Undefined, /* 0xF0 */ + GC_Undefined, /* 0xF1 */ + GC_Undefined, /* 0xF2 */ + GC_Undefined, /* 0xF3 */ + GC_Undefined, /* 0xF4 */ + GC_Undefined, /* 0xF5 */ + GC_Undefined, /* 0xF6 */ + GC_Undefined, /* 0xF7 */ + GC_Undefined, /* 0xF8 */ + GC_Undefined, /* 0xF9 */ + GC_Undefined, /* 0xFA */ + GC_Undefined, /* 0xFB */ + GC_Undefined, /* 0xFC */ + GC_Undefined, /* 0xFD */ + GC_Undefined, /* 0xFE */ + GC_Undefined /* 0xFF */ }; -#if (MAX_SAFE_TYPE != 0x7F) +#if (MAX_TYPE_CODE != 0xFF) #include "gctype.c and scheme.h inconsistent -- GC_Type_Map" #endif + diff --git a/v7/src/microcode/history.h b/v7/src/microcode/history.h index 3c1da862e..8e6bb4db9 100644 --- a/v7/src/microcode/history.h +++ b/v7/src/microcode/history.h @@ -30,12 +30,12 @@ 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/history.h,v 9.22 1987/04/16 02:23:38 jinx Rel $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/history.h,v 9.23 1987/10/09 16:11:17 jinx Rel $ * * History maintenance data structures and support. * */ - + /* * The history consists of a "vertebra" which is a doubly linked ring, * each entry pointing to a "rib". The rib consists of a singly @@ -52,6 +52,25 @@ MIT in each case. */ #define RIB_NEXT_REDUCTION 2 #define RIB_MARK 2 +#define HISTORY_MARK_TYPE (UNMARKED_HISTORY_TYPE ^ MARKED_HISTORY_TYPE) +#define HISTORY_MARK_MASK (HISTORY_MARK_TYPE << ADDRESS_LENGTH) + +#if ((UNMARKED_HISTORY_TYPE | HISTORY_MARK_TYPE) != MARKED_HISTORY_TYPE) +#include "error: Bad history types in types.h and history.h" +#endif + +#define HISTORY_MARK(object) \ +{ \ + (object) |= (HISTORY_MARK_MASK); \ +} + +#define HISTORY_UNMARK(object) \ +{ \ + (object) &= (~HISTORY_MARK_MASK); \ +} + +#define HISTORY_MARKED_P(object) ((object) & HISTORY_MARK_MASK) + /* Save_History places a restore history frame on the stack. Such a * frame consists of a normal continuation frame plus a pointer to the * stacklet on which the last restore history is located and the @@ -69,7 +88,7 @@ MIT in each case. */ Push(Make_Pointer(TC_CONTROL_POINT, \ Prev_Restore_History_Stacklet)); \ Push(Make_Non_Pointer(TC_FIXNUM, Prev_Restore_History_Offset)); \ - Store_Expression(Make_Pointer(TC_HUNK3, History)); \ + Store_Expression(Make_Pointer(UNMARKED_HISTORY_TYPE, History)); \ Store_Return((Return_Code)); \ Save_Cont(); \ History = Get_Pointer(Get_Fixed_Obj_Slot(Dummy_History)); \ @@ -79,42 +98,52 @@ MIT in each case. */ #ifdef COMPILE_HISTORY #define New_Subproblem(Expr, Env) \ -{ fast Pointer *Rib; \ +{ \ + fast Pointer *Rib; \ + \ History = Get_Pointer(History[HIST_NEXT_SUBPROBLEM]); \ - History[HIST_MARK] |= DANGER_BIT; \ + HISTORY_MARK(History[HIST_MARK]); \ Rib = Get_Pointer(History[HIST_RIB]); \ - Rib[RIB_MARK] |= DANGER_BIT; \ + HISTORY_MARK(Rib[RIB_MARK]); \ Rib[RIB_ENV] = Env; \ Rib[RIB_EXP] = Expr; \ } #define Reuse_Subproblem(Expr, Env) \ -{ fast Pointer *Rib; \ +{ \ + fast Pointer *Rib; \ + \ Rib = Get_Pointer(History[HIST_RIB]); \ - Rib[RIB_MARK] |= DANGER_BIT; \ + HISTORY_MARK(Rib[RIB_MARK]); \ Rib[RIB_ENV] = Env; \ Rib[RIB_EXP] = Expr; \ } #define New_Reduction(Expr, Env) \ -{ fast Pointer *Rib; \ +{ \ + fast Pointer *Rib; \ + \ Rib = Get_Pointer(Fast_Vector_Ref(History[HIST_RIB], \ RIB_NEXT_REDUCTION)); \ - History[HIST_RIB] = Make_Pointer(TC_HUNK3, Rib); \ + History[HIST_RIB] = Make_Pointer(UNMARKED_HISTORY_TYPE, Rib); \ Rib[RIB_ENV] = Env; \ Rib[RIB_EXP] = Expr; \ - Rib[RIB_MARK] &= ~DANGER_BIT; \ + HISTORY_UNMARK(Rib[RIB_MARK]); \ } #define End_Subproblem() \ - History[HIST_MARK] &= ~DANGER_BIT; \ - History = Get_Pointer(History[HIST_PREV_SUBPROBLEM]); +{ \ + HISTORY_UNMARK(History[HIST_MARK]); \ + History = Get_Pointer(History[HIST_PREV_SUBPROBLEM]); \ +} + +#else /* not COMPILE_HISTORY */ -#else /* COMPILE_HISTORY */ #define New_Subproblem(Expr, Env) { } #define Reuse_Subproblem(Expr, Env) { } #define New_Reduction(Expr, Env) { } #define End_Subproblem() { } + #endif /* COMPILE_HISTORY */ /* History manipulation for the compiled code interface. */ @@ -122,22 +151,25 @@ MIT in each case. */ #ifdef COMPILE_HISTORY #define Compiler_New_Reduction() \ -{ New_Reduction(NIL, \ +{ \ + New_Reduction(NIL, \ Make_Non_Pointer(TC_RETURN_CODE, \ RC_POP_FROM_COMPILED_CODE)); \ } #define Compiler_New_Subproblem() \ -{ New_Subproblem(NIL, \ +{ \ + New_Subproblem(NIL, \ Make_Non_Pointer(TC_RETURN_CODE, \ RC_POP_FROM_COMPILED_CODE)); \ } #define Compiler_End_Subproblem() \ -{ End_Subproblem(); \ +{ \ + End_Subproblem(); \ } -#else /* COMPILE_HISTORY */ +#else /* not COMPILE_HISTORY */ #define Compiler_New_Reduction() #define Compiler_New_Subproblem() diff --git a/v7/src/microcode/hooks.c b/v7/src/microcode/hooks.c index cb33b0ce7..d79e104d6 100644 --- a/v7/src/microcode/hooks.c +++ b/v7/src/microcode/hooks.c @@ -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/hooks.c,v 9.25 1987/08/01 06:56:26 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/hooks.c,v 9.26 1987/10/09 16:11:27 jinx Rel $ * * This file contains various hooks and handles which connect the * primitives with the main interpreter. @@ -39,6 +39,7 @@ MIT in each case. */ #include "scheme.h" #include "primitive.h" #include "winder.h" +#include "history.h" /* (APPLY FN LIST-OF-ARGUMENTS) Calls the function FN to the arguments specified in the list @@ -116,86 +117,97 @@ Built_In_Primitive(Prim_Apply, 2, "APPLY", 0x5) /*NOTREACHED*/ } -/* This code used to be in the middle of Make_Control_Point, replaced - * by CWCC below. Preprocessor conditionals do not work in macros. - */ +/* Implementation detail: in addition to setting aside the old + stacklet on a catch, the new stacklet is cleared and a return + code is placed at the base of the (now clear) stack indicating + that a return back through here requires restoring the stacklet. + The current enabled interrupts are also saved in the old stacklet. + + >>> Temporarily (maybe) the act of doing a CATCH will disable any + >>> return hook that may be in the stack. +*/ -#define CWCC(Return_Code) \ - fast Pointer *From_Where; \ - Primitive_1_Arg(); \ - CWCC_1(); \ - /* Implementation detail: in addition to setting aside the old \ - stacklet on a catch, the new stacklet is cleared and a return \ - code is placed at the base of the (now clear) stack indicating \ - that a return back through here requires restoring the stacklet. \ - The current enabled interrupts are also saved in the old stacklet. \ - \ - >>> Temporarily (maybe) the act of doing a CATCH will disable any \ - >>> return hook that may be in the stack. \ +#define CWCC(Return_Code) \ +{ \ + fast Pointer *From_Where; \ \ - >>> Don't even think about adding COMPILER to this stuff! \ - */ \ + CWCC_1(); \ Pop_Primitive_Frame(1); \ if (Return_Hook_Address != NULL) \ { \ *Return_Hook_Address = Old_Return_Code; \ Return_Hook_Address = NULL; \ } \ -/* Put down frames to restore history and interrupts so that these \ - * operations will be performed on a throw. \ - */ \ + /* \ + Put down frames to restore history and interrupts so that these \ + operations will be performed on a throw. \ + */ \ Will_Push(CONTINUATION_SIZE + HISTORY_SIZE); \ Save_History(Return_Code); \ Store_Expression(Make_Non_Pointer(TC_FIXNUM, IntEnb)); \ Store_Return(RC_RESTORE_INT_MASK); \ Save_Cont(); \ Pushed(); \ -/* There is no history to use since the last control point was formed. \ - */ \ + /* \ + There is no history to use since the last control point was formed. \ + */ \ Prev_Restore_History_Stacklet = NULL; \ Prev_Restore_History_Offset = 0; \ CWCC_2(); \ -/* Will_Push(3); -- we just cleared the stack so there MUST be room */ \ + /* we just cleared the stack so there MUST be room */ \ + /* Will_Push(3); */ \ Push(Control_Point); \ Push(Arg1); /* Function */ \ - Push(STACK_FRAME_HEADER+1); \ -/* Pushed(); */ + Push(STACK_FRAME_HEADER + 1); \ + /* Pushed(); */ \ +} #ifdef USE_STACKLETS + #define CWCC_1() \ - Primitive_GC_If_Needed(2*Default_Stacklet_Size) +{ \ + Primitive_GC_If_Needed(2 * Default_Stacklet_Size); \ +} #define CWCC_2() \ +{ \ Control_Point = Get_Current_Stacklet(); \ - Allocate_New_Stacklet(3) + Allocate_New_Stacklet(3); \ +} + +#else /* not USE_STACKLETS */ -#else /* Not using stacklets, so full copy must be made */ #define CWCC_1() \ - Primitive_GC_If_Needed((Stack_Top-Stack_Pointer) + \ - STACKLET_HEADER_SIZE - 1 + \ - CONTINUATION_SIZE + \ - HISTORY_SIZE) +{ \ + Primitive_GC_If_Needed((Stack_Top - Stack_Pointer) + \ + STACKLET_HEADER_SIZE + \ + CONTINUATION_SIZE + \ + HISTORY_SIZE); \ +} #define CWCC_2() \ { \ fast long i, Stack_Cells; \ \ - Stack_Cells = (Stack_Top-Stack_Pointer); \ + Stack_Cells = (Stack_Top - Stack_Pointer); \ Control_Point = Make_Pointer(TC_CONTROL_POINT, Free); \ Free[STACKLET_LENGTH] = \ Make_Non_Pointer(TC_MANIFEST_VECTOR, \ - Stack_Cells + STACKLET_HEADER_SIZE - 1); \ + (Stack_Cells + (STACKLET_HEADER_SIZE - 1))); \ + Free[STACKLET_REUSE_FLAG] = TRUTH; \ Free[STACKLET_UNUSED_LENGTH] = \ Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, 0); \ Free += STACKLET_HEADER_SIZE; \ - for (i=0; i < Stack_Cells; i++) \ + for (i = Stack_Cells; --i >= 0; ) \ { \ *Free++ = Pop(); \ } \ if (Consistency_Check) \ { \ if (Stack_Pointer != Stack_Top) \ + { \ Microcode_Termination(TERM_BAD_STACK); \ + } \ } \ Will_Push(CONTINUATION_SIZE); \ Store_Return(RC_JOIN_STACKLETS); \ @@ -203,29 +215,31 @@ Built_In_Primitive(Prim_Apply, 2, "APPLY", 0x5) Save_Cont(); \ Pushed(); \ } -#endif + +#endif /* USE_STACKLETS */ /* (CALL-WITH-CURRENT-CONTINUATION PROCEDURE) - Creates a control point (a pointer to the current stack) and - passes it to PROCEDURE as its only argument. The inverse - operation, typically called THROW, is performed by using the - control point as you would a procedure. A control point accepts - one argument which is then returned as the value of the CATCH - which created the control point. If the dangerous bit of the - unused length word in the stacklet is clear then the control - point may be reused as often as desired since the stack will be - copied on every throw. The user level CATCH is built on this - primitive but is not the same, since it handles dynamic-wind - while the primitive does not; it assumes that the microcode - sets and clears the appropriate danger bits for copying. + + Creates a control point (a pointer to the current stack) and passes + it to PROCEDURE as its only argument. The inverse operation, + typically called THROW, is performed by using the control point as + you would a procedure. A control point accepts one argument which + is then returned as the value of the CATCH which created the + control point. If the reuse flag of the stacklet is clear then the + control point may be reused as often as desired since the stack + will be copied on every throw. The user level CATCH is built on + this primitive but is not the same, since it handles dynamic state + while the primitive does not; it assumes that the microcode sets + and clears the appropriate reuse flags for copying. */ Built_In_Primitive(Prim_Catch, 1, "CALL-WITH-CURRENT-CONTINUATION", 0x3) { - fast Pointer Control_Point; + Pointer Control_Point; + Primitive_1_Arg(); CWCC(RC_RESTORE_HISTORY); - Clear_Danger_Bit((Get_Pointer(Control_Point))[STACKLET_UNUSED_LENGTH]); + Vector_Set(Control_Point, STACKLET_REUSE_FLAG, NIL); PRIMITIVE_ABORT( PRIM_APPLY); /*NOTREACHED*/ } @@ -234,6 +248,7 @@ Built_In_Primitive(Prim_Non_Reentrant_Catch, 1, "NON-REENTRANT-CALL-WITH-CURRENT-CONTINUATION", 0x9) { Pointer Control_Point; + Primitive_1_Arg(); #ifdef USE_STACKLETS @@ -243,7 +258,7 @@ Built_In_Primitive(Prim_Non_Reentrant_Catch, 1, /* When there are no stacklets, it is identical to the reentrant version. */ CWCC(RC_RESTORE_HISTORY); - Clear_Danger_Bit((Get_Pointer(Control_Point))[STACKLET_UNUSED_LENGTH]); + Vector_Set(Control_Point, STACKLET_REUSE_FLAG, NIL); #endif @@ -524,11 +539,7 @@ Built_In_Primitive(Prim_Set_Current_History, 1, "SET-CURRENT-HISTORY!", 0x2F) { Primitive_1_Arg(); - /* History is one of the few places where we still used danger bits. - Check explicitely. - */ - - if ((safe_pointer_type (Arg1)) != TC_HUNK3) + if (!(HUNK3_P(Arg1))) error_wrong_type_arg (1); Val = *History; @@ -610,17 +621,18 @@ Built_In_Primitive(Prim_With_History_Disabled, 1, /* Remove one reduction from the history before saving it */ First_Rib = Get_Pointer(History[HIST_RIB]); Second_Rib = Get_Pointer(First_Rib[RIB_NEXT_REDUCTION]); - if (!((Dangerous(First_Rib[RIB_MARK])) || + if (!((HISTORY_MARKED_P(First_Rib[RIB_MARK])) || (First_Rib == Second_Rib))) { - Set_Danger_Bit(Second_Rib[RIB_MARK]); + HISTORY_MARK(Second_Rib[RIB_MARK]); for (Rib = First_Rib; Get_Pointer(Rib[RIB_NEXT_REDUCTION]) != First_Rib; Rib = Get_Pointer(Rib[RIB_NEXT_REDUCTION])) { /* Look for one that points to the first rib */ } - History[HIST_RIB] = Make_Pointer(Type_Code(History[HIST_RIB]), Rib); + /* This maintains the mark in History[HIST_RIB] */ + History[HIST_RIB] = Make_Pointer(OBJECT_TYPE(History[HIST_RIB]), Rib); } Pop_Primitive_Frame(1); Stop_History(); diff --git a/v7/src/microcode/hunk.c b/v7/src/microcode/hunk.c index 9e36ceeee..5f2b48f9b 100644 --- a/v7/src/microcode/hunk.c +++ b/v7/src/microcode/hunk.c @@ -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/hunk.c,v 9.22 1987/04/16 02:24:07 jinx Rel $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/hunk.c,v 9.23 1987/10/09 16:11:45 jinx Rel $ * * Support for Hunk3s (triples) */ @@ -60,23 +60,23 @@ Built_In_Primitive(Prim_Hunk3_Cxr, 2, "HUNK3-CXR", 0x29) long Offset; Primitive_2_Args(); - Arg_1_Type(TC_HUNK3); - Arg_2_Type(TC_FIXNUM); + CHECK_ARG(1, HUNK3_P); + CHECK_ARG(2, FIXNUM_P); Range_Check(Offset, Arg2, 0, 2, ERR_ARG_2_BAD_RANGE); return Vector_Ref(Arg1, Offset); } /* (HUNK3-SET-CXR! TRIPLE N VALUE) Stores VALUE in the Nth item of TRIPLE. N must be 0, 1, or 2. - Returns (not good style to count on this) the previous contents. + Returns the previous contents. */ Built_In_Primitive(Prim_Hunk3_Set_Cxr, 3, "HUNK3-SET-CXR!", 0x2A) { long Offset; Primitive_3_Args(); - Arg_1_Type(TC_HUNK3); - Arg_2_Type(TC_FIXNUM); + CHECK_ARG(1, HUNK3_P); + CHECK_ARG(2, FIXNUM_P); Range_Check(Offset, Arg2, 0, 2, ERR_ARG_2_BAD_RANGE); Side_Effect_Impurify(Arg1, Arg3); return Swap_Pointers(Nth_Vector_Loc(Arg1, Offset), Arg3); @@ -125,7 +125,7 @@ Built_In_Primitive(Prim_Sys_H3_2, 1, "SYSTEM-HUNK3-CXR2", 0x94) Replaces item 0 (the first item) in any object with a GC type of triple with NEW-CONTENTS. For example, this would modify the operator slot of a COMBINATION_2_OPERAND SCode item. Returns - (bad style to rely on this) the previous contents. + the previous contents. */ Built_In_Primitive(Prim_SH3_Set_0, 2, "SYSTEM-HUNK3-SET-CXR0!", 0x8F) { @@ -140,7 +140,7 @@ Built_In_Primitive(Prim_SH3_Set_0, 2, "SYSTEM-HUNK3-SET-CXR0!", 0x8F) Replaces item 1 (the second item) in any object with a GC type of triple with NEW-CONTENTS. For example, this would modify the first operand slot of a COMBINATION_2_OPERAND SCode item. - Returns (bad style to rely on this) the previous contents. + Returns the previous contents. */ Built_In_Primitive(Prim_SH3_Set_1, 2, "SYSTEM-HUNK3-SET-CXR1!", 0x92) { @@ -155,7 +155,7 @@ Built_In_Primitive(Prim_SH3_Set_1, 2, "SYSTEM-HUNK3-SET-CXR1!", 0x92) Replaces item 2 (the third item) in any object with a GC type of triple with NEW-CONTENTS. For example, this would modify the second operand slot of a COMBINATION_2_OPERAND SCode item. - Returns (bad style to rely on this) the previous contents. + Returns the previous contents. */ Built_In_Primitive(Prim_SH3_Set_2, 2, "SYSTEM-HUNK3-SET-CXR2!", 0x95) { diff --git a/v7/src/microcode/interp.c b/v7/src/microcode/interp.c index b936b1880..f9cc44f0e 100644 --- a/v7/src/microcode/interp.c +++ b/v7/src/microcode/interp.c @@ -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/interp.c,v 9.32 1987/10/05 18:32:48 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/interp.c,v 9.33 1987/10/09 16:11:55 jinx Exp $ * * This file contains the heart of the Scheme Scode * interpreter @@ -42,6 +42,8 @@ MIT in each case. */ #include "locks.h" #include "trap.h" #include "lookup.h" +#include "history.h" +#include "cmpint.h" #include "zones.h" /* In order to make the interpreter tail recursive (i.e. diff --git a/v7/src/microcode/interp.h b/v7/src/microcode/interp.h index 4f9d96c11..41e831249 100644 --- a/v7/src/microcode/interp.h +++ b/v7/src/microcode/interp.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/interp.h,v 9.24 1987/07/23 21:48:38 cph Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/interp.h,v 9.25 1987/10/09 16:12:22 jinx Rel $ * * Macros used by the interpreter and some utilities. * @@ -93,18 +93,26 @@ MIT in each case. */ /* Internal_Will_Push is in stack.h. */ #ifdef ENABLE_DEBUGGING_TOOLS -#define Will_Push(N) \ -{ Pointer *Will_Push_Limit; \ - Internal_Will_Push((N)); \ + +#define Will_Push(N) \ +{ \ + Pointer *Will_Push_Limit; \ + \ + Internal_Will_Push((N)); \ Will_Push_Limit = Simulate_Pushing(N) -#define Pushed() \ - if (Stack_Pointer < Will_Push_Limit) Stack_Death(); \ +#define Pushed() \ + if (Stack_Pointer < Will_Push_Limit) \ + { \ + Stack_Death(); \ + } \ } #else + #define Will_Push(N) Internal_Will_Push(N) #define Pushed() /* No op */ + #endif #define Will_Eventually_Push(N) Internal_Will_Push(N) @@ -135,42 +143,6 @@ MIT in each case. */ #define Push_From(SP) *--(SP) #define Pop_Into(SP, What) (*(SP)++) = (What) -/* Stack Gap Operations: */ - -/* With_Stack_Gap opens a gap Gap_Size wide Gap_Position cells above the - * top of the stack. Code must push Gap_Size objects. It executes Code - * with the stack pointer placed so that these objects will fill the gap. - */ - -#define With_Stack_Gap(Gap_Size, Gap_Position, Code) \ -{ Pointer *Saved_Destination; \ - fast Pointer *Destination; \ - fast long size_to_move = (Gap_Position); \ - Destination = Simulate_Pushing(Gap_Size); \ - Saved_Destination = Destination; \ - while (--size_to_move >= 0) \ - Pop_Into(Destination, Pop()); \ - Code; \ - Stack_Pointer = Saved_Destination; \ -} - -/* Close_Stack_Gap closes a gap Gap_Size wide Gap_Position cells above the - * top of the stack. The contents of the gap are lost. - */ - -#define Close_Stack_Gap(Gap_Size, Gap_Position, extra_code) \ -{ fast long size_to_move = (Gap_Position); \ - fast Pointer *Source = Simulate_Popping(size_to_move); \ - Stack_Pointer = Simulate_Popping((Gap_Size) + size_to_move); \ - extra_code; \ - while (--size_to_move >= 0) \ - Push(Push_From(Source)); \ -} - -/* Racks operations continue on the next page */ - -/* Rack operations, continued */ - /* Fetch from register */ #define Fetch_Expression() Expression @@ -190,32 +162,44 @@ MIT in each case. */ /* Note: Save_Cont must match the definitions in sdata.h */ -#define Save_Cont() { Push(Expression); \ - Push(Return); \ - Cont_Print(); \ - } - -#define Restore_Cont() { Return = Pop(); \ - Expression = Pop(); \ - if (Cont_Debug) \ - { Print_Return(RESTORE_CONT_RETURN_MESSAGE); \ - Print_Expression(Fetch_Expression(), \ - RESTORE_CONT_EXPR_MESSAGE);\ - CRLF(); \ - } \ - } - -#define Cont_Print() if (Cont_Debug) \ - { Print_Return(CONT_PRINT_RETURN_MESSAGE); \ - Print_Expression(Fetch_Expression(), \ - CONT_PRINT_EXPR_MESSAGE); \ - CRLF(); \ - } +#define Save_Cont() \ +{ \ + Push(Expression); \ + Push(Return); \ + Cont_Print(); \ +} + +#define Restore_Cont() \ +{ \ + Return = Pop(); \ + Expression = Pop(); \ + if (Cont_Debug) \ + { \ + Print_Return(RESTORE_CONT_RETURN_MESSAGE); \ + Print_Expression(Fetch_Expression(), \ + RESTORE_CONT_EXPR_MESSAGE); \ + CRLF(); \ + } \ +} + +#define Cont_Print() \ +{ \ + if (Cont_Debug) \ + { \ + Print_Return(CONT_PRINT_RETURN_MESSAGE); \ + Print_Expression(Fetch_Expression(), \ + CONT_PRINT_EXPR_MESSAGE); \ + CRLF(); \ + } \ +} #define Stop_Trapping() \ -{ Trapping = false; \ +{ \ + Trapping = false; \ if (Return_Hook_Address != NULL) \ + { \ *Return_Hook_Address = Old_Return_Code; \ + } \ Return_Hook_Address = NULL; \ } @@ -239,173 +223,6 @@ MIT in each case. */ #define Pop_Primitive_Frame(NArgs) \ Stack_Pointer = Simulate_Popping(NArgs) -/* Compiled code utility macros */ - -/* Going from interpreted code to compiled code */ - -/* Tail recursion is handled as follows: - if the return code is `reenter_compiled_code', it is discarded, - and the two contiguous interpreter segments on the stack are - merged. - */ - -/* Apply interface: - calling a compiled procedure with a frame nslots long. - */ - -#define apply_compiled_setup(nslots) \ -{ long frame_size = (nslots); \ - if (Stack_Ref(frame_size + CONTINUATION_RETURN_CODE) == \ - (Make_Non_Pointer(TC_RETURN_CODE, RC_REENTER_COMPILED_CODE))) \ - { /* Merge compiled code segments on the stack. */ \ - Close_Stack_Gap(CONTINUATION_SIZE, \ - frame_size, \ - { long segment_size = \ - Datum(Stack_Ref(CONTINUATION_EXPRESSION - \ - CONTINUATION_SIZE)); \ - last_return_code = Simulate_Popping(segment_size); \ - }); \ - /* Undo the subproblem rotation. */ \ - Compiler_End_Subproblem(); \ - } \ - else \ - { /* Make a new compiled code segment which includes this frame. */ \ - /* History need not be hacked here. */ \ - With_Stack_Gap(1, \ - frame_size, \ - { last_return_code = &Top_Of_Stack(); \ - Push(return_to_interpreter); \ - }); \ - } \ -} - -/* Eval interface: - executing a compiled expression. - */ - -#define execute_compiled_setup() \ -{ if (Stack_Ref(CONTINUATION_RETURN_CODE) == \ - (Make_Non_Pointer(TC_RETURN_CODE, RC_REENTER_COMPILED_CODE))) \ - { /* Merge compiled code segments on the stack. */ \ - long segment_size; \ - Restore_Cont(); \ - segment_size = Datum(Fetch_Expression()); \ - last_return_code = Simulate_Popping(segment_size); \ - /* Undo the subproblem rotation. */ \ - Compiler_End_Subproblem(); \ - } \ - else \ - { /* 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); \ - } \ -} - -/* Pop return interface: - Returning to compiled code from the interpreter. - */ - -#define compiled_code_restart() \ -{ long segment_size; \ - segment_size = Datum(Fetch_Expression()); \ - last_return_code = Simulate_Popping(segment_size); \ - /* Undo the subproblem rotation. */ \ - Compiler_End_Subproblem(); \ -} - -/* Going from compiled code to interpreted code */ - -/* Tail recursion is handled in the following way: - if the return address is `return_to_interpreter', it is discarded, - and the two contiguous interpreter segments on the stack are - merged. - */ - -/* Apply interface: - calling an interpreted procedure (or unsafe primitive) - with a frame nslots long. - */ - -#define compiler_apply_procedure(nslots) \ -{ 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(); \ - } \ - else \ - { /* Make a new interpreter segment which includes this frame. */ \ - With_Stack_Gap(CONTINUATION_SIZE, \ - frame_size, \ - { long segment_size = Stack_Distance(last_return_code); \ - Store_Expression(Make_Unsigned_Fixnum(segment_size)); \ - Store_Return(RC_REENTER_COMPILED_CODE); \ - Save_Cont(); \ - }); \ - /* Rotate history to a new subproblem. */ \ - Compiler_New_Subproblem(); \ - } \ -} - -/* Pop Return interface: - returning to the interpreter from compiled code. - Nothing needs to be done at this time. - */ - -#define compiled_code_done() - -/* Various handlers for backing out of compiled code. */ - -/* Backing out of apply. */ - -#define apply_compiled_backout() \ -{ compiler_apply_procedure(STACK_ENV_EXTRA_SLOTS + \ - Get_Integer( Stack_Ref( STACK_ENV_HEADER))); \ -} - -/* Backing out of eval. */ - -#define execute_compiled_backout() \ -{ if (Top_Of_Stack() == return_to_interpreter) \ - { \ - Simulate_Popping(1); \ - /* Set up the current rib. */ \ - Compiler_New_Reduction(); \ - } \ - else \ - { long segment_size = Stack_Distance(last_return_code); \ - Store_Expression(Make_Unsigned_Fixnum(segment_size)); \ - Store_Return(RC_REENTER_COMPILED_CODE); \ - Save_Cont(); \ - /* Rotate history to a new subproblem. */ \ - Compiler_New_Subproblem(); \ - } \ -} - -/* Backing out because of special errors or interrupts. - The microcode has already setup a return code with a NIL. - No tail recursion in this case. - *** - Is the history manipulation correct? - Does Microcode_Error do something special? - *** - */ - -#define compiled_error_backout() \ -{ long segment_size; \ - Restore_Cont(); \ - segment_size = Stack_Distance(last_return_code); \ - Store_Expression(Make_Unsigned_Fixnum(segment_size)); \ - /* The Store_Return is a NOP, the Save_Cont is done by the code \ - that follows. \ - */ \ - /* Store_Return(Datum(Fetch_Return())); */ \ - /* Save_Cont(); */ \ - Compiler_New_Subproblem(); \ -} - #define UNWIND_PROTECT(body_statement, cleanup_statement) do \ { \ jmp_buf UNWIND_PROTECT_new_buf, *UNWIND_PROTECT_old_buf; \ diff --git a/v7/src/microcode/list.c b/v7/src/microcode/list.c index cdaacad24..92f56ddb5 100644 --- a/v7/src/microcode/list.c +++ b/v7/src/microcode/list.c @@ -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/list.c,v 9.23 1987/04/16 02:25:19 jinx Rel $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/list.c,v 9.24 1987/10/09 16:12:36 jinx Rel $ * * List creation and manipulation primitives. */ @@ -259,7 +259,7 @@ Built_In_Primitive(Prim_Sys_Pair_Cons, 3, "SYSTEM-PAIR-CONS", 0x84) Primitive_3_Args(); Arg_1_Type(TC_FIXNUM); - Range_Check(Type, Arg1, 0, MAX_SAFE_TYPE, + Range_Check(Type, Arg1, 0, MAX_TYPE_CODE, ERR_ARG_1_BAD_RANGE); if (GC_Type_Code(Type) == GC_Pair) { diff --git a/v7/src/microcode/memmag.c b/v7/src/microcode/memmag.c index 6221957ab..0c020e0d7 100644 --- a/v7/src/microcode/memmag.c +++ b/v7/src/microcode/memmag.c @@ -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/memmag.c,v 9.30 1987/06/23 22:00:09 cph Rel $ */ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/memmag.c,v 9.31 1987/10/09 16:12:45 jinx Rel $ */ /* Memory management top level. @@ -299,7 +299,7 @@ void GC() Set_Fixed_Obj_Slot(Lost_Objects_Base, NIL); *Free++ = Fixed_Objects; - *Free++ = Make_Pointer(TC_HUNK3, History); + *Free++ = Make_Pointer(UNMARKED_HISTORY_TYPE, History); *Free++ = Undefined_Externals; *Free++ = Get_Current_Stacklet(); *Free++ = ((Prev_Restore_History_Stacklet == NULL) ? diff --git a/v7/src/microcode/object.h b/v7/src/microcode/object.h index 451f89d7f..d287d444e 100644 --- a/v7/src/microcode/object.h +++ b/v7/src/microcode/object.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/object.h,v 9.25 1987/10/05 18:35:46 jinx Exp $ */ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/object.h,v 9.26 1987/10/09 16:12:57 jinx Rel $ */ /* This file contains definitions pertaining to the C view of Scheme pointers: widths of fields, extraction macros, pre-computed @@ -46,21 +46,11 @@ MIT in each case. */ #define TYPE_CODE_LENGTH 8 /* Not CHAR_SIZE!! */ #define MAX_TYPE_CODE 0xFF /* ((1<> ADDRESS_LENGTH) & MAX_TYPE_CODE) -#define safe_pointer_type(P) (((P) >> ADDRESS_LENGTH) & SAFE_TYPE_MASK) #else /* Faster for logical shifts */ #define OBJECT_TYPE(P) ((P) >> ADDRESS_LENGTH) -#define safe_pointer_type(P) ((pointer_type (P)) & SAFE_TYPE_MASK) #endif #define OBJECT_DATUM(P) ((P) & ADDRESS_MASK) /* compatibility definitions */ #define Type_Code(P) (OBJECT_TYPE (P)) -#define Safe_Type_Code(P) (safe_pointer_type (P)) #define Datum(P) (OBJECT_DATUM (P)) #define pointer_type(P) (OBJECT_TYPE (P)) @@ -103,7 +89,7 @@ MIT in each case. */ #define Make_Object(TC, D) \ ((((unsigned) (TC)) << ADDRESS_LENGTH) | (OBJECT_DATUM (D))) -#ifndef Heap_In_Low_Memory /* Safe version */ +#ifndef Heap_In_Low_Memory /* Portable version */ typedef Pointer *relocation_type; /* Used to relocate pointers on fasload */ @@ -209,6 +195,10 @@ typedef long relocation_type; /* Used to relocate pointers on fasload */ ((OBJECT_TYPE (object)) == TC_BIG_FLONUM) \ ((OBJECT_TYPE (object)) == TC_COMPLEX)) +#define HUNK3_P(object) \ + (((OBJECT_TYPE(object)) == TC_HUNK3_A) || \ + ((OBJECT_TYPE(object)) == TC_HUNK3_B)) + #define MAKE_FIXNUM(N) (Make_Non_Pointer (TC_FIXNUM, (N))) #define FIXNUM_NEGATIVE_P(fixnum) (((fixnum) & FIXNUM_SIGN_BIT) != 0) #define MAKE_UNSIGNED_FIXNUM(N) (FIXNUM_ZERO + (N)) @@ -225,7 +215,7 @@ do \ } while (0) #define BOOLEAN_TO_OBJECT(expression) ((expression) ? TRUTH : NIL) - + #define Make_Broken_Heart(N) (BROKEN_HEART_ZERO + (N)) #define Make_Unsigned_Fixnum(N) (FIXNUM_ZERO + (N)) #define Make_Signed_Fixnum(N) Make_Non_Pointer( TC_FIXNUM, (N)) @@ -246,14 +236,6 @@ do \ #define BYTES_TO_POINTERS(nbytes) \ (((nbytes) + ((sizeof (Pointer)) - 1)) / (sizeof (Pointer))) -/* Playing with the danger bit */ - -#define Without_Danger_Bit(P) ((P) & (~DANGER_BIT)) -#define Dangerous(P) ((P & DANGER_BIT) != 0) -#define Clear_Danger_Bit(P) P &= ~DANGER_BIT -#define Set_Danger_Bit(P) P |= DANGER_BIT -/* Side effect testing */ - #define Is_Constant(address) \ (((address) >= Constant_Space) && ((address) < Free_Constant)) diff --git a/v7/src/microcode/ppband.c b/v7/src/microcode/ppband.c index ada657611..09fb108d7 100644 --- a/v7/src/microcode/ppband.c +++ b/v7/src/microcode/ppband.c @@ -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/ppband.c,v 9.27 1987/10/05 18:30:44 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/ppband.c,v 9.28 1987/10/09 16:08:24 jinx Rel $ * * Dumps Scheme FASL in user-readable form . */ @@ -79,7 +79,7 @@ Close_Dump_File() #ifdef Heap_In_Low_Memory #ifdef spectrum -#define File_To_Pointer(P) ((((long) (P))&ADDRESS_MASK) / sizeof(Pointer)) +#define File_To_Pointer(P) ((((long) (P)) & ADDRESS_MASK) / sizeof(Pointer)) #else #define File_To_Pointer(P) ((P) / sizeof(Pointer)) #endif /* spectrum */ @@ -107,8 +107,8 @@ static Pointer *Data, *end_of_memory; Boolean scheme_string(From, Quoted) -long From; -Boolean Quoted; + long From; + Boolean Quoted; { fast long i, Count; fast char *Chars; @@ -129,11 +129,11 @@ Boolean Quoted; return false; } -#define via(File_Address) Relocate(Address(Data[File_Address])) +#define via(File_Address) Relocate(OBJECT_DATUM(Data[File_Address])) void scheme_symbol(From) -long From; + long From; { Pointer *symbol; @@ -151,13 +151,11 @@ Display(Location, Type, The_Datum) long Points_To; printf("%5x: %2x|%6x ", Location, Type, The_Datum); - if (GC_Type_Map[Type & MAX_SAFE_TYPE] != GC_Non_Pointer) + if (GC_Type_Map[Type] != GC_Non_Pointer) Points_To = Relocate((Pointer *) The_Datum); else Points_To = The_Datum; - if (Type > MAX_SAFE_TYPE) - printf("*"); - switch (Type & SAFE_TYPE_MASK) + switch (Type) { /* "Strange" cases */ case TC_NULL: if (The_Datum == 0) { printf("NIL\n"); @@ -253,11 +251,12 @@ Display(Location, Type, The_Datum) } main(argc, argv) -int argc; -char **argv; + int argc; + char **argv; { Pointer *Next; long i, total_length; + if (argc == 1) { if (!Read_Header()) @@ -296,44 +295,54 @@ char **argv; } total_length -= Heap_Count; if (total_length < Const_Count) + { Const_Count = total_length; + } } printf("Heap contents:\n\n"); for (Next = Data, i = 0; i < Heap_Count; Next++, i++) { - if (Safe_Type_Code(*Next) == TC_MANIFEST_NM_VECTOR) + if (OBJECT_TYPE(*Next) == TC_MANIFEST_NM_VECTOR) { long j, count; count = Get_Integer(*Next); - Display(i, Type_Code(*Next), Address(*Next)); + Display(i, OBJECT_TYPE(*Next), OBJECT_DATUM(*Next)); Next += 1; for (j = 0; j < count ; j++, Next++) + { printf(" %02x%06x\n", - Type_Code(*Next), Address(*Next)); + OBJECT_TYPE(*Next), OBJECT_DATUM(*Next)); + } i += count; Next -= 1; } else - Display(i, Type_Code(*Next), Address(*Next)); + { + Display(i, OBJECT_TYPE(*Next), OBJECT_DATUM(*Next)); + } } printf("\n\nConstant space:\n\n"); for (; i < Heap_Count + Const_Count; Next++, i++) { - if (Safe_Type_Code(*Next) == TC_MANIFEST_NM_VECTOR) + if (OBJECT_TYPE(*Next) == TC_MANIFEST_NM_VECTOR) { long j, count; count = Get_Integer(*Next); - Display(i, Type_Code(*Next), Address(*Next)); + Display(i, OBJECT_TYPE(*Next), OBJECT_DATUM(*Next)); Next += 1; for (j = 0; j < count ; j++, Next++) + { printf(" %02x%06x\n", - Type_Code(*Next), Address(*Next)); + OBJECT_TYPE(*Next), OBJECT_DATUM(*Next)); + } i += count; Next -= 1; } else - Display(i, Type_Code(*Next), Address(*Next)); + { + Display(i, OBJECT_TYPE(*Next), OBJECT_DATUM(*Next)); + } } } diff --git a/v7/src/microcode/prim.c b/v7/src/microcode/prim.c index 59eaae3bf..6f2d8d174 100644 --- a/v7/src/microcode/prim.c +++ b/v7/src/microcode/prim.c @@ -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/prim.c,v 9.25 1987/04/16 23:20:46 jinx Rel $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/prim.c,v 9.26 1987/10/09 16:13:08 jinx Exp $ * * The leftovers ... primitives that don't seem to belong elsewhere. * @@ -103,7 +103,7 @@ Built_In_Primitive(Prim_Prim_Type, 1, "PRIMITIVE-TYPE", 0x10) Primitive_1_Arg(); Touch_In_Primitive(Arg1, Arg1); - return Make_Unsigned_Fixnum(Safe_Type_Code(Arg1)); + return Make_Unsigned_Fixnum(OBJECT_TYPE(Arg1)); } /* (PRIMITIVE-GC-TYPE OBJECT) @@ -148,7 +148,7 @@ Built_In_Primitive(Prim_Primitive_Set_Type, 2, "PRIMITIVE-SET-TYPE", 0x11) Primitive_2_Args(); Arg_1_Type(TC_FIXNUM); - Range_Check(New_Type, Arg1, 0, MAX_SAFE_TYPE, ERR_ARG_1_BAD_RANGE); + Range_Check(New_Type, Arg1, 0, MAX_TYPE_CODE, ERR_ARG_1_BAD_RANGE); Touch_In_Primitive(Arg2, Arg2); New_GC_Type = GC_Type_Code(New_Type); if ((GC_Type(Arg2) == New_GC_Type) || @@ -177,7 +177,7 @@ Built_In_Primitive(Prim_And_Make_Object, 2, "&MAKE-OBJECT", 0x8D) Primitive_2_Args(); Arg_1_Type(TC_FIXNUM); - Range_Check(New_Type, Arg1, 0, MAX_SAFE_TYPE, ERR_ARG_1_BAD_RANGE); + Range_Check(New_Type, Arg1, 0, MAX_TYPE_CODE, ERR_ARG_1_BAD_RANGE); return Make_New_Pointer(New_Type, Arg2); } @@ -209,40 +209,6 @@ Built_In_Primitive(Prim_System_Memory_Set, 3, "SYSTEM-MEMORY-SET!", 0x196) return Swap_Pointers(Nth_Vector_Loc(Arg1, index), Arg3); } -/* Playing with the danger bit */ - -/* (OBJECT-DANGEROUS? OBJECT) - Returns #!TRUE if OBJECT has the danger bit set, NIL otherwise. -*/ -Built_In_Primitive(Prim_Dangerous_QM, 1, "OBJECT-DANGEROUS?", 0x49) -{ - Primitive_1_Arg(); - - return (Dangerous(Arg1)) ? TRUTH : NIL; -} - -/* (MAKE-OBJECT-DANGEROUS OBJECT) - Returns OBJECT, but with the danger bit set. -*/ -Built_In_Primitive(Prim_Dangerize, 1, "MAKE-OBJECT-DANGEROUS", 0x48) -{ - Primitive_1_Arg(); - - return Set_Danger_Bit(Arg1); -} - -/* (MAKE-OBJECT-SAFE OBJECT) - Returns OBJECT with the danger bit cleared. This does not - side-effect the object, it merely returns a new (non-dangerous) - pointer to the same item. -*/ -Built_In_Primitive(Prim_Undangerize, 1, "MAKE-OBJECT-SAFE", 0x47) -{ - Primitive_1_Arg(); - - return Clear_Danger_Bit(Arg1); -} - /* Cells */ /* (MAKE-CELL CONTENTS) diff --git a/v7/src/microcode/purutl.c b/v7/src/microcode/purutl.c index d8abfa8ad..c5c7d86c1 100644 --- a/v7/src/microcode/purutl.c +++ b/v7/src/microcode/purutl.c @@ -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/purutl.c,v 9.30 1987/07/22 21:54:46 jinx Exp $ */ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/purutl.c,v 9.31 1987/10/09 16:13:19 jinx Rel $ */ /* Pure/Constant space utilities. */ @@ -47,14 +47,14 @@ Update(From, To, Was, Will_Be) { if (GC_Type_Special(*From)) { - if (Safe_Type_Code(*From) == TC_MANIFEST_NM_VECTOR) + if (OBJECT_TYPE(*From) == TC_MANIFEST_NM_VECTOR) From += Get_Integer(*From); continue; } if (GC_Type_Non_Pointer(*From)) continue; if (Get_Pointer(*From) == Was) - *From = Make_Pointer(Type_Code(*From), Will_Be); + *From = Make_Pointer(OBJECT_TYPE(*From), Will_Be); } return; } @@ -108,7 +108,7 @@ Make_Impure(Object) default: fprintf(stderr, "\nImpurify: Bad type code = 0x%02x\n", - Type_Code(Object)); + OBJECT_TYPE(Object)); Invalid_Type_Code(); } @@ -129,7 +129,7 @@ Make_Impure(Object) block, or something like it. -- JINX */ - if (Type_Code(Object) == TC_BIG_FLONUM) + if (OBJECT_TYPE(Object) == TC_BIG_FLONUM) { Pointer *Start; @@ -162,7 +162,7 @@ Make_Impure(Object) Terminate_Constant_Space(End_Of_Area); Update(Heap_Bottom, Free, Obj_Address, New_Address); Update(Constant_Space, End_Of_Area, Obj_Address, New_Address); - return Make_Pointer(Type_Code(Object), New_Address); + return Make_Pointer(OBJECT_TYPE(Object), New_Address); } /* (PRIMITIVE-IMPURIFY OBJECT) diff --git a/v7/src/microcode/returns.h b/v7/src/microcode/returns.h index cc0356d53..5ee3085fe 100644 --- a/v7/src/microcode/returns.h +++ b/v7/src/microcode/returns.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/returns.h,v 9.27 1987/10/05 18:36:01 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/returns.h,v 9.28 1987/10/09 16:13:30 jinx Exp $ * * Return codes. These are placed in Return when an * interpreter operation needs to operate in several @@ -121,8 +121,8 @@ MIT in each case. */ #define RC_COMP_CACHE_REF_APPLY_RESTART 0x57 #define RC_COMP_SAFE_REF_TRAP_RESTART 0x58 #define RC_COMP_UNASSIGNED_TRAP_RESTART 0x59 -#define RC_COMP_CACHE_ASSIGNMENT_RESTART 0x60 +#define RC_COMP_CACHE_ASSIGNMENT_RESTART 0x5A -#define MAX_RETURN_CODE 0x60 +#define MAX_RETURN_CODE 0x5A /* When adding return codes, don't forget to update storage.c too. */ diff --git a/v7/src/microcode/scheme.h b/v7/src/microcode/scheme.h index 54d484552..0cada2399 100644 --- a/v7/src/microcode/scheme.h +++ b/v7/src/microcode/scheme.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/scheme.h,v 9.25 1987/07/07 19:58:16 cph Rel $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/scheme.h,v 9.26 1987/10/09 16:13:39 jinx Rel $ * * General declarations for the SCode interpreter. This * file is INCLUDED by others and contains declarations only. @@ -86,7 +86,6 @@ MIT in each case. */ #include "returns.h" /* Return code numbers */ #include "fixobj.h" /* Format of fixed objects vector */ #include "stack.h" /* Macros for stack (stacklet) manipulation */ -#include "history.h" /* History maintenance */ #include "interpret.h" /* Macros for interpreter */ #ifdef butterfly diff --git a/v7/src/microcode/sdata.h b/v7/src/microcode/sdata.h index fb026091c..e30637cb4 100644 --- a/v7/src/microcode/sdata.h +++ b/v7/src/microcode/sdata.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/sdata.h,v 9.25 1987/10/05 18:36:16 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/sdata.h,v 9.26 1987/10/09 16:13:47 jinx Rel $ * * Description of the user data objects. This should parallel the * file SDATA.SCM in the runtime system. @@ -120,7 +120,9 @@ MIT in each case. */ _______________________________________ |MAN. VECT.| n | _ _______________________________________ - / | NM VECT | m at GC or when full | + / | #T if it does not need to be copied | + | _______________________________________ + | | NM VECT | m at GC or when full | | _______________________________________ | | ... |\ | | not yet in use -- garbage | > m @@ -135,10 +137,13 @@ MIT in each case. */ */ +#define STACKLET_HEADER_SIZE 3 #define STACKLET_LENGTH 0 /* = VECTOR_LENGTH */ -#define STACKLET_HEADER_SIZE 2 -#define STACKLET_UNUSED_LENGTH 1 -#define STACKLET_FREE_LIST_LINK 1 /* If on free list */ +#define STACKLET_REUSE_FLAG 1 +#define STACKLET_UNUSED_LENGTH 2 + +/* Aliases */ +#define STACKLET_FREE_LIST_LINK STACKLET_REUSE_FLAG /* DELAYED * The object returned by a DELAY operation. Consists initially of a diff --git a/v7/src/microcode/stack.h b/v7/src/microcode/stack.h index 6118b9162..23ecfbbc0 100644 --- a/v7/src/microcode/stack.h +++ b/v7/src/microcode/stack.h @@ -30,19 +30,25 @@ 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/stack.h,v 9.22 1987/06/23 22:01:13 cph Rel $ */ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/stack.h,v 9.23 1987/10/09 16:14:01 jinx Rel $ */ /* This file contains macros for manipulating stacks and stacklets. */ #ifdef USE_STACKLETS -/* Stack is made up of linked small parts, each in the heap */ + +/* + Stack is made up of linked small parts, each in the heap + */ #define Initialize_Stack() \ { \ if (GC_Check(Default_Stacklet_Size)) \ + { \ Microcode_Termination(TERM_STACK_ALLOCATION_FAILED); \ - Stack_Guard = Free+STACKLET_HEADER_SIZE; \ - *Free = Make_Non_Pointer(TC_MANIFEST_VECTOR, Default_Stacklet_Size-1); \ + } \ + Stack_Guard = (Free + STACKLET_HEADER_SIZE); \ + *Free = Make_Non_Pointer(TC_MANIFEST_VECTOR, \ + (Default_Stacklet_Size - 1)); \ Free += Default_Stacklet_Size; \ Stack_Pointer = Free; \ Free_Stacklets = NULL; \ @@ -53,7 +59,8 @@ MIT in each case. */ #define Internal_Will_Push(N) \ { \ if ((Stack_Pointer - (N)) < Stack_Guard) \ - { Export_Registers(); \ + { \ + Export_Registers(); \ Allocate_New_Stacklet((N)); \ Import_Registers(); \ } \ @@ -63,7 +70,7 @@ MIT in each case. */ #define Stack_Allocation_Size(Stack_Blocks) 0 -#define Current_Stacklet (Stack_Guard-STACKLET_HEADER_SIZE) +#define Current_Stacklet (Stack_Guard - STACKLET_HEADER_SIZE) /* Make the unused portion of the old stacklet invisible to garbage * collection. This also allows the stack pointer to be reconstructed. @@ -71,9 +78,10 @@ MIT in each case. */ #define Internal_Terminate_Old_Stacklet() \ { \ + Current_Stacklet[STACKLET_REUSE_FLAG] = TRUTH; \ Current_Stacklet[STACKLET_UNUSED_LENGTH] = \ - Make_Non_Pointer((DANGER_TYPE | TC_MANIFEST_NM_VECTOR), \ - Stack_Pointer-Stack_Guard); \ + Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, \ + (Stack_Pointer - Stack_Guard)); \ } #ifdef ENABLE_DEBUGGING_TOOLS @@ -96,6 +104,7 @@ MIT in each case. */ #endif /* Used by garbage collector to detect the end of constant space */ + #define Terminate_Constant_Space(Where) \ *Free_Constant = Make_Pointer(TC_BROKEN_HEART, Free_Constant); \ Where = Free_Constant @@ -104,33 +113,38 @@ MIT in each case. */ Make_Pointer(TC_CONTROL_POINT, Current_Stacklet) #define Previous_Stack_Pointer(Where) \ - Nth_Vector_Loc(Where, \ - (STACKLET_HEADER_SIZE+ \ + (Nth_Vector_Loc(Where, \ + (STACKLET_HEADER_SIZE + \ Get_Integer(Vector_Ref(Where, \ - STACKLET_UNUSED_LENGTH)))) + STACKLET_UNUSED_LENGTH))))) #define Set_Current_Stacklet(Where) \ -{ Pointer Our_Where = (Where); \ +{ \ + Pointer Our_Where; \ + \ + Our_Where = (Where); \ Stack_Guard = Nth_Vector_Loc(Our_Where, STACKLET_HEADER_SIZE); \ Stack_Pointer = Previous_Stack_Pointer(Our_Where); \ } -#define STACKLET_SLACK STACKLET_HEADER_SIZE + CONTINUATION_SIZE -#define Default_Stacklet_Size (Stack_Size+STACKLET_SLACK) +#define STACKLET_SLACK (STACKLET_HEADER_SIZE + CONTINUATION_SIZE) + +#define Default_Stacklet_Size (Stack_Size + STACKLET_SLACK) + #define New_Stacklet_Size(N) \ - (STACKLET_SLACK + Stack_Size * (((N) + Stack_Size - 1)/Stack_Size)) + (STACKLET_SLACK + Stack_Size * (((N) + Stack_Size - 1) / Stack_Size)) #define Get_End_Of_Stacklet() \ - (&(Current_Stacklet[1+Get_Integer(*Current_Stacklet)])) + (&(Current_Stacklet[1 + Get_Integer(Current_Stacklet[STACKLET_LENGTH])])) #define Apply_Stacklet_Backout() \ -Will_Push(2*CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+2)); \ +Will_Push((2 * CONTINUATION_SIZE) + (STACK_ENV_EXTRA_SLOTS + 2)); \ Store_Expression(NIL); \ Store_Return(RC_END_OF_COMPUTATION); \ Save_Cont(); \ Push(Val); \ Push(Previous_Stacklet); \ - Push(STACK_FRAME_HEADER+1); \ + Push(STACK_FRAME_HEADER + 1); \ Store_Return(RC_INTERNAL_APPLY); \ Save_Cont(); \ Pushed() @@ -144,94 +158,129 @@ Pushed() * will be entered. */ -#define Within_Stacklet_Backout() \ -{ Pointer Old_Expression = Fetch_Expression(); \ - Store_Expression(Previous_Stacklet); \ - Store_Return(RC_JOIN_STACKLETS); \ - Save_Cont(); \ - Store_Expression(Old_Expression); \ +#define Within_Stacklet_Backout() \ +{ \ + Pointer Old_Expression; \ + \ + Old_Expression = Fetch_Expression(); \ + Store_Expression(Previous_Stacklet); \ + Store_Return(RC_JOIN_STACKLETS); \ + Save_Cont(); \ + Store_Expression(Old_Expression); \ } -/* Our_Throw is used in chaining from one stacklet - * to another. In order to improve efficiency, the entire stack is - * copied neither on catch or throw, but is instead copied one - * stacklet at a time as needed. The need to copy a stacklet is - * signified by the danger bit being set in the header of a stacklet. - * If the danger bit is found to be set in a stacklet which is being - * returned into then that stacklet is copied and the danger bit is - * set in the stacklet into which the copied one will return. When a - * stacklet is returned from it is no longer needed for anything so it +/* Our_Throw is used in chaining from one stacklet to another. In + * order to improve efficiency, the entire stack is copied neither on + * catch or throw, but is instead copied one stacklet at a time as + * needed. The need to copy a stacklet is signified by the object in + * the STACKLET_REUSE_FLAG of a stacklet. If this object is #F, the + * stacklet is copied when it is "returned into", and the word is set + * to #F in the stacklet into which the copied one will return. When a + * stacklet is returned from, it is no longer needed for anything so it * can be deallocated. A free list of deallocate stacklets is kept in * order to improve the efficiencty of their use. */ -#define Our_Throw(From_Pop_Return, Stacklet) \ -{ Pointer Previous_Stacklet = (Stacklet); \ - Pointer *Stacklet_Top = Current_Stacklet; \ - Stacklet_Top[STACKLET_FREE_LIST_LINK] = \ - ((Pointer) Free_Stacklets); \ - Free_Stacklets = Stacklet_Top; \ - if (!(From_Pop_Return)) \ - { Prev_Restore_History_Stacklet = NULL; \ - Prev_Restore_History_Offset = 0; \ - } \ - if (!(Dangerous(Fast_Vector_Ref(Previous_Stacklet, \ - STACKLET_UNUSED_LENGTH)))) \ - { if (GC_Check(Vector_Length(Previous_Stacklet) + 1)) \ - { Free_Stacklets = \ - ((Pointer *) Free_Stacklets[STACKLET_FREE_LIST_LINK]); \ - Stack_Pointer = Get_End_Of_Stacklet(); \ - Prev_Restore_History_Stacklet = NULL; \ - Prev_Restore_History_Offset = 0; - - /* Backout code inserted here, SUN screw up! */ +#define Our_Throw(From_Pop_Return, Stacklet) \ +{ \ + Pointer Previous_Stacklet; \ + Pointer *Stacklet_Top; \ + \ + Previous_Stacklet = (Stacklet); \ + Stacklet_Top = Current_Stacklet; \ + Stacklet_Top[STACKLET_FREE_LIST_LINK] = \ + ((Pointer) Free_Stacklets); \ + Free_Stacklets = Stacklet_Top; \ + if (!(From_Pop_Return)) \ + { \ + Prev_Restore_History_Stacklet = NULL; \ + Prev_Restore_History_Offset = 0; \ + } \ + if ((Vector_Ref(Previous_Stacklet, STACKLET_REUSE_FLAG)) == NIL) \ + { \ + /* We need to copy the stacklet into which we are \ + returning. \ + */ \ + \ + if (GC_Check(Vector_Length(Previous_Stacklet) + 1)) \ + { \ + /* We don't have enough space to copy the stacklet. */ \ + \ + Free_Stacklets = \ + ((Pointer *) Free_Stacklets[STACKLET_FREE_LIST_LINK]); \ + Stack_Pointer = Get_End_Of_Stacklet(); \ + Prev_Restore_History_Stacklet = NULL; \ + Prev_Restore_History_Offset = 0 + + /* Backout code inserted here by macro user */ - /* Backout code inserted here, SUN screw up! */ - -#define Our_Throw_Part_2() \ - Request_GC(Vector_Length(Previous_Stacklet) + 1); \ - } \ - else /* Space available for copy */ \ - { long Unused_Length, Used_Length; \ - fast Pointer *Old_Stacklet_Top = \ - Get_Pointer(Previous_Stacklet); \ - Pointer *First_Continuation = \ - Nth_Vector_Loc(Previous_Stacklet, \ - ((1 + Vector_Length(Previous_Stacklet)) - \ - CONTINUATION_SIZE)); \ - if (Old_Stacklet_Top == Prev_Restore_History_Stacklet) \ - Prev_Restore_History_Stacklet = NULL; \ - if (First_Continuation[CONTINUATION_RETURN_CODE] == \ - Make_Non_Pointer(TC_RETURN_CODE, RC_JOIN_STACKLETS)) \ - { Pointer *Even_Older_Stacklet = \ - Get_Pointer(First_Continuation[CONTINUATION_EXPRESSION]);\ - Clear_Danger_Bit(Even_Older_Stacklet[STACKLET_UNUSED_LENGTH]);\ - } \ - Stack_Guard = &(Free[STACKLET_HEADER_SIZE]); \ - Free[STACKLET_LENGTH] = Old_Stacklet_Top[STACKLET_LENGTH];\ - Unused_Length = \ - Get_Integer(Old_Stacklet_Top[STACKLET_UNUSED_LENGTH]) + \ - STACKLET_HEADER_SIZE; \ - Free += Unused_Length; \ - Stack_Pointer = Free; \ - Used_Length = \ - (Get_Integer(Old_Stacklet_Top[STACKLET_LENGTH]) - \ - Unused_Length) + 1; \ - Old_Stacklet_Top += Unused_Length; \ - while (--Used_Length >= 0) *Free++ = *Old_Stacklet_Top++; \ - } \ - } \ - else /* No need to copy the stacklet we are going into */ \ - { if (Get_Pointer(Previous_Stacklet)== \ - Prev_Restore_History_Stacklet) \ - Prev_Restore_History_Stacklet = NULL; \ - Set_Current_Stacklet(Previous_Stacklet); \ - } \ +#define Our_Throw_Part_2() \ + Request_GC(Vector_Length(Previous_Stacklet) + 1); \ + } \ + else \ + { \ + /* There is space available to copy the stacklet. */ \ + \ + long Unused_Length; \ + fast Used_Length; \ + fast Pointer *Old_Stacklet_Top, *temp; \ + Pointer *First_Continuation; \ + \ + Old_Stacklet_Top = Get_Pointer(Previous_Stacklet); \ + First_Continuation = \ + Nth_Vector_Loc(Previous_Stacklet, \ + ((1 + Vector_Length(Previous_Stacklet)) - \ + CONTINUATION_SIZE)); \ + if (Old_Stacklet_Top == Prev_Restore_History_Stacklet) \ + { \ + Prev_Restore_History_Stacklet = NULL; \ + } \ + if (First_Continuation[CONTINUATION_RETURN_CODE] == \ + Make_Non_Pointer(TC_RETURN_CODE, RC_JOIN_STACKLETS)) \ + { \ + Pointer Older_Stacklet; \ + \ + Older_Stacklet = First_Continuation[CONTINUATION_EXPRESSION]; \ + Vector_Set(Older_Stacklet, STACKLET_REUSE_FLAG, NIL); \ + } \ + \ + temp = Free; \ + Stack_Guard = &(temp[STACKLET_HEADER_SIZE]); \ + temp[STACKLET_LENGTH] = Old_Stacklet_Top[STACKLET_LENGTH]; \ + Unused_Length = \ + Get_Integer(Old_Stacklet_Top[STACKLET_UNUSED_LENGTH]) + \ + STACKLET_HEADER_SIZE; \ + temp += Unused_Length; \ + Stack_Pointer = temp; \ + Used_Length = \ + (Get_Integer(Old_Stacklet_Top[STACKLET_LENGTH]) - \ + Unused_Length) + 1; \ + Old_Stacklet_Top += Unused_Length; \ + while (--Used_Length >= 0) \ + { \ + *temp++ = *Old_Stacklet_Top++; \ + } \ + Free = temp; \ + } \ + } \ + else \ + { \ + /* No need to copy the stacklet we are going into */ \ + \ + if (Get_Pointer(Previous_Stacklet)== \ + Prev_Restore_History_Stacklet) \ + { \ + Prev_Restore_History_Stacklet = NULL; \ + } \ + Set_Current_Stacklet(Previous_Stacklet); \ + } \ } -#else +#else /* not USE_STACKLETS */ -/* Full size stack in a statically allocated area */ +/* + Full size stack in a statically allocated area + */ #define Stack_Check(P) \ do \ @@ -239,12 +288,14 @@ do \ if ((P) <= Stack_Guard) \ { \ if ((P) <= Absolute_Stack_Base) \ + { \ Microcode_Termination (TERM_STACK_OVERFLOW); \ + } \ Request_Interrupt (INT_Stack_Overflow); \ } \ } while (0) -#define Internal_Will_Push(N) Stack_Check(Stack_Pointer - (N)) +#define Internal_Will_Push(N) Stack_Check(Stack_Pointer - (N)) #define Stack_Allocation_Size(Stack_Blocks) (Stack_Blocks) @@ -262,7 +313,7 @@ do \ Where = Stack_Top; \ } -#define Get_Current_Stacklet() NIL +#define Get_Current_Stacklet() NIL #define Set_Current_Stacklet(Where) {} @@ -273,9 +324,9 @@ do \ STACKLET_UNUSED_LENGTH))))) /* Never allocate more space */ -#define New_Stacklet_Size(N) 0 +#define New_Stacklet_Size(N) 0 -#define Get_End_Of_Stacklet() Stack_Top +#define Get_End_Of_Stacklet() Stack_Top /* Not needed in this version */ @@ -284,7 +335,8 @@ do \ #define Within_Stacklet_Backout() /* This piece of code KNOWS which way the stack grows. - The assumption is that successive pushes modify decreasing addresses. */ + The assumption is that successive pushes modify decreasing addresses. + */ /* Clear the stack and replace it with a copy of the contents of the control point. Also disables the history collection mechanism, @@ -293,45 +345,62 @@ do \ #define Our_Throw(From_Pop_Return, P) \ { \ Pointer Control_Point; \ - long NCells, Offset; \ fast Pointer *To_Where, *From_Where; \ - fast long len; \ + fast long len, valid, invalid; \ \ Control_Point = (P); \ if (Consistency_Check) \ - if (Type_Code (Control_Point) != TC_CONTROL_POINT) \ + { \ + if (OBJECT_TYPE(Control_Point) != TC_CONTROL_POINT) \ + { \ Microcode_Termination (TERM_BAD_STACK); \ + } \ + } \ len = Vector_Length (Control_Point); \ - NCells = ((len - 1) \ - - Get_Integer (Vector_Ref (Control_Point, \ - STACKLET_UNUSED_LENGTH))); \ + invalid = ((Get_Integer (Vector_Ref (Control_Point, \ + STACKLET_UNUSED_LENGTH))) + \ + STACKLET_HEADER_SIZE); \ + valid = ((len + 1) - invalid); \ IntCode &= (~ INT_Stack_Overflow); \ - Stack_Check (Stack_Top - NCells); \ - From_Where = Nth_Vector_Loc (Control_Point, STACKLET_HEADER_SIZE); \ - From_Where = Nth_Vector_Loc (Control_Point, ((len + 1) - NCells)); \ - To_Where = (Stack_Top - NCells); \ + To_Where = (Stack_Top - valid); \ + From_Where = Nth_Vector_Loc (Control_Point, invalid); \ + Stack_Check (To_Where); \ Stack_Pointer = To_Where; \ - for (len = 0; len < NCells; len++) \ + while (--valid >= 0) \ + { \ *To_Where++ = *From_Where++; \ + } \ + \ if (Consistency_Check) \ + { \ if ((To_Where != Stack_Top) || \ - (From_Where != Nth_Vector_Loc (Control_Point, \ - (1 + Vector_Length (Control_Point))))) \ + (From_Where != \ + Nth_Vector_Loc (Control_Point, (1 + len)))) \ + { \ Microcode_Termination (TERM_BAD_STACK); \ + } \ + } \ if (!(From_Pop_Return)) \ + { \ + Prev_Restore_History_Stacklet = NULL; \ + Prev_Restore_History_Offset = 0; \ + if ((!Valid_Fixed_Obj_Vector ()) || \ + (Get_Fixed_Obj_Slot (Dummy_History) == NIL)) \ { \ - Prev_Restore_History_Stacklet = NULL; \ - Prev_Restore_History_Offset = 0; \ - if ((!Valid_Fixed_Obj_Vector ()) || \ - (Get_Fixed_Obj_Slot (Dummy_History) == NIL)) \ - History = Make_Dummy_History (); \ - else \ - History = Get_Pointer (Get_Fixed_Obj_Slot (Dummy_History)); \ + History = Make_Dummy_History (); \ + } \ + else \ + { \ + History = Get_Pointer (Get_Fixed_Obj_Slot (Dummy_History)); \ } \ - else if (Prev_Restore_History_Stacklet == Get_Pointer (Control_Point)) \ + } \ + else if (Prev_Restore_History_Stacklet == \ + Get_Pointer (Control_Point)) \ + { \ Prev_Restore_History_Stacklet = NULL; \ + } \ } #define Our_Throw_Part_2() -#endif +#endif /* USE_STACKLETS */ diff --git a/v7/src/microcode/storage.c b/v7/src/microcode/storage.c index 168cf618a..dd29c9318 100644 --- a/v7/src/microcode/storage.c +++ b/v7/src/microcode/storage.c @@ -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/storage.c,v 9.36 1987/10/05 18:36:30 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/storage.c,v 9.37 1987/10/09 16:14:23 jinx Rel $ This file defines the storage for global variables for the Scheme Interpreter. */ @@ -239,12 +239,12 @@ char *Return_Names[] = { /* 0x57 */ "COMPILER_CACHE_REFERENCE_APPLY_RESTART", /* 0x58 */ "COMPILER_SAFE_REFERENCE_TRAP_RESTART", /* 0x59 */ "COMPILER_UNASSIGNED_P_TRAP_RESTART", -/* 0x60 */ "COMPILER_CACHE_ASSIGNMENT_RESTART" +/* 0x5A */ "COMPILER_CACHE_ASSIGNMENT_RESTART" }; -#if (MAX_RETURN_CODE != 0x60) +#if (MAX_RETURN_CODE != 0x5A) /* Cause an error */ -#include "Returns.h and storage.c are inconsistent -- Names Table" +#include "error: returns.h and storage.c are inconsistent -- Names Table" #endif long MAX_RETURN = MAX_RETURN_CODE; diff --git a/v7/src/microcode/types.h b/v7/src/microcode/types.h index 2889655cb..651c22611 100644 --- a/v7/src/microcode/types.h +++ b/v7/src/microcode/types.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/types.h,v 9.24 1987/10/05 18:37:00 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/types.h,v 9.25 1987/10/09 16:14:39 jinx Rel $ * * Type code definitions, numerical order * @@ -111,3 +111,6 @@ MIT in each case. */ #define TC_VECTOR_8B TC_CHARACTER_STRING #define TC_ADDRESS TC_FIXNUM #define TC_HUNK3 TC_HUNK3_B + +#define UNMARKED_HISTORY_TYPE TC_HUNK3_A +#define MARKED_HISTORY_TYPE TC_HUNK3_B diff --git a/v7/src/microcode/utabmd.scm b/v7/src/microcode/utabmd.scm index 437ca94b8..3cbf45b91 100644 --- a/v7/src/microcode/utabmd.scm +++ b/v7/src/microcode/utabmd.scm @@ -37,7 +37,7 @@ ;;;; Machine Dependent Type Tables -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utabmd.scm,v 9.37 1987/08/06 19:10:08 jinx Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utabmd.scm,v 9.38 1987/10/09 16:14:47 jinx Rel $ (declare (usual-integrations)) @@ -130,11 +130,11 @@ INTERNED-SYMBOL ;1D (STRING CHARACTER-STRING VECTOR-8B) ;1E ACCESS ;1F - #F ;20 + (HUNK3-A UNMARKED-HISTORY) ;20 DEFINITION ;21 BROKEN-HEART ;22 ASSIGNMENT ;23 - (TRIPLE HUNK3) ;24 + (TRIPLE HUNK3 HUNK3-B MARKED-HISTORY) ;24 IN-PACKAGE ;25 COMBINATION ;26 MANIFEST-NM-VECTOR ;27 @@ -226,6 +226,134 @@ #F ;7D #F ;7E #F ;7F + #F ;80 + #F ;81 + #F ;82 + #F ;83 + #F ;84 + #F ;85 + #F ;86 + #F ;87 + #F ;88 + #F ;89 + #F ;8A + #F ;8B + #F ;8C + #F ;8D + #F ;8E + #F ;8F + #F ;90 + #F ;91 + #F ;92 + #F ;93 + #F ;94 + #F ;95 + #F ;96 + #F ;97 + #F ;98 + #F ;99 + #F ;9A + #F ;9B + #F ;9C + #F ;9D + #F ;9E + #F ;9F + #F ;A0 + #F ;A1 + #F ;A2 + #F ;A3 + #F ;A4 + #F ;A5 + #F ;A6 + #F ;A7 + #F ;A8 + #F ;A9 + #F ;AA + #F ;AB + #F ;AC + #F ;AD + #F ;AE + #F ;AF + #F ;B0 + #F ;B1 + #F ;B2 + #F ;B3 + #F ;B4 + #F ;B5 + #F ;B6 + #F ;B7 + #F ;B8 + #F ;B9 + #F ;BA + #F ;BB + #F ;BC + #F ;BD + #F ;BE + #F ;BF + #F ;C0 + #F ;C1 + #F ;C2 + #F ;C3 + #F ;C4 + #F ;C5 + #F ;C6 + #F ;C7 + #F ;C8 + #F ;C9 + #F ;CA + #F ;CB + #F ;CC + #F ;CD + #F ;CE + #F ;CF + #F ;D0 + #F ;D1 + #F ;D2 + #F ;D3 + #F ;D4 + #F ;D5 + #F ;D6 + #F ;D7 + #F ;D8 + #F ;D9 + #F ;DA + #F ;DB + #F ;DC + #F ;DD + #F ;DE + #F ;DF + #F ;E0 + #F ;E1 + #F ;E2 + #F ;E3 + #F ;E4 + #F ;E5 + #F ;E6 + #F ;E7 + #F ;E8 + #F ;E9 + #F ;EA + #F ;EB + #F ;EC + #F ;ED + #F ;EE + #F ;EF + #F ;F0 + #F ;F1 + #F ;F2 + #F ;F3 + #F ;F4 + #F ;F5 + #F ;F6 + #F ;F7 + #F ;F8 + #F ;F9 + #F ;FA + #F ;FB + #F ;FC + #F ;FD + #F ;FE + #F ;FF )) ;;; [] Returns @@ -322,6 +450,7 @@ COMPILER-CACHE-REFERENCE-APPLY-RESTART ;57 COMPILER-SAFE-REFERENCE-TRAP-RESTART ;58 COMPILER-UNASSIGNED?-TRAP-RESTART ;59 + COMPILER-CACHE-ASSIGNMENT-RESTART ;5A )) ;;; [] Primitives @@ -365,7 +494,7 @@ (CDR FIRST-TAIL) ;$22 (SET-CAR! SET-FIRST!) ;$23 (SET-CDR! SET-FIRST-TAIL!) ;$24 - #F ;$25 + GET-COMMAND-LINE ;$25 TTY-GET-CURSOR ;$26 GENERAL-CAR-CDR ;$27 HUNK3-CONS ;$28 @@ -399,9 +528,9 @@ TRUNCATE-STRING! ;$44 SUBSTRING ;$45 ZERO-FIXNUM? ;$46 - MAKE-OBJECT-SAFE ;$47 - MAKE-OBJECT-DANGEROUS ;$48 - OBJECT-DANGEROUS? ;$49 + #F ;$47 + #F ;$48 + #F ;$49 SUBSTRING->LIST ;$4A MAKE-FILLED-STRING ;$4B PLUS-BIGNUM ;$4C @@ -863,4 +992,4 @@ ;;; This identification string is saved by the system. -"$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utabmd.scm,v 9.37 1987/08/06 19:10:08 jinx Exp $" +"$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utabmd.scm,v 9.38 1987/10/09 16:14:47 jinx Rel $" diff --git a/v7/src/microcode/utils.c b/v7/src/microcode/utils.c index 30e20995f..95d35c4f6 100644 --- a/v7/src/microcode/utils.c +++ b/v7/src/microcode/utils.c @@ -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/utils.c,v 9.33 1987/07/23 21:52:40 cph Exp $ */ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utils.c,v 9.34 1987/10/09 16:15:08 jinx Rel $ */ /* This file contains utilities for interrupts, errors, etc. */ @@ -38,6 +38,8 @@ MIT in each case. */ #include "primitive.h" #include "flonum.h" #include "winder.h" +#include "history.h" +#include "cmpint.h" /* Set_Up_Interrupt is called from the Interrupt * macro to do all of the setup for calling the user's @@ -210,7 +212,8 @@ Err_Print (Micro_Error) void Stack_Death () -{ fprintf(stderr, "\nWill_Push vs. Pushed inconsistency.\n"); +{ + fprintf(stderr, "\nWill_Push vs. Pushed inconsistency.\n"); Microcode_Termination(TERM_BAD_STACK); } @@ -234,7 +237,7 @@ Back_Out_Of_Primitive () * not be in the expression register. */ - if (Safe_Type_Code(expression) == 0) + if (OBJECT_TYPE(expression) == 0) { expression = Make_Non_Pointer(TC_PRIMITIVE, expression); Store_Expression(expression); @@ -245,7 +248,7 @@ Back_Out_Of_Primitive () */ nargs = N_Args_Primitive(Get_Integer(expression)); - if (Type_Code(Stack_Ref(nargs)) == TC_RETURN_ADDRESS) + if (OBJECT_TYPE(Stack_Ref(nargs)) == TC_RETURN_ADDRESS) { /* This clobbers the expression register. */ compiler_apply_procedure(nargs); @@ -276,7 +279,7 @@ signal_error_from_primitive (error_code) long error_code; { Back_Out_Of_Primitive (); - longjmp (*Back_To_Eval, error_code); + PRIMITIVE_ABORT(error_code); /*NOTREACHED*/ } @@ -284,7 +287,7 @@ void signal_interrupt_from_primitive () { Back_Out_Of_Primitive (); - longjmp (*Back_To_Eval, PRIM_INTERRUPT); + PRIMITIVE_ABORT(PRIM_INTERRUPT); /*NOTREACHED*/ } @@ -297,7 +300,7 @@ specl_interrupt_from_primitive(local_mask) Store_Return(RC_RESTORE_INT_MASK); Store_Expression(Make_Unsigned_Fixnum(IntEnb)); IntEnb = (local_mask); - longjmp(*Back_To_Eval, PRIM_INTERRUPT); + PRIMITIVE_ABORT(PRIM_INTERRUPT); /*NOTREACHED*/ } @@ -439,8 +442,8 @@ Do_Micro_Error (Err, From_Pop_Return) /* Do_Micro_Error, continued */ if ((!Valid_Fixed_Obj_Vector()) || - (Type_Code((Error_Vector = - Get_Fixed_Obj_Slot(System_Error_Vector))) != + (OBJECT_TYPE((Error_Vector = + Get_Fixed_Obj_Slot(System_Error_Vector))) != TC_VECTOR)) { fprintf(stderr, @@ -526,26 +529,32 @@ C_String_To_Scheme_String (C_String) Max_Length = ((Space_Before_GC() - STRING_CHARS) * sizeof( Pointer)); if (C_String == NULL) + { + Length = 0; + if (Max_Length < 0) { - Length = 0; - if (Max_Length < 0) - Primitive_GC(3); + Primitive_GC(3); } + } else + { + for (Length = 0; + (*C_String != '\0') && (Length < Max_Length); + Length += 1) { - for (Length = 0; - (*C_String != '\0') && (Length < Max_Length); - Length += 1) - *Next++ = *C_String++; - if (Length >= Max_Length) - { - while (*C_String++ != '\0') - Length += 1; - Primitive_GC(2 + - (((Length + 1) + (sizeof( Pointer) - 1)) - / sizeof( Pointer))); - } + *Next++ = *C_String++; + } + if (Length >= Max_Length) + { + while (*C_String++ != '\0') + { + Length += 1; + } + Primitive_GC(2 + + (((Length + 1) + (sizeof( Pointer) - 1)) + / sizeof( Pointer))); } + } *Next = '\0'; Free += (2 + ((Length + sizeof( Pointer)) / sizeof( Pointer))); Vector_Set(Result, STRING_LENGTH, Length); @@ -587,14 +596,14 @@ Make_Dummy_History () Free[RIB_EXP] = NIL; Free[RIB_ENV] = NIL; Free[RIB_NEXT_REDUCTION] = - Make_Pointer(TC_HUNK3, History_Rib); + Make_Pointer(UNMARKED_HISTORY_TYPE, History_Rib); Free += 3; Result = Free; - Free[HIST_RIB] = Make_Pointer(TC_HUNK3, History_Rib); + Free[HIST_RIB] = Make_Pointer(UNMARKED_HISTORY_TYPE, History_Rib); Free[HIST_NEXT_SUBPROBLEM] = - Make_Pointer(TC_HUNK3, Result); + Make_Pointer(UNMARKED_HISTORY_TYPE, Result); Free[HIST_PREV_SUBPROBLEM] = - Make_Pointer(TC_HUNK3, Result); + Make_Pointer(UNMARKED_HISTORY_TYPE, Result); Free += 3; return Result; } @@ -633,11 +642,18 @@ Copy_Rib (Orig_Rib) for (This_Rib=NULL, Result=Free; (This_Rib != Orig_Rib) && (!GC_Check(0)); This_Rib = Get_Pointer(This_Rib[RIB_NEXT_REDUCTION])) - { if (This_Rib==NULL) This_Rib = Orig_Rib; + { + if (This_Rib == NULL) + { + This_Rib = Orig_Rib; + } Free[RIB_EXP] = This_Rib[RIB_EXP]; Free[RIB_ENV] = This_Rib[RIB_ENV]; - Free[RIB_NEXT_REDUCTION] = Make_Pointer(TC_HUNK3, Free+3); - if (Dangerous(This_Rib[RIB_MARK])) Free[RIB_MARK] |= DANGER_BIT; + Free[RIB_NEXT_REDUCTION] = Make_Pointer(UNMARKED_HISTORY_TYPE, Free+3); + if (HISTORY_MARKED_P(This_Rib[RIB_MARK])) + { + HISTORY_MARK(Free[RIB_MARK]); + } Free += 3; } Store_Address((Free-3)[RIB_NEXT_REDUCTION], C_To_Scheme(Result)); @@ -658,36 +674,56 @@ Restore_History (Hist_Obj) *Orig_Vertebra; if (Consistency_Check) - if (Type_Code(Hist_Obj) != TC_HUNK3) - { printf("Bad history to restore.\n"); + { + if (!(HUNK3_P(Hist_Obj))) + { + fprintf(stderr, "Bad history to restore.\n"); Microcode_Termination(TERM_EXIT); } + } Orig_Vertebra = Get_Pointer(Hist_Obj); - for (Next_Vertebra=NULL, Prev_Vertebra=NULL; + for (Next_Vertebra = NULL, Prev_Vertebra = NULL; Next_Vertebra != Orig_Vertebra; Next_Vertebra = Get_Pointer(Next_Vertebra[HIST_NEXT_SUBPROBLEM])) { Pointer *New_Rib; - if (Prev_Vertebra==NULL) Next_Vertebra = Orig_Vertebra; + + if (Prev_Vertebra == NULL) + { + Next_Vertebra = Orig_Vertebra; + } New_Rib = Copy_Rib(Get_Pointer(Next_Vertebra[HIST_RIB])); - if (Prev_Vertebra==NULL) New_History = Free; - else Prev_Vertebra[HIST_NEXT_SUBPROBLEM] = - Make_Pointer(TC_HUNK3, Free); - Free[HIST_RIB] = Make_Pointer(TC_HUNK3, New_Rib); + if (Prev_Vertebra == NULL) + { + New_History = Free; + } + else + { + Prev_Vertebra[HIST_NEXT_SUBPROBLEM] = + Make_Pointer(UNMARKED_HISTORY_TYPE, Free); + } + Free[HIST_RIB] = Make_Pointer(UNMARKED_HISTORY_TYPE, New_Rib); Free[HIST_NEXT_SUBPROBLEM] = NIL; Free[HIST_PREV_SUBPROBLEM] = - Make_Pointer(TC_HUNK3, Prev_Vertebra); - if (Dangerous(Next_Vertebra[HIST_MARK])) - Free[HIST_MARK] |= DANGER_BIT; + Make_Pointer(UNMARKED_HISTORY_TYPE, Prev_Vertebra); + if (HISTORY_MARKED_P(Next_Vertebra[HIST_MARK])) + { + HISTORY_MARK(Free[HIST_MARK]); + } Prev_Vertebra = Free; Free += 3; - if (GC_Check(0)) return false; + if (GC_Check(0)) + { + return false; + } } Store_Address(New_History[HIST_PREV_SUBPROBLEM], C_To_Scheme(Free-3)); Prev_Vertebra[HIST_NEXT_SUBPROBLEM] = - Make_Pointer(TC_HUNK3, New_History); - if (Dangerous(Orig_Vertebra[HIST_MARK])) - Prev_Vertebra[HIST_MARK] |= DANGER_BIT; + Make_Pointer(UNMARKED_HISTORY_TYPE, New_History); + if (HISTORY_MARKED_P(Orig_Vertebra[HIST_MARK])) + { + HISTORY_MARK(Prev_Vertebra[HIST_MARK]); + } History = New_History; return true; } @@ -802,23 +838,37 @@ Allocate_New_Stacklet (N) Old_Stacklet = Current_Stacklet; Terminate_Old_Stacklet(); if ((Free_Stacklets == NULL) || - ((N+STACKLET_SLACK) > Get_Integer(Free_Stacklets[STACKLET_LENGTH]))) - { long size = New_Stacklet_Size(N); - /* Room is set aside for the two header bytes of a stacklet plus - * the two bytes required for the RC_JOIN_STACKLETS frame. + ((N + STACKLET_SLACK) > + Get_Integer(Free_Stacklets[STACKLET_LENGTH]))) + { + long size; + + /* + Room is set aside for the header bytes of a stacklet plus + the two words required for the RC_JOIN_STACKLETS frame. */ + + size = New_Stacklet_Size(N); if (GC_Check(size)) - { Request_GC(size); - if (Free+size >= Heap_Top) + { + Request_GC(size); + if ((Free + size) >= Heap_Top) + { Microcode_Termination(TERM_STACK_OVERFLOW); + } } - Free[STACKLET_LENGTH] = Make_Non_Pointer(TC_MANIFEST_VECTOR, size-1); + Free[STACKLET_LENGTH] = Make_Non_Pointer(TC_MANIFEST_VECTOR, (size - 1)); Stack_Guard = &(Free[STACKLET_HEADER_SIZE]); Free += size; Stack_Pointer = Free; } - else /* Grab first one on the free list */ - { Pointer *New_Stacklet = Free_Stacklets; + else + { + /* Grab first one on the free list */ + + Pointer *New_Stacklet; + + New_Stacklet = Free_Stacklets; Free_Stacklets = ((Pointer *) Free_Stacklets[STACKLET_FREE_LIST_LINK]); Stack_Pointer = &New_Stacklet[1 + Get_Integer(New_Stacklet[STACKLET_LENGTH])]; @@ -828,13 +878,16 @@ Allocate_New_Stacklet (N) Old_Return = Fetch_Return(); Store_Expression(Make_Pointer(TC_CONTROL_POINT, Old_Stacklet)); Store_Return(RC_JOIN_STACKLETS); -/* Will_Push omitted because size calculation includes enough room. */ + /* + Will_Push omitted because size calculation includes enough room. + */ Save_Cont(); Store_Expression(Old_Expression); Store_Return(Old_Return); return; } -#endif + +#endif /* USE_STACKLETS */ /* Dynamic Winder support code */ @@ -893,26 +946,41 @@ Translate_To_Point (Target) Distance = Get_Integer(Fast_Vector_Ref(Target, STATE_POINT_DISTANCE_TO_ROOT)); if (State_Space == NIL) + { Current_Location = Current_State_Point; + } else + { Current_Location = Vector_Ref(State_Space, STATE_SPACE_NEAREST_POINT); + } if (Target == Current_Location) - longjmp(*Back_To_Eval, PRIM_POP_RETURN); + { + PRIMITIVE_ABORT(PRIM_POP_RETURN); + /*NOTREACHED*/ + } for (Path_Ptr=(&(Path[Distance])), Path_Point=Target, i=0; i <= Distance; i++, Path_Point=Fast_Vector_Ref(Path_Point, STATE_POINT_NEARER_POINT)) + { *Path_Ptr-- = Path_Point; + } From_Depth = Get_Integer(Fast_Vector_Ref(Current_Location, STATE_POINT_DISTANCE_TO_ROOT)); for (Path_Point=Current_Location, Merge_Depth = From_Depth; Merge_Depth > Distance; Merge_Depth--) + { Path_Point = Fast_Vector_Ref(Path_Point, STATE_POINT_NEARER_POINT); + } for (Path_Ptr=(&(Path[Merge_Depth])); Merge_Depth >= 0; Merge_Depth--, Path_Ptr--, Path_Point=Fast_Vector_Ref(Path_Point, STATE_POINT_NEARER_POINT)) + { if (*Path_Ptr == Path_Point) + { break; + } + } #ifdef ENABLE_DEBUGGING_TOOLS if (Merge_Depth < 0) { @@ -933,6 +1001,6 @@ Translate_To_Point (Target) Save_Cont(); Pushed(); IntEnb &= (INT_GC<<1) - 1; /* Disable lower than GC level */ - longjmp(*Back_To_Eval, PRIM_POP_RETURN); + PRIMITIVE_ABORT(PRIM_POP_RETURN); /*NOTREACHED*/ } diff --git a/v7/src/microcode/version.h b/v7/src/microcode/version.h index 7c32a2b1a..87bd31a62 100644 --- a/v7/src/microcode/version.h +++ b/v7/src/microcode/version.h @@ -30,23 +30,23 @@ 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/version.h,v 9.102 1987/10/05 18:37:10 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/version.h,v 9.103 1987/10/09 16:15:31 jinx Exp $ This file contains version information for the microcode. */ /* Scheme system release version */ #ifndef RELEASE -#define RELEASE "5.3.0" +#define RELEASE "6.0.0" #endif /* Microcode release version */ #ifndef VERSION -#define VERSION 9 +#define VERSION 10 #endif #ifndef SUBVERSION -#define SUBVERSION 102 +#define SUBVERSION 1 #endif #ifndef UCODE_TABLES_FILENAME diff --git a/v7/src/microcode/xdebug.c b/v7/src/microcode/xdebug.c index 1008513b3..2397401f2 100644 --- a/v7/src/microcode/xdebug.c +++ b/v7/src/microcode/xdebug.c @@ -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/xdebug.c,v 9.21 1987/01/22 14:37:28 jinx Rel $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/xdebug.c,v 9.22 1987/10/09 16:15:41 jinx Rel $ * * This file contains primitives to debug the memory management in the * Scheme system. @@ -43,67 +43,94 @@ MIT in each case. */ /* New debugging utilities */ #define FULL_EQ 0 -#define SAFE_EQ 1 #define ADDRESS_EQ 2 #define DATUM_EQ 3 -#define SAFE_MASK (~DANGER_BIT) +static Pointer * +Find_Occurrence(From, To, What, Mode) + fast Pointer *From, *To; + Pointer What; + int Mode; +{ + fast Pointer Obj; -static Pointer *Find_Occurrence(From, To, What, Mode) -fast Pointer *From, *To; -Pointer What; -int Mode; -{ fast Pointer Obj; switch (Mode) { default: case FULL_EQ: - { Obj = What; + { + Obj = What; for (; From < To; From++) - if (Safe_Type_Code(*From) == TC_MANIFEST_NM_VECTOR) + { + if (OBJECT_TYPE(*From) == TC_MANIFEST_NM_VECTOR) + { From += Get_Integer(*From); - else if (*From == Obj) return From; + } + else if (*From == Obj) + { + return From; + } + } return To; } - case SAFE_EQ: - { Obj = (What & SAFE_MASK); - for (; From < To; From++) - if (Safe_Type_Code(*From) == TC_MANIFEST_NM_VECTOR) - From += Get_Integer(*From); - else if (((*From) & SAFE_MASK) == Obj) return From; - return To; - } + case ADDRESS_EQ: - { Obj = Datum(What); + { + Obj = OBJECT_DATUM(What); for (; From < To; From++) - if (Safe_Type_Code(*From) == TC_MANIFEST_NM_VECTOR) + { + if (OBJECT_TYPE(*From) == TC_MANIFEST_NM_VECTOR) + { From += Get_Integer(*From); - else if ((Datum(*From) == Obj) && + } + else if ((OBJECT_DATUM(*From) == Obj) && (!(GC_Type_Non_Pointer(*From)))) + { return From; + } + } return To; } case DATUM_EQ: - { Obj = Datum(What); + { + Obj = OBJECT_DATUM(What); for (; From < To; From++) - if (Safe_Type_Code(*From) == TC_MANIFEST_NM_VECTOR) + { + if (OBJECT_TYPE(*From) == TC_MANIFEST_NM_VECTOR) + { From += Get_Integer(*From); - else if (Datum(*From) == Obj) return From; + } + else if (OBJECT_DATUM(*From) == Obj) + { + return From; + } + } return To; } } } -static long Find_In_Area(Name, From, To, Obj, Mode, print_p, store_p) -char *Name; -Pointer *From, *To, Obj; -int Mode; -Boolean print_p, store_p; -{ fast Pointer *Where; +#define PRINT_P 1 +#define STORE_P 2 + +static long +Find_In_Area(Name, From, To, Obj, Mode, print_p, store_p) + char *Name; + Pointer *From, *To, Obj; + int Mode; + Boolean print_p, store_p; +{ + fast Pointer *Where; fast long occurrences = 0; - if (print_p) printf(" Looking in %s:\n", Name); + + if (print_p) + { + printf(" Looking in %s:\n", Name); + } Where = From-1; + while ((Where = Find_Occurrence(Where+1, To, Obj, Mode)) < To) - { occurrences += 1; + { + occurrences += 1; if (print_p) #ifndef b32 printf("Location = 0x%x; Contents = 0x%x\n", @@ -113,27 +140,33 @@ Boolean print_p, store_p; ((long) Where), ((long) (*Where))); #endif if (store_p) + { /* Note that Make_Pointer (vs. Make_Non_Pointer) is correct here!! */ *Free++ = Make_Pointer(TC_ADDRESS, Where); + } } return occurrences; } - -#define PRINT_P 1 -#define STORE_P 2 - -Pointer Find_Who_Points(Obj, Find_Mode, Collect_Mode) -Pointer Obj; -int Find_Mode, Collect_Mode; -{ long n = 0; + +Pointer +Find_Who_Points(Obj, Find_Mode, Collect_Mode) + Pointer Obj; + int Find_Mode, Collect_Mode; +{ + long n = 0; Pointer *Saved_Free = Free; Boolean print_p = (Collect_Mode & PRINT_P); Boolean store_p = (Collect_Mode & STORE_P); + /* No overflow check done. Hopefully referenced few times, or invoked before to find the count and insure that there is enough space. */ - if (store_p) Free += 1; + if (store_p) + { + Free += 1; + } if (print_p) - { putchar('\n'); + { + putchar('\n'); #ifndef b32 printf("*** Looking for Obj = 0x%x; Find_Mode = %2d ***\n", Obj, Find_Mode); @@ -153,24 +186,39 @@ int Find_Mode, Collect_Mode; Stack_Pointer, Stack_Top, Obj, Find_Mode, print_p, store_p); #endif - if (print_p) printf("Done.\n"); + if (print_p) + { + printf("Done.\n"); + } if (store_p) - { *Saved_Free = Make_Non_Pointer(TC_MANIFEST_VECTOR, n); + { + *Saved_Free = Make_Non_Pointer(TC_MANIFEST_VECTOR, n); return Make_Pointer(TC_VECTOR, Saved_Free); } - else return Make_Non_Pointer(TC_FIXNUM, n); + else + { + return Make_Non_Pointer(TC_FIXNUM, n); + } } Print_Memory(Where, How_Many) -Pointer *Where; -long How_Many; -{ fast Pointer *End = &Where[How_Many]; + Pointer *Where; + long How_Many; +{ + fast Pointer *End = &Where[How_Many]; + #ifndef b32 printf("\n*** Memory from 0x%x to 0x%x (excluded) ***\n", Where, End); - while (Where < End) printf("0x%x\n", *Where++); + while (Where < End) + { + printf("0x%x\n", *Where++); + } #else printf("\n*** Memory from 0x%08x to 0x%08x (excluded) ***\n", Where, End); - while (Where < End) printf("0x%08x\n", *Where++); + while (Where < End) + { + printf("0x%08x\n", *Where++); + } #endif printf("Done.\n"); return; @@ -179,27 +227,36 @@ long How_Many; /* Primitives to give scheme a handle on utilities from DEBUG.C */ Define_Primitive(Prim_Show_Pure, 0, "SHOW-PURE") -{ printf("\n*** Constant & Pure Space: ***\n"); +{ + Primitive_0_Args(); + + printf("\n*** Constant & Pure Space: ***\n"); Show_Pure(); return TRUTH; } Define_Primitive(Prim_Show_Env, 1, "SHOW-ENV") -{ Primitive_1_Arg(); +{ + Primitive_1_Arg(); + printf("\n*** Environment = 0x%x ***\n", Arg1); Show_Env(Arg1); return TRUTH; } Define_Primitive(Prim_Stack_Trace, 0, "STACK-TRACE") -{ Primitive_0_Args(); +{ + Primitive_0_Args(); + printf("\n*** Back Trace: ***\n"); Back_Trace(); return TRUTH; } Define_Primitive(Prim_Find_Symbol, 1, "FIND-SYMBOL") -{ Primitive_1_Arg(); +{ + Primitive_1_Arg(); + Find_Symbol(); return TRUTH; } @@ -207,21 +264,33 @@ Define_Primitive(Prim_Find_Symbol, 1, "FIND-SYMBOL") /* Primitives to give scheme a handle on utilities on this file. */ Define_Primitive(Prim_Debug_Flags, 0, "DEBUG-FLAGS") -{ Handle_Debug_Flags(); +{ + Primitive_0_Args(); + + Handle_Debug_Flags(); return TRUTH; } Define_Primitive(Prim_Find_Who_Points, 3, "FIND-WHO-POINTS") -{ Primitive_3_Args(); +{ + Primitive_3_Args(); + return Find_Who_Points(Arg1, Get_Integer(Arg2), Get_Integer(Arg3)); } Define_Primitive(Prim_Print_Memory, 2, "PRINT-MEMORY") -{ Pointer *Base; +{ + Pointer *Base; Primitive_2_Args(); + if (GC_Type_Non_Pointer(Arg1)) + { Base = ((Pointer *) Datum(Arg1)); - else Base = Get_Pointer(Arg1); + } + else + { + Base = Get_Pointer(Arg1); + } Print_Memory(Base, Get_Integer(Arg2)); return TRUTH; } diff --git a/v8/src/microcode/gctype.c b/v8/src/microcode/gctype.c index 907a05069..4816808ed 100644 --- a/v8/src/microcode/gctype.c +++ b/v8/src/microcode/gctype.c @@ -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/gctype.c,v 9.24 1987/10/05 18:32:37 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/gctype.c,v 9.25 1987/10/09 16:11:06 jinx Rel $ * * This file contains the table which maps between Types and * GC Types. @@ -41,7 +41,7 @@ MIT in each case. */ /* Mapping GC_Type to Type_Codes */ /*********************************/ -int GC_Type_Map[MAX_SAFE_TYPE + 1] = { +int GC_Type_Map[MAX_TYPE_CODE + 1] = { GC_Non_Pointer, /* TC_NULL,etc */ GC_Pair, /* TC_LIST */ GC_Non_Pointer, /* TC_CHARACTER */ @@ -179,9 +179,141 @@ int GC_Type_Map[MAX_SAFE_TYPE + 1] = { GC_Undefined, /* 0x7C */ GC_Undefined, /* 0x7D */ GC_Undefined, /* 0x7E */ - GC_Undefined /* 0x7F */ + GC_Undefined, /* 0x7F */ + + GC_Undefined, /* 0x80 */ + GC_Undefined, /* 0x81 */ + GC_Undefined, /* 0x82 */ + GC_Undefined, /* 0x83 */ + GC_Undefined, /* 0x84 */ + GC_Undefined, /* 0x85 */ + GC_Undefined, /* 0x86 */ + GC_Undefined, /* 0x87 */ + GC_Undefined, /* 0x88 */ + GC_Undefined, /* 0x89 */ + GC_Undefined, /* 0x8A */ + GC_Undefined, /* 0x8B */ + GC_Undefined, /* 0x8C */ + GC_Undefined, /* 0x8D */ + GC_Undefined, /* 0x8E */ + GC_Undefined, /* 0x8F */ + GC_Undefined, /* 0x90 */ + GC_Undefined, /* 0x91 */ + GC_Undefined, /* 0x92 */ + GC_Undefined, /* 0x93 */ + GC_Undefined, /* 0x94 */ + GC_Undefined, /* 0x95 */ + GC_Undefined, /* 0x96 */ + GC_Undefined, /* 0x97 */ + GC_Undefined, /* 0x98 */ + GC_Undefined, /* 0x99 */ + GC_Undefined, /* 0x9A */ + GC_Undefined, /* 0x9B */ + GC_Undefined, /* 0x9C */ + GC_Undefined, /* 0x9D */ + GC_Undefined, /* 0x9E */ + GC_Undefined, /* 0x9F */ + GC_Undefined, /* 0xA0 */ + GC_Undefined, /* 0xA1 */ + GC_Undefined, /* 0xA2 */ + GC_Undefined, /* 0xA3 */ + GC_Undefined, /* 0xA4 */ + GC_Undefined, /* 0xA5 */ + GC_Undefined, /* 0xA6 */ + GC_Undefined, /* 0xA7 */ + GC_Undefined, /* 0xA8 */ + GC_Undefined, /* 0xA9 */ + GC_Undefined, /* 0xAA */ + GC_Undefined, /* 0xAB */ + GC_Undefined, /* 0xAC */ + GC_Undefined, /* 0xAD */ + GC_Undefined, /* 0xAE */ + GC_Undefined, /* 0xAF */ + + GC_Undefined, /* 0xB0 */ + GC_Undefined, /* 0xB1 */ + GC_Undefined, /* 0xB2 */ + GC_Undefined, /* 0xB3 */ + GC_Undefined, /* 0xB4 */ + GC_Undefined, /* 0xB5 */ + GC_Undefined, /* 0xB6 */ + GC_Undefined, /* 0xB7 */ + GC_Undefined, /* 0xB8 */ + GC_Undefined, /* 0xB9 */ + GC_Undefined, /* 0xBA */ + GC_Undefined, /* 0xBB */ + GC_Undefined, /* 0xBC */ + GC_Undefined, /* 0xBD */ + GC_Undefined, /* 0xBE */ + GC_Undefined, /* 0xBF */ + GC_Undefined, /* 0xC0 */ + GC_Undefined, /* 0xC1 */ + GC_Undefined, /* 0xC2 */ + GC_Undefined, /* 0xC3 */ + GC_Undefined, /* 0xC4 */ + GC_Undefined, /* 0xC5 */ + GC_Undefined, /* 0xC6 */ + GC_Undefined, /* 0xC7 */ + GC_Undefined, /* 0xC8 */ + GC_Undefined, /* 0xC9 */ + GC_Undefined, /* 0xCA */ + GC_Undefined, /* 0xCB */ + GC_Undefined, /* 0xCC */ + GC_Undefined, /* 0xCD */ + GC_Undefined, /* 0xCE */ + GC_Undefined, /* 0xCF */ + GC_Undefined, /* 0xD0 */ + GC_Undefined, /* 0xD1 */ + GC_Undefined, /* 0xD2 */ + GC_Undefined, /* 0xD3 */ + GC_Undefined, /* 0xD4 */ + GC_Undefined, /* 0xD5 */ + GC_Undefined, /* 0xD6 */ + GC_Undefined, /* 0xD7 */ + GC_Undefined, /* 0xD8 */ + GC_Undefined, /* 0xD9 */ + GC_Undefined, /* 0xDA */ + GC_Undefined, /* 0xDB */ + GC_Undefined, /* 0xDC */ + GC_Undefined, /* 0xDD */ + GC_Undefined, /* 0xDE */ + GC_Undefined, /* 0xDF */ + + GC_Undefined, /* 0xE0 */ + GC_Undefined, /* 0xE1 */ + GC_Undefined, /* 0xE2 */ + GC_Undefined, /* 0xE3 */ + GC_Undefined, /* 0xE4 */ + GC_Undefined, /* 0xE5 */ + GC_Undefined, /* 0xE6 */ + GC_Undefined, /* 0xE7 */ + GC_Undefined, /* 0xE8 */ + GC_Undefined, /* 0xE9 */ + GC_Undefined, /* 0xEA */ + GC_Undefined, /* 0xEB */ + GC_Undefined, /* 0xEC */ + GC_Undefined, /* 0xED */ + GC_Undefined, /* 0xEE */ + GC_Undefined, /* 0xEF */ + GC_Undefined, /* 0xF0 */ + GC_Undefined, /* 0xF1 */ + GC_Undefined, /* 0xF2 */ + GC_Undefined, /* 0xF3 */ + GC_Undefined, /* 0xF4 */ + GC_Undefined, /* 0xF5 */ + GC_Undefined, /* 0xF6 */ + GC_Undefined, /* 0xF7 */ + GC_Undefined, /* 0xF8 */ + GC_Undefined, /* 0xF9 */ + GC_Undefined, /* 0xFA */ + GC_Undefined, /* 0xFB */ + GC_Undefined, /* 0xFC */ + GC_Undefined, /* 0xFD */ + GC_Undefined, /* 0xFE */ + GC_Undefined /* 0xFF */ }; -#if (MAX_SAFE_TYPE != 0x7F) +#if (MAX_TYPE_CODE != 0xFF) #include "gctype.c and scheme.h inconsistent -- GC_Type_Map" #endif + diff --git a/v8/src/microcode/interp.c b/v8/src/microcode/interp.c index 845434930..60a5d3b5e 100644 --- a/v8/src/microcode/interp.c +++ b/v8/src/microcode/interp.c @@ -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/interp.c,v 9.32 1987/10/05 18:32:48 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/interp.c,v 9.33 1987/10/09 16:11:55 jinx Exp $ * * This file contains the heart of the Scheme Scode * interpreter @@ -42,6 +42,8 @@ MIT in each case. */ #include "locks.h" #include "trap.h" #include "lookup.h" +#include "history.h" +#include "cmpint.h" #include "zones.h" /* In order to make the interpreter tail recursive (i.e. diff --git a/v8/src/microcode/object.h b/v8/src/microcode/object.h index cdd213dd7..4ebfd5b30 100644 --- a/v8/src/microcode/object.h +++ b/v8/src/microcode/object.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/object.h,v 9.25 1987/10/05 18:35:46 jinx Exp $ */ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/object.h,v 9.26 1987/10/09 16:12:57 jinx Rel $ */ /* This file contains definitions pertaining to the C view of Scheme pointers: widths of fields, extraction macros, pre-computed @@ -46,21 +46,11 @@ MIT in each case. */ #define TYPE_CODE_LENGTH 8 /* Not CHAR_SIZE!! */ #define MAX_TYPE_CODE 0xFF /* ((1<> ADDRESS_LENGTH) & MAX_TYPE_CODE) -#define safe_pointer_type(P) (((P) >> ADDRESS_LENGTH) & SAFE_TYPE_MASK) #else /* Faster for logical shifts */ #define OBJECT_TYPE(P) ((P) >> ADDRESS_LENGTH) -#define safe_pointer_type(P) ((pointer_type (P)) & SAFE_TYPE_MASK) #endif #define OBJECT_DATUM(P) ((P) & ADDRESS_MASK) /* compatibility definitions */ #define Type_Code(P) (OBJECT_TYPE (P)) -#define Safe_Type_Code(P) (safe_pointer_type (P)) #define Datum(P) (OBJECT_DATUM (P)) #define pointer_type(P) (OBJECT_TYPE (P)) @@ -103,7 +89,7 @@ MIT in each case. */ #define Make_Object(TC, D) \ ((((unsigned) (TC)) << ADDRESS_LENGTH) | (OBJECT_DATUM (D))) -#ifndef Heap_In_Low_Memory /* Safe version */ +#ifndef Heap_In_Low_Memory /* Portable version */ typedef Pointer *relocation_type; /* Used to relocate pointers on fasload */ @@ -209,6 +195,10 @@ typedef long relocation_type; /* Used to relocate pointers on fasload */ ((OBJECT_TYPE (object)) == TC_BIG_FLONUM) \ ((OBJECT_TYPE (object)) == TC_COMPLEX)) +#define HUNK3_P(object) \ + (((OBJECT_TYPE(object)) == TC_HUNK3_A) || \ + ((OBJECT_TYPE(object)) == TC_HUNK3_B)) + #define MAKE_FIXNUM(N) (Make_Non_Pointer (TC_FIXNUM, (N))) #define FIXNUM_NEGATIVE_P(fixnum) (((fixnum) & FIXNUM_SIGN_BIT) != 0) #define MAKE_UNSIGNED_FIXNUM(N) (FIXNUM_ZERO + (N)) @@ -225,7 +215,7 @@ do \ } while (0) #define BOOLEAN_TO_OBJECT(expression) ((expression) ? TRUTH : NIL) - + #define Make_Broken_Heart(N) (BROKEN_HEART_ZERO + (N)) #define Make_Unsigned_Fixnum(N) (FIXNUM_ZERO + (N)) #define Make_Signed_Fixnum(N) Make_Non_Pointer( TC_FIXNUM, (N)) @@ -246,14 +236,6 @@ do \ #define BYTES_TO_POINTERS(nbytes) \ (((nbytes) + ((sizeof (Pointer)) - 1)) / (sizeof (Pointer))) -/* Playing with the danger bit */ - -#define Without_Danger_Bit(P) ((P) & (~DANGER_BIT)) -#define Dangerous(P) ((P & DANGER_BIT) != 0) -#define Clear_Danger_Bit(P) P &= ~DANGER_BIT -#define Set_Danger_Bit(P) P |= DANGER_BIT -/* Side effect testing */ - #define Is_Constant(address) \ (((address) >= Constant_Space) && ((address) < Free_Constant)) diff --git a/v8/src/microcode/ppband.c b/v8/src/microcode/ppband.c index 3763a4aa6..26e04a355 100644 --- a/v8/src/microcode/ppband.c +++ b/v8/src/microcode/ppband.c @@ -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/ppband.c,v 9.27 1987/10/05 18:30:44 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/ppband.c,v 9.28 1987/10/09 16:08:24 jinx Rel $ * * Dumps Scheme FASL in user-readable form . */ @@ -79,7 +79,7 @@ Close_Dump_File() #ifdef Heap_In_Low_Memory #ifdef spectrum -#define File_To_Pointer(P) ((((long) (P))&ADDRESS_MASK) / sizeof(Pointer)) +#define File_To_Pointer(P) ((((long) (P)) & ADDRESS_MASK) / sizeof(Pointer)) #else #define File_To_Pointer(P) ((P) / sizeof(Pointer)) #endif /* spectrum */ @@ -107,8 +107,8 @@ static Pointer *Data, *end_of_memory; Boolean scheme_string(From, Quoted) -long From; -Boolean Quoted; + long From; + Boolean Quoted; { fast long i, Count; fast char *Chars; @@ -129,11 +129,11 @@ Boolean Quoted; return false; } -#define via(File_Address) Relocate(Address(Data[File_Address])) +#define via(File_Address) Relocate(OBJECT_DATUM(Data[File_Address])) void scheme_symbol(From) -long From; + long From; { Pointer *symbol; @@ -151,13 +151,11 @@ Display(Location, Type, The_Datum) long Points_To; printf("%5x: %2x|%6x ", Location, Type, The_Datum); - if (GC_Type_Map[Type & MAX_SAFE_TYPE] != GC_Non_Pointer) + if (GC_Type_Map[Type] != GC_Non_Pointer) Points_To = Relocate((Pointer *) The_Datum); else Points_To = The_Datum; - if (Type > MAX_SAFE_TYPE) - printf("*"); - switch (Type & SAFE_TYPE_MASK) + switch (Type) { /* "Strange" cases */ case TC_NULL: if (The_Datum == 0) { printf("NIL\n"); @@ -253,11 +251,12 @@ Display(Location, Type, The_Datum) } main(argc, argv) -int argc; -char **argv; + int argc; + char **argv; { Pointer *Next; long i, total_length; + if (argc == 1) { if (!Read_Header()) @@ -296,44 +295,54 @@ char **argv; } total_length -= Heap_Count; if (total_length < Const_Count) + { Const_Count = total_length; + } } printf("Heap contents:\n\n"); for (Next = Data, i = 0; i < Heap_Count; Next++, i++) { - if (Safe_Type_Code(*Next) == TC_MANIFEST_NM_VECTOR) + if (OBJECT_TYPE(*Next) == TC_MANIFEST_NM_VECTOR) { long j, count; count = Get_Integer(*Next); - Display(i, Type_Code(*Next), Address(*Next)); + Display(i, OBJECT_TYPE(*Next), OBJECT_DATUM(*Next)); Next += 1; for (j = 0; j < count ; j++, Next++) + { printf(" %02x%06x\n", - Type_Code(*Next), Address(*Next)); + OBJECT_TYPE(*Next), OBJECT_DATUM(*Next)); + } i += count; Next -= 1; } else - Display(i, Type_Code(*Next), Address(*Next)); + { + Display(i, OBJECT_TYPE(*Next), OBJECT_DATUM(*Next)); + } } printf("\n\nConstant space:\n\n"); for (; i < Heap_Count + Const_Count; Next++, i++) { - if (Safe_Type_Code(*Next) == TC_MANIFEST_NM_VECTOR) + if (OBJECT_TYPE(*Next) == TC_MANIFEST_NM_VECTOR) { long j, count; count = Get_Integer(*Next); - Display(i, Type_Code(*Next), Address(*Next)); + Display(i, OBJECT_TYPE(*Next), OBJECT_DATUM(*Next)); Next += 1; for (j = 0; j < count ; j++, Next++) + { printf(" %02x%06x\n", - Type_Code(*Next), Address(*Next)); + OBJECT_TYPE(*Next), OBJECT_DATUM(*Next)); + } i += count; Next -= 1; } else - Display(i, Type_Code(*Next), Address(*Next)); + { + Display(i, OBJECT_TYPE(*Next), OBJECT_DATUM(*Next)); + } } } diff --git a/v8/src/microcode/returns.h b/v8/src/microcode/returns.h index 2d522215a..ba5164fa4 100644 --- a/v8/src/microcode/returns.h +++ b/v8/src/microcode/returns.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/returns.h,v 9.27 1987/10/05 18:36:01 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/returns.h,v 9.28 1987/10/09 16:13:30 jinx Exp $ * * Return codes. These are placed in Return when an * interpreter operation needs to operate in several @@ -121,8 +121,8 @@ MIT in each case. */ #define RC_COMP_CACHE_REF_APPLY_RESTART 0x57 #define RC_COMP_SAFE_REF_TRAP_RESTART 0x58 #define RC_COMP_UNASSIGNED_TRAP_RESTART 0x59 -#define RC_COMP_CACHE_ASSIGNMENT_RESTART 0x60 +#define RC_COMP_CACHE_ASSIGNMENT_RESTART 0x5A -#define MAX_RETURN_CODE 0x60 +#define MAX_RETURN_CODE 0x5A /* When adding return codes, don't forget to update storage.c too. */ diff --git a/v8/src/microcode/types.h b/v8/src/microcode/types.h index 52aa4207b..b410b3e85 100644 --- a/v8/src/microcode/types.h +++ b/v8/src/microcode/types.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/types.h,v 9.24 1987/10/05 18:37:00 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/types.h,v 9.25 1987/10/09 16:14:39 jinx Rel $ * * Type code definitions, numerical order * @@ -111,3 +111,6 @@ MIT in each case. */ #define TC_VECTOR_8B TC_CHARACTER_STRING #define TC_ADDRESS TC_FIXNUM #define TC_HUNK3 TC_HUNK3_B + +#define UNMARKED_HISTORY_TYPE TC_HUNK3_A +#define MARKED_HISTORY_TYPE TC_HUNK3_B diff --git a/v8/src/microcode/utabmd.scm b/v8/src/microcode/utabmd.scm index 336f2515d..6e38e8d5f 100644 --- a/v8/src/microcode/utabmd.scm +++ b/v8/src/microcode/utabmd.scm @@ -37,7 +37,7 @@ ;;;; Machine Dependent Type Tables -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/utabmd.scm,v 9.37 1987/08/06 19:10:08 jinx Exp $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/utabmd.scm,v 9.38 1987/10/09 16:14:47 jinx Rel $ (declare (usual-integrations)) @@ -130,11 +130,11 @@ INTERNED-SYMBOL ;1D (STRING CHARACTER-STRING VECTOR-8B) ;1E ACCESS ;1F - #F ;20 + (HUNK3-A UNMARKED-HISTORY) ;20 DEFINITION ;21 BROKEN-HEART ;22 ASSIGNMENT ;23 - (TRIPLE HUNK3) ;24 + (TRIPLE HUNK3 HUNK3-B MARKED-HISTORY) ;24 IN-PACKAGE ;25 COMBINATION ;26 MANIFEST-NM-VECTOR ;27 @@ -226,6 +226,134 @@ #F ;7D #F ;7E #F ;7F + #F ;80 + #F ;81 + #F ;82 + #F ;83 + #F ;84 + #F ;85 + #F ;86 + #F ;87 + #F ;88 + #F ;89 + #F ;8A + #F ;8B + #F ;8C + #F ;8D + #F ;8E + #F ;8F + #F ;90 + #F ;91 + #F ;92 + #F ;93 + #F ;94 + #F ;95 + #F ;96 + #F ;97 + #F ;98 + #F ;99 + #F ;9A + #F ;9B + #F ;9C + #F ;9D + #F ;9E + #F ;9F + #F ;A0 + #F ;A1 + #F ;A2 + #F ;A3 + #F ;A4 + #F ;A5 + #F ;A6 + #F ;A7 + #F ;A8 + #F ;A9 + #F ;AA + #F ;AB + #F ;AC + #F ;AD + #F ;AE + #F ;AF + #F ;B0 + #F ;B1 + #F ;B2 + #F ;B3 + #F ;B4 + #F ;B5 + #F ;B6 + #F ;B7 + #F ;B8 + #F ;B9 + #F ;BA + #F ;BB + #F ;BC + #F ;BD + #F ;BE + #F ;BF + #F ;C0 + #F ;C1 + #F ;C2 + #F ;C3 + #F ;C4 + #F ;C5 + #F ;C6 + #F ;C7 + #F ;C8 + #F ;C9 + #F ;CA + #F ;CB + #F ;CC + #F ;CD + #F ;CE + #F ;CF + #F ;D0 + #F ;D1 + #F ;D2 + #F ;D3 + #F ;D4 + #F ;D5 + #F ;D6 + #F ;D7 + #F ;D8 + #F ;D9 + #F ;DA + #F ;DB + #F ;DC + #F ;DD + #F ;DE + #F ;DF + #F ;E0 + #F ;E1 + #F ;E2 + #F ;E3 + #F ;E4 + #F ;E5 + #F ;E6 + #F ;E7 + #F ;E8 + #F ;E9 + #F ;EA + #F ;EB + #F ;EC + #F ;ED + #F ;EE + #F ;EF + #F ;F0 + #F ;F1 + #F ;F2 + #F ;F3 + #F ;F4 + #F ;F5 + #F ;F6 + #F ;F7 + #F ;F8 + #F ;F9 + #F ;FA + #F ;FB + #F ;FC + #F ;FD + #F ;FE + #F ;FF )) ;;; [] Returns @@ -322,6 +450,7 @@ COMPILER-CACHE-REFERENCE-APPLY-RESTART ;57 COMPILER-SAFE-REFERENCE-TRAP-RESTART ;58 COMPILER-UNASSIGNED?-TRAP-RESTART ;59 + COMPILER-CACHE-ASSIGNMENT-RESTART ;5A )) ;;; [] Primitives @@ -365,7 +494,7 @@ (CDR FIRST-TAIL) ;$22 (SET-CAR! SET-FIRST!) ;$23 (SET-CDR! SET-FIRST-TAIL!) ;$24 - #F ;$25 + GET-COMMAND-LINE ;$25 TTY-GET-CURSOR ;$26 GENERAL-CAR-CDR ;$27 HUNK3-CONS ;$28 @@ -399,9 +528,9 @@ TRUNCATE-STRING! ;$44 SUBSTRING ;$45 ZERO-FIXNUM? ;$46 - MAKE-OBJECT-SAFE ;$47 - MAKE-OBJECT-DANGEROUS ;$48 - OBJECT-DANGEROUS? ;$49 + #F ;$47 + #F ;$48 + #F ;$49 SUBSTRING->LIST ;$4A MAKE-FILLED-STRING ;$4B PLUS-BIGNUM ;$4C @@ -863,4 +992,4 @@ ;;; This identification string is saved by the system. -"$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/utabmd.scm,v 9.37 1987/08/06 19:10:08 jinx Exp $" +"$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/utabmd.scm,v 9.38 1987/10/09 16:14:47 jinx Rel $" diff --git a/v8/src/microcode/version.h b/v8/src/microcode/version.h index e708145b2..ca9d541e7 100644 --- a/v8/src/microcode/version.h +++ b/v8/src/microcode/version.h @@ -30,23 +30,23 @@ 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/version.h,v 9.102 1987/10/05 18:37:10 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/version.h,v 9.103 1987/10/09 16:15:31 jinx Exp $ This file contains version information for the microcode. */ /* Scheme system release version */ #ifndef RELEASE -#define RELEASE "5.3.0" +#define RELEASE "6.0.0" #endif /* Microcode release version */ #ifndef VERSION -#define VERSION 9 +#define VERSION 10 #endif #ifndef SUBVERSION -#define SUBVERSION 102 +#define SUBVERSION 1 #endif #ifndef UCODE_TABLES_FILENAME