- History now uses two distinct types for marked and unmarked versions.
- Stacklets/control points have a separate word used as the reuse flag.
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.
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) ?
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.
error_bad_range_arg (2);
if (number == 0)
- zero_to_bit_string (length);
+ {
+ return (zero_to_bit_string (length));
+ }
else
{
Pointer result;
/* -*-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
#define STRING_SIZE 512
#define BLOCKSIZE 1024
#define blocks(n) ((n)*BLOCKSIZE)
-\f
+
/* 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;
}
-
+\f
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]);
+ }
}
\f
-/* 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();
+\f
+/*
+ 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];
+ }
+\f
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;
}
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;
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 */
+\f
+/* 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. */
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 */
-\f
-/* 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));
}
\f
#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);
+\f
+ /* 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;
}
\f
/* Boot Scheme */
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)
{
/*NOTREACHED*/
}
\f
-#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));
-}
-\f
-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;
-}
-\f
/*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 +
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;
+\f
case TERM_NO_ERROR_HANDLER:
printf("No handler for error code: %d", Micro_Error);
break;
}
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();
Exit_Hook();
Exit_Scheme(value);
}
+\f
+/* 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));
+}
+\f
+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;
+ }
+\f
+ /* 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;
+}
+\f
+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;
+}
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
*/
and where <locked> is #!true if someone wants slot kept for a time.
*/
-\f
+
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;
}
\f
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;
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?!")
+\f
/* (SET-CAR-IF-EQ?! <CONS Cell> <New Value> <Old Value>)
Replaces the CAR of <CONS Cell> with <New Value> if it used to contain
<Old Value>. The value returned is either <CONS Cell> (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;
+ }
}
-\f
-Define_Primitive(Prim_Set_Cdr_If_Eq, 3, "SET-CDR-IF-EQ?!")
+
/* (SET-CDR-IF-EQ?! <CONS Cell> <New Value> <Old Value>)
Replaces the CDR of <CONS Cell> with <New Value> if it used to contain
<Old Value>. The value returned is either <CONS Cell> (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;
+ }
+}
+\f
/* (VECTOR-SET-IF-EQ?! <Vector> <Offset> <New Value> <Old Value>)
Replaces the <Offset>th element of <Vector> with <New Value> if it used
to contain <Old Value>. The value returned is either <Vector> (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?! <Triple> <Offset> <New Value> <Old Value>)
Replaces the <Offset>th CXR of <Triple> with <New Value> if it used to
contain <Old Value>. The value returned is either <Triple> (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;
+ }
}
\f
-Define_Primitive(Prim_Future_Ref, 2, "FUTURE-REF")
/* (FUTURE-REF <Future> <Offset>)
Returns the <Offset>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,
return User_Vector_Ref(Arg1, Offset);
}
-Define_Primitive(Prim_Future_Set, 3, "FUTURE-SET!")
/* (FUTURE-SET! <Future> <Offset> <New Value>)
Modifies the <Offset>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,
User_Vector_Set(Arg1, Offset,Arg3);
return Result;
}
-\f
-Define_Primitive(Prim_Future_Size, 1, "FUTURE-SIZE")
+
/* (FUTURE-SIZE <Future>)
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!")
+\f
/* (LOCK-FUTURE! <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
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! <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;
- };
+ }
}
\f
-Define_Primitive(Prim_Future_To_Vector, 1, "FUTURE->VECTOR")
/* (FUTURE->VECTOR <Future>)
Create a COPY of <future> 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);
}
-
+\f
/* 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;
+}
+\f
+#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 */
-\f
-/* Make_Initial_Process continued */
+
+#endif /* USE_STACKLETS */
Free[CONTINUATION_EXPRESSION] = Make_Non_Pointer(TC_FIXNUM, IntEnb);
Free[CONTINUATION_RETURN_CODE] =
*/
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;
+}
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.
(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)
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
*/
#define Switch_by_GC_Type(P) \
- switch(Safe_Type_Code(P))
+ switch(OBJECT_TYPE(P))
#define case_simple_Non_Pointer \
case TC_NULL: \
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.
/* 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 */
GC_Undefined, /* 0x7C */
GC_Undefined, /* 0x7D */
GC_Undefined, /* 0x7E */
- GC_Undefined /* 0x7F */
+ GC_Undefined, /* 0x7F */
+\f
+ 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 */
+\f
+ 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 */
+\f
+ 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
+
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.
*
*/
-
+\f
/*
* The history consists of a "vertebra" which is a doubly linked ring,
* each entry pointing to a "rib". The rib consists of a singly
#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)
+\f
/* 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
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)); \
#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 */
\f
/* History manipulation for the compiled code interface. */
#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()
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.
#include "scheme.h"
#include "primitive.h"
#include "winder.h"
+#include "history.h"
\f
/* (APPLY FN LIST-OF-ARGUMENTS)
Calls the function FN to the arguments specified in the list
/*NOTREACHED*/
}
\f
-/* 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(); */ \
+}
\f
#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); \
Save_Cont(); \
Pushed(); \
}
-#endif
+
+#endif /* USE_STACKLETS */
\f
/* (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*/
}
"NON-REENTRANT-CALL-WITH-CURRENT-CONTINUATION", 0x9)
{
Pointer Control_Point;
+ Primitive_1_Arg();
#ifdef USE_STACKLETS
/* 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
{
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;
/* 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();
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)
*/
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);
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)
{
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)
{
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)
{
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
#include "locks.h"
#include "trap.h"
#include "lookup.h"
+#include "history.h"
+#include "cmpint.h"
#include "zones.h"
\f
/* In order to make the interpreter tail recursive (i.e.
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.
*
/* 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)
#define Push_From(SP) *--(SP)
#define Pop_Into(SP, What) (*(SP)++) = (What)
\f
-/* 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 */
-\f
-/* Rack operations, continued */
-
/* Fetch from register */
#define Fetch_Expression() Expression
/* 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; \
}
\f
#define Pop_Primitive_Frame(NArgs) \
Stack_Pointer = Simulate_Popping(NArgs)
\f
-/* 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); \
- }); \
- } \
-}
-\f
-/* 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(); \
-}
-\f
-/* 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()
-\f
-/* 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(); \
-}
-\f
#define UNWIND_PROTECT(body_statement, cleanup_statement) do \
{ \
jmp_buf UNWIND_PROTECT_new_buf, *UNWIND_PROTECT_old_buf; \
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.
*/
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)
{
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.
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) ?
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
#define TYPE_CODE_LENGTH 8 /* Not CHAR_SIZE!! */
#define MAX_TYPE_CODE 0xFF /* ((1<<TYPE_CODE_LENGTH) - 1) */
-/* The danger bit is being phased out. It is currently used by stacklets
- and the history mechanism. The variable lookup code no longer uses it.
- */
-
-#define DANGER_TYPE 0x80 /* (1<<(TYPE_CODE_LENGTH-1)) */
-#define MAX_SAFE_TYPE 0x7F /* (MAX_TYPE_CODE & ~DANGER_TYPE) */
-#define SAFE_TYPE_MASK MAX_SAFE_TYPE
-#define DANGER_BIT HIGH_BIT
-
-#ifndef b32 /* Safe versions */
+#ifndef b32 /* Portable versions */
#define ADDRESS_LENGTH (POINTER_LENGTH-TYPE_CODE_LENGTH)
#define ADDRESS_MASK ((1<<ADDRESS_LENGTH) - 1)
#define TYPE_CODE_MASK (~ADDRESS_MASK)
-#define HIGH_BIT (1 << (POINTER_LENGTH-1))
/* FIXNUM_LENGTH does NOT include the sign bit! */
#define FIXNUM_LENGTH (ADDRESS_LENGTH-1)
#define FIXNUM_SIGN_BIT (1<<FIXNUM_LENGTH)
#define ADDRESS_LENGTH 24
#define ADDRESS_MASK 0x00FFFFFF
#define TYPE_CODE_MASK 0xFF000000
-#define HIGH_BIT 0x80000000
#define FIXNUM_LENGTH 23
#define FIXNUM_SIGN_BIT 0x00800000
#define SIGN_MASK 0xFF800000
#endif
\f
-#ifndef UNSIGNED_SHIFT /* Safe version */
+#ifndef UNSIGNED_SHIFT /* Portable version */
#define OBJECT_TYPE(P) (((P) >> 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))
#define Make_Object(TC, D) \
((((unsigned) (TC)) << ADDRESS_LENGTH) | (OBJECT_DATUM (D)))
\f
-#ifndef Heap_In_Low_Memory /* Safe version */
+#ifndef Heap_In_Low_Memory /* Portable version */
typedef Pointer *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))
+\f
#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))
} while (0)
#define BOOLEAN_TO_OBJECT(expression) ((expression) ? TRUTH : NIL)
-\f
+
#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))
#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))
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 .
*/
#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 */
Boolean
scheme_string(From, Quoted)
-long From;
-Boolean Quoted;
+ long From;
+ Boolean Quoted;
{
fast long i, Count;
fast char *Chars;
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;
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");
}
main(argc, argv)
-int argc;
-char **argv;
+ int argc;
+ char **argv;
{
Pointer *Next;
long i, total_length;
+
if (argc == 1)
{
if (!Read_Header())
}
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));
+ }
}
}
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.
*
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)
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) ||
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);
}
return Swap_Pointers(Nth_Vector_Loc(Arg1, index), Arg3);
}
\f
-/* 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);
-}
-\f
/* Cells */
/* (MAKE-CELL CONTENTS)
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. */
{
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;
}
default:
fprintf(stderr, "\nImpurify: Bad type code = 0x%02x\n",
- Type_Code(Object));
+ OBJECT_TYPE(Object));
Invalid_Type_Code();
}
\f
block, or something like it. -- JINX
*/
- if (Type_Code(Object) == TC_BIG_FLONUM)
+ if (OBJECT_TYPE(Object) == TC_BIG_FLONUM)
{
Pointer *Start;
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);
}
\f
/* (PRIMITIVE-IMPURIFY OBJECT)
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/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
#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. */
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.
#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
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.
_______________________________________
|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
*/
+#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
\f
/* DELAYED
* The object returned by a DELAY operation. Consists initially of a
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. */
\f
#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; \
#define Internal_Will_Push(N) \
{ \
if ((Stack_Pointer - (N)) < Stack_Guard) \
- { Export_Registers(); \
+ { \
+ Export_Registers(); \
Allocate_New_Stacklet((N)); \
Import_Registers(); \
} \
#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.
#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
#endif
\f
/* 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
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])]))
\f
#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()
* 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); \
}
\f
-/* 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 */
\f
- /* 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); \
+ } \
+\f \
+ 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); \
+ } \
}
\f
-#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 \
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)
Where = Stack_Top; \
}
-#define Get_Current_Stacklet() NIL
+#define Get_Current_Stacklet() NIL
#define Set_Current_Stacklet(Where) {}
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 */
#define Within_Stacklet_Backout()
\f
/* 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,
#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++; \
+ } \
+\f \
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 */
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. */
/* 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;
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
*
#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
;;;; 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))
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
#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
))
\f
;;; [] Returns
COMPILER-CACHE-REFERENCE-APPLY-RESTART ;57
COMPILER-SAFE-REFERENCE-TRAP-RESTART ;58
COMPILER-UNASSIGNED?-TRAP-RESTART ;59
+ COMPILER-CACHE-ASSIGNMENT-RESTART ;5A
))
\f
;;; [] Primitives
(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
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
;;; 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 $"
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. */
#include "primitive.h"
#include "flonum.h"
#include "winder.h"
+#include "history.h"
+#include "cmpint.h"
\f
/* Set_Up_Interrupt is called from the Interrupt
* macro to do all of the setup for calling the user's
void
Stack_Death ()
-{ fprintf(stderr, "\nWill_Push vs. Pushed inconsistency.\n");
+{
+ fprintf(stderr, "\nWill_Push vs. Pushed inconsistency.\n");
Microcode_Termination(TERM_BAD_STACK);
}
\f
* 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);
*/
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);
long error_code;
{
Back_Out_Of_Primitive ();
- longjmp (*Back_To_Eval, error_code);
+ PRIMITIVE_ABORT(error_code);
/*NOTREACHED*/
}
signal_interrupt_from_primitive ()
{
Back_Out_Of_Primitive ();
- longjmp (*Back_To_Eval, PRIM_INTERRUPT);
+ PRIMITIVE_ABORT(PRIM_INTERRUPT);
/*NOTREACHED*/
}
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*/
}
\f
/* 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,
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);
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;
}
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));
*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;
}
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])];
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 */
\f
/* Dynamic Winder support code */
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)
{
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*/
}
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. */
\f
/* 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
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.
/* 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;
- }
+\f
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;
}
}
}
\f
-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",
((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;
+\f
+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);
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);
+ }
}
\f
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;
/* 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;
}
/* 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;
}
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.
/* 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 */
GC_Undefined, /* 0x7C */
GC_Undefined, /* 0x7D */
GC_Undefined, /* 0x7E */
- GC_Undefined /* 0x7F */
+ GC_Undefined, /* 0x7F */
+\f
+ 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 */
+\f
+ 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 */
+\f
+ 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
+
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
#include "locks.h"
#include "trap.h"
#include "lookup.h"
+#include "history.h"
+#include "cmpint.h"
#include "zones.h"
\f
/* In order to make the interpreter tail recursive (i.e.
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
#define TYPE_CODE_LENGTH 8 /* Not CHAR_SIZE!! */
#define MAX_TYPE_CODE 0xFF /* ((1<<TYPE_CODE_LENGTH) - 1) */
-/* The danger bit is being phased out. It is currently used by stacklets
- and the history mechanism. The variable lookup code no longer uses it.
- */
-
-#define DANGER_TYPE 0x80 /* (1<<(TYPE_CODE_LENGTH-1)) */
-#define MAX_SAFE_TYPE 0x7F /* (MAX_TYPE_CODE & ~DANGER_TYPE) */
-#define SAFE_TYPE_MASK MAX_SAFE_TYPE
-#define DANGER_BIT HIGH_BIT
-
-#ifndef b32 /* Safe versions */
+#ifndef b32 /* Portable versions */
#define ADDRESS_LENGTH (POINTER_LENGTH-TYPE_CODE_LENGTH)
#define ADDRESS_MASK ((1<<ADDRESS_LENGTH) - 1)
#define TYPE_CODE_MASK (~ADDRESS_MASK)
-#define HIGH_BIT (1 << (POINTER_LENGTH-1))
/* FIXNUM_LENGTH does NOT include the sign bit! */
#define FIXNUM_LENGTH (ADDRESS_LENGTH-1)
#define FIXNUM_SIGN_BIT (1<<FIXNUM_LENGTH)
#define ADDRESS_LENGTH 24
#define ADDRESS_MASK 0x00FFFFFF
#define TYPE_CODE_MASK 0xFF000000
-#define HIGH_BIT 0x80000000
#define FIXNUM_LENGTH 23
#define FIXNUM_SIGN_BIT 0x00800000
#define SIGN_MASK 0xFF800000
#endif
\f
-#ifndef UNSIGNED_SHIFT /* Safe version */
+#ifndef UNSIGNED_SHIFT /* Portable version */
#define OBJECT_TYPE(P) (((P) >> 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))
#define Make_Object(TC, D) \
((((unsigned) (TC)) << ADDRESS_LENGTH) | (OBJECT_DATUM (D)))
\f
-#ifndef Heap_In_Low_Memory /* Safe version */
+#ifndef Heap_In_Low_Memory /* Portable version */
typedef Pointer *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))
+\f
#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))
} while (0)
#define BOOLEAN_TO_OBJECT(expression) ((expression) ? TRUTH : NIL)
-\f
+
#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))
#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))
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 .
*/
#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 */
Boolean
scheme_string(From, Quoted)
-long From;
-Boolean Quoted;
+ long From;
+ Boolean Quoted;
{
fast long i, Count;
fast char *Chars;
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;
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");
}
main(argc, argv)
-int argc;
-char **argv;
+ int argc;
+ char **argv;
{
Pointer *Next;
long i, total_length;
+
if (argc == 1)
{
if (!Read_Header())
}
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));
+ }
}
}
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
#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. */
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
*
#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
;;;; 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))
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
#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
))
\f
;;; [] Returns
COMPILER-CACHE-REFERENCE-APPLY-RESTART ;57
COMPILER-SAFE-REFERENCE-TRAP-RESTART ;58
COMPILER-UNASSIGNED?-TRAP-RESTART ;59
+ COMPILER-CACHE-ASSIGNMENT-RESTART ;5A
))
\f
;;; [] Primitives
(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
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
;;; 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 $"
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. */
\f
/* 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
projects / mit-scheme.git / commitdiff