- Primitives back out in the interpreter, rather than directly.
- A table with the arity in bytes has been added to usrdef.c
- Primitive objects have two fields: a table index for invocation,
and a virtual number for bookkeeping purposes. The table index is
always valid, even for unimplemented primitives. In this case it
points to a procedure which causes an UNIMPLEMENTE-PRIMITIVE error
when invoked. The back out mechanism takes care
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/bchdmp.c,v 9.37 1987/11/24 07:58:33 jinx Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchdmp.c,v 9.38 1987/12/04 22:13:25 jinx Rel $ */
/* bchgcl, bchmmg, bchpur, and bchdmp can replace gcloop, memmag,
purify, and fasdump, respectively, to provide garbage collection
on an object that is too large).
*/
-Built_In_Primitive(Prim_Prim_Fasdump, 3, "PRIMITIVE-FASDUMP", 0x56)
-Define_Primitive(Prim_Prim_Fasdump, 3, "PRIMITIVE-FASDUMP")
+DEFINE_PRIMITIVE("PRIMITIVE-FASDUMP", Prim_Prim_Fasdump, 3)
{
Boolean success;
long length, hlength, tlength, tsize;
if (table_start >= table_top)
{
fasdump_exit(0);
- Primitive_GC(table_top - saved_free);
+ Primitive_GC(table_start - saved_free);
}
\f
#if (GC_DISK_BUFFER_SIZE <= FASL_HEADER_LENGTH)
if (table_end >= table_top)
{
fasdump_exit(0);
- Primitive_GC(table_top - saved_free);
+ Primitive_GC(table_end - saved_free);
}
tsize = (table_end - table_start);
file is loaded back using BAND_LOAD, PROCEDURE is called with an
argument of NIL.
*/
-Built_In_Primitive(Prim_Band_Dump, 2, "DUMP-BAND", 0xB7)
-Define_Primitive(Prim_Band_Dump, 2, "DUMP-BAND")
+
+DEFINE_PRIMITIVE("DUMP-BAND", Prim_Band_Dump, 2)
{
extern Pointer compiler_utilities;
Pointer Combination, *table_start, *table_end, *saved_free;
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.38 1987/11/17 08:06:33 jinx Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchmmg.c,v 9.39 1987/12/04 22:13:39 jinx Rel $ */
/* Memory management top level. Garbage collection to disk.
the GC daemon if there is one.
*/
-Built_In_Primitive(Prim_Garbage_Collect, 1, "GARBAGE-COLLECT", 0x3A)
-Define_Primitive(Prim_Garbage_Collect, 1, "GARBAGE-COLLECT")
+DEFINE_PRIMITIVE ("GARBAGE-COLLECT", Prim_Garbage_Collect, 1)
{
Pointer GC_Daemon_Proc;
Primitive_1_Arg();
Arg_1_Type(TC_FIXNUM);
if (Free > Heap_Top)
{
- fprintf(stderr,
- "\nGC has been delayed too long; You are truly out of room!\n");
- fprintf(stderr,
- "Free = 0x%x, MemTop = 0x%x, Heap_Top = 0x%x\n",
- Free, MemTop, Heap_Top);
- Microcode_Termination(TERM_NO_SPACE);
+ Microcode_Termination(TERM_GC_OUT_OF_SPACE);
/*NOTREACHED*/
}
GC_Reserve = Get_Integer(Arg1);
Store_Expression(Make_Unsigned_Fixnum(MemTop - Free));
Save_Cont();
Pushed();
- longjmp( *Back_To_Eval, PRIM_POP_RETURN);
+ PRIMITIVE_ABORT(PRIM_POP_RETURN);
/*NOTREACHED*/
}
Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS + 1));
Push(GC_Daemon_Proc);
Push(STACK_FRAME_HEADER);
Pushed();
- longjmp(*Back_To_Eval, PRIM_APPLY);
+ PRIMITIVE_ABORT(PRIM_APPLY);
/* The following comment is by courtesy of LINT, your friendly sponsor. */
/*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/bkpt.h,v 9.23 1987/04/16 02:08:44 jinx Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/bkpt.h,v 9.24 1987/12/04 22:13:56 jinx Rel $
*
* This file contains breakpoint utilities.
* Disabled when not debugging the interpreter.
#if false
/* This code disabled by SAS 6/24/86 */
struct
-{ int nprims;
+{
+ int nprims;
int primtime[1];
} perfinfo_data;
{ int i;
perfinfo_data.nprims = MAX_PRIMITIVE + 1;
for (i = 0; i <= MAX_PRIMITIVE; i++)
+ {
perfinfo_data.primtime[i] = 0;
+ }
}
-#define Metering_Apply_Primitive(Loc, N) \
-{ \
- long Start_Time = Sys_Clock(); \
- \
- Loc = Apply_Primitive(N) \
- perfinfo_data.primtime[N] += Sys_Clock() - Start_Time; \
- Set_Time_Zone(Zone_Working); \
+#define Metering_Apply_Primitive(Loc, prim)
+{
+ long Start_Time;
+
+ Start_Time = Sys_Clock();
+ Loc = Apply_Primitive(prim);
+ perfinfo_data.primtime[PRIMITIVE_NUMBER(prim)] +=
+ (Sys_Clock() - Start_Time);
+ Set_Time_Zone(Zone_Working);
}
#endif
#endif /* ifdef ENABLE_DEBUGGING_TOOLS */
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/boot.c,v 9.42 1987/11/23 05:16:31 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/boot.c,v 9.43 1987/12/04 22:14:06 jinx Rel $
Copyright (c) 1987 Massachusetts Institute of Technology
Enter_Interpreter()
{
jmp_buf Orig_Eval_Point;
- Back_To_Eval = (jmp_buf *) Orig_Eval_Point;
+ Back_To_Eval = ((jmp_buf *) Orig_Eval_Point);
Interpret(Was_Scheme_Dumped);
fprintf(stderr, "\nThe interpreter returned to top level!\n");
}
putchar('\n');
- if ((code < 0) || (code > MAX_ERROR))
+ if ((code < 0) || (code > MAX_TERMINATION))
{
printf("Unknown termination code 0x%x\n", code);
}
value = 0;
break;
- case TERM_NON_EXISTENT_CONTINUATION:
- printf("Return code = 0x%x\n", Fetch_Return());
- goto normal_termination;
-
- case TERM_GC_OUT_OF_SPACE:
- printf("Memory: required = %d; available = %d\n",
- Get_Integer(Fetch_Expression()), Space_Before_GC());
- goto normal_termination;
-
case TERM_NO_ERROR_HANDLER:
/* This does not print a back trace because it was printed before
getting here irrelevant of the state of Trace_On_Error.
value = 1;
break;
+ case TERM_NON_EXISTENT_CONTINUATION:
+ printf("Return code = 0x%lx\n", Fetch_Return());
+ goto normal_termination;
+
+ case TERM_GC_OUT_OF_SPACE:
+ printf("You are out of space at the end of a Garbage Collection!\n");
+ printf("Free = 0x%lx; MemTop = 0x%lx; Heap_Top = 0x%lx\n",
+ Free, MemTop, Heap_Top);
+ printf("Words required = %ld; Words available = %ld\n",
+ (MemTop - Free), GC_Space_Needed);
+ goto normal_termination;
+
default:
normal_termination:
value = 1;
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/const.h,v 9.25 1987/11/17 08:08:36 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/const.h,v 9.26 1987/12/04 22:14:55 jinx Rel $
*
* Named constants used throughout the interpreter
*
#define PRIM_NO_TRAP_EVAL -5
#define PRIM_NO_TRAP_APPLY -6
#define PRIM_POP_RETURN -7
+#define PRIM_TOUCH -8
/* Some numbers of parameters which mean something special */
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/debug.c,v 9.26 1987/11/17 08:08:55 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/debug.c,v 9.27 1987/12/04 22:15:07 jinx Rel $
*
* Utilities to help with debugging
*/
printf("[0x%x]", index);
}
-void Print_Return(String)
-char *String;
-{ printf("%s: ", String);
+void
+Print_Return(String)
+ char *String;
+{
+ printf("%s: ", String);
Print_Return_Name(Fetch_Return());
CRLF();
}
\f
extern Boolean Prt_PName();
-void Print_Expression(Expr, String)
-char *String;
-Pointer Expr;
-{ if (String[0] != 0) printf("%s: ", String);
+void
+Print_Expression(Expr, String)
+ char *String;
+ Pointer Expr;
+{
+ if (String[0] != 0)
+ {
+ printf("%s: ", String);
+ }
Do_Printing(Expr, true);
}
Do_Printing(Expr, Detailed)
-Pointer Expr;
-Boolean Detailed;
-{ long Temp_Address;
+ Pointer Expr;
+ Boolean Detailed;
+{
+ long Temp_Address;
Boolean Return_After_Print;
+
Temp_Address = Get_Integer(Expr);
Return_After_Print = false;
switch(Type_Code(Expr))
printf("\"");
Length = ((long) (Vector_Ref(Expr, STRING_LENGTH)));
Next = (char *) Nth_Vector_Loc(Expr, STRING_CHARS);
- for (i=0; i < Length; i++)
- { This = *Next++;
+ for (i = 0; i < Length; i++)
+ {
+ This = *Next++;
printf((This < ' ') || (This > '|') ? "\\%03o" : "%c",
This);
}
case TC_LIST: List_Print(Expr); return;
case TC_NULL:
- if (Temp_Address==0)
+ if (Temp_Address == 0)
{ printf("()");
return;
}
return;
}
case TC_EXTENDED_LAMBDA:
- if (Detailed) printf("[EXTENDED_LAMBDA (");
- Do_Printing(
- Vector_Ref(
- Vector_Ref(Expr, ELAMBDA_NAMES),
- 1), false);
- if (Detailed) printf(") 0x%x", Temp_Address);
+ if (Detailed)
+ printf("[EXTENDED_LAMBDA (");
+ Do_Printing(Vector_Ref(Vector_Ref(Expr, ELAMBDA_NAMES), 1), false);
+ if (Detailed)
+ printf(") 0x%x", Temp_Address);
return;
+
case TC_EXTENDED_PROCEDURE:
- if (Detailed) printf("[EXTENDED_PROCEDURE (");
+ if (Detailed)
+ printf("[EXTENDED_PROCEDURE (");
Do_Printing(Vector_Ref(Expr, PROCEDURE_LAMBDA_EXPR), false);
- if (Detailed) printf(") 0x%x]", Temp_Address);
+ if (Detailed)
+ printf(") 0x%x]", Temp_Address);
break;
/* Do_Printing continues on the next page */
case TC_PCOMB2: printf("[PCOMB2"); break;
case TC_PCOMB3: printf("[PCOMB3"); break;
case TC_PRIMITIVE:
- printf("[PRIMITIVE "); Prt_PName(Temp_Address);
+ printf("[PRIMITIVE "); Prt_PName(Expr);
printf("]"); return;
case TC_PROCEDURE:
if (Detailed)
case TC_THE_ENVIRONMENT: printf("[THE_ENVIRONMENT"); break;
case TC_TRUE:
if (Temp_Address == 0)
- { printf("#!true");
+ {
+ printf("#T");
return;
}
printf("[TRUE");
}
\f
Boolean
-Prt_PName(Number)
- long Number;
+Prt_PName(primitive)
+ Pointer primitive;
{
extern char *primitive_to_name();
char *name;
- name = primitive_to_name(Number);
+ name = primitive_to_name(primitive);
if (name == ((char *) NULL))
{
- printf("Unknown primitive 0x%08x", Number);
+ printf("Unknown primitive 0x%08x", PRIMITIVE_NUMBER(primitive));
return false;
}
else
}
}
-void Print_Primitive(Number)
- long Number;
+void Print_Primitive(primitive)
+ Pointer primitive;
{
extern long primitive_to_arity();
int NArgs, i;
printf("Primitive: ");
- if (Prt_PName(Number))
- NArgs = primitive_to_arity(Number);
+ if (Prt_PName(primitive))
+ {
+ NArgs = primitive_to_arity(primitive);
+ }
else
+ {
NArgs = 3; /* Unknown primitive */
+ }
printf("\n");
for (i = 0; i < NArgs; i++)
}
\f
Debug_Printer(Expr)
-Pointer Expr;
-{ Print_Expression(Expr, "");
+ Pointer Expr;
+{
+ Print_Expression(Expr, "");
putchar('\n');
}
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/dmpwrld.c,v 9.25 1987/06/18 22:15:11 jinx Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/dmpwrld.c,v 9.26 1987/12/04 22:15:25 jinx Rel $
*
* This file contains a primitive to dump an executable version of Scheme.
* It uses unexec.c from GNU Emacs.
extern Boolean Was_Scheme_Dumped;
extern unix_find_pathname();
-Define_Primitive(Prim_Dump_World, 1, "DUMP-WORLD")
+DEFINE_PRIMITIVE ("DUMP-WORLD", Prim_Dump_World, 1)
{
char *fname, path_buffer[FILE_NAME_LENGTH];
Boolean Saved_Dumped_Value, Saved_Photo_Open;
Arg_1_Type(TC_CHARACTER_STRING);
if (there_are_open_files())
- Primitive_Error(ERR_OUT_OF_FILE_HANDLES);
+ {
+ Primitive_Error(ERR_OUT_OF_FILE_HANDLES);
+ }
fname = Scheme_String_To_C_String(Arg1);
Primitive_Error(ERR_EXTERNAL_RETURN);
}
- 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/errors.h,v 9.26 1987/11/17 08:09:19 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/errors.h,v 9.27 1987/12/04 22:15:36 jinx Exp $
*
* Error and termination code declarations.
*
#define TERM_GC_OUT_OF_SPACE 0x14
#define TERM_NO_SPACE 0x15
#define TERM_SIGNAL 0x16
+#define TERM_TOUCH 0x17
/*
If you add any termination codes here, remember to add them to
storage.c as well.
*/
-#define MAX_TERMINATION 0x16
+#define MAX_TERMINATION 0x17
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/extern.c,v 9.24 1987/11/18 00:09:22 jinx Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/extern.c,v 9.25 1987/12/04 22:15:47 jinx Rel $ */
#include "scheme.h"
#include "primitive.h"
primitives and return addresses.
*/
-/* (MAP-CODE-TO-MACHINE-ADDRESS TYPE-CODE VALUE-CODE)
- For return codes and primitives, this returns the internal
- representation of the return address or primitive address given
- the external representation. Currently in CScheme these two are
- the same. In the 68000 assembly version the internal
- representation is an actual address in memory.
+/* (MAP-CODE-TO-MACHINE-ADDRESS TYPE-CODE VALUE-CODE) For return codes
+ and primitives, this returns the internal representation of the
+ return address or primitive address given the external
+ representation. Currently in CScheme these two are the same for
+ return codes, but for primitives there are two parts to the code.
+ In the 68000 assembly version the internal representation is an
+ actual address in memory.
*/
-Built_In_Primitive(Prim_Map_Code_To_Address, 2,
- "MAP-CODE-TO-MACHINE-ADDRESS", 0x93)
-Define_Primitive(Prim_Map_Code_To_Address, 2,
- "MAP-CODE-TO-MACHINE-ADDRESS")
+
+DEFINE_PRIMITIVE("MAP-CODE-TO-MACHINE-ADDRESS", Prim_Map_Code_To_Address, 2)
{
- long Code, Offset;
+ Pointer result;
+ long tc, number;
Primitive_2_Args();
Arg_1_Type(TC_FIXNUM);
Arg_2_Type(TC_FIXNUM);
- Code = Get_Integer(Arg1);
- Offset = Get_Integer(Arg2);
- switch (Code)
+ tc = Get_Integer(Arg1);
+ number = Get_Integer(Arg2);
+ switch (tc)
{
case TC_RETURN_CODE:
- if (Offset > MAX_RETURN_CODE)
+ if (number > MAX_RETURN_CODE)
{
Primitive_Error(ERR_ARG_2_BAD_RANGE);
}
+ result = (Make_Non_Pointer(tc, number));
break;
case TC_PRIMITIVE:
- if (Offset >= NUMBER_OF_PRIMITIVES())
+ if (number >= NUMBER_OF_PRIMITIVES())
{
Primitive_Error(ERR_ARG_2_BAD_RANGE);
}
+ if (number > MAX_PRIMITIVE)
+ {
+ result = MAKE_PRIMITIVE_OBJECT(number, (MAX_PRIMITIVE + 1));
+ }
+ else
+ {
+ result = MAKE_PRIMITIVE_OBJECT(0, number);
+ }
break;
default: Primitive_Error(ERR_ARG_1_BAD_RANGE);
}
- return (Make_Non_Pointer(Code, Offset));
+ PRIMITIVE_RETURN(result);
}
\f
/* (MAP-MACHINE-ADDRESS-TO-CODE TYPE-CODE ADDRESS)
primitive) it finds the number for the external representation
for the internal address.
*/
-Built_In_Primitive(Prim_Map_Address_To_Code, 2,
- "MAP-MACHINE-ADDRESS-TO-CODE", 0x90)
-Define_Primitive(Prim_Map_Address_To_Code, 2,
- "MAP-MACHINE-ADDRESS-TO-CODE")
+
+DEFINE_PRIMITIVE("MAP-MACHINE-ADDRESS-TO-CODE", Prim_Map_Address_To_Code, 2)
{
- long Code, Offset;
+ long tc, number;
Primitive_2_Args();
Arg_1_Type(TC_FIXNUM);
- Code = Get_Integer(Arg1);
- Arg_2_Type(Code);
- Offset = Get_Integer(Arg2);
- switch (Code)
+ tc = Get_Integer(Arg1);
+ Arg_2_Type(tc);
+ switch (tc)
{ case TC_RETURN_CODE:
- if (Offset > MAX_RETURN_CODE)
+ number = Get_Integer(Arg2);
+ if (number > MAX_RETURN_CODE)
{
Primitive_Error(ERR_ARG_2_BAD_RANGE);
}
break;
case TC_PRIMITIVE:
- if (Offset > NUMBER_OF_PRIMITIVES())
- {
- Primitive_Error(ERR_ARG_2_BAD_RANGE);
- }
+ number = PRIMITIVE_NUMBER(Arg2);
break;
default:
Primitive_Error(ERR_ARG_1_BAD_RANGE);
}
- return (MAKE_UNSIGNED_FIXNUM(Offset));
+ PRIMITIVE_RETURN(MAKE_UNSIGNED_FIXNUM(number));
}
\f
-/* (PRIMITIVE-PROCEDURE-ARITY INTERNAL-PRIMITIVE)
+/* (PRIMITIVE-PROCEDURE-ARITY PRIMITIVE)
Given the internal representation of a primitive (in CScheme the
internal and external representations are the same), return the
number of arguments it requires.
*/
-Built_In_Primitive(Prim_Map_Prim_Address_To_Arity, 1,
- "PRIMITIVE-PROCEDURE-ARITY", 0x96)
-Define_Primitive(Prim_Map_Prim_Address_To_Arity, 1,
- "PRIMITIVE-PROCEDURE-ARITY")
+
+DEFINE_PRIMITIVE("PRIMITIVE-PROCEDURE-ARITY", Prim_Map_Prim_Address_To_Arity, 1)
{
extern long primitive_to_arity();
- long Prim_Num, answer;
+ long answer;
Primitive_1_Arg();
Arg_1_Type(TC_PRIMITIVE);
- Prim_Num = Get_Integer(Arg1);
- if (Prim_Num >= NUMBER_OF_PRIMITIVES())
+ if (PRIMITIVE_NUMBER(Arg1) >= NUMBER_OF_PRIMITIVES())
{
Primitive_Error(ERR_ARG_1_BAD_RANGE);
}
- answer = primitive_to_arity(Prim_Num);
- return (MAKE_SIGNED_FIXNUM(answer));
+ answer = primitive_to_arity(Arg1);
+ PRIMITIVE_RETURN(MAKE_SIGNED_FIXNUM(answer));
}
\f
/* (GET-PRIMITIVE-COUNTS)
defined.
*/
-Built_In_Primitive(Prim_Get_Primitive_Counts, 0, "GET-PRIMITIVE-COUNTS", 0x101)
-Define_Primitive(Prim_Get_Primitive_Counts, 0, "GET-PRIMITIVE-COUNTS")
+DEFINE_PRIMITIVE("GET-PRIMITIVE-COUNTS", Prim_Get_Primitive_Counts, 0)
{
Primitive_0_Args();
primitive procedure. It causes an error if the number is out of range.
*/
-Built_In_Primitive(Prim_Get_Primitive_Name, 1, "GET-PRIMITIVE-NAME", 0x102)
-Define_Primitive(Prim_Get_Primitive_Name, 1, "GET-PRIMITIVE-NAME")
+DEFINE_PRIMITIVE("GET-PRIMITIVE-NAME", Prim_Get_Primitive_Name, 1)
{
extern Pointer primitive_name();
long Number, TC;
Primitive_1_Arg();
- TC = Type_Code(Arg1);
+ TC = OBJECT_TYPE(Arg1);
if ((TC != TC_FIXNUM) && (TC != TC_PRIMITIVE))
{
Primitive_Error(ERR_ARG_1_WRONG_TYPE);
}
- Range_Check(Number, Arg1, 0, (NUMBER_OF_PRIMITIVES() - 1),
- ERR_ARG_1_BAD_RANGE);
+ Number = PRIMITIVE_NUMBER(Arg1);
+ if ((Number < 0) || (Number >= NUMBER_OF_PRIMITIVES()))
+ {
+ Primitive_Error(ERR_ARG_1_BAD_RANGE);
+ }
PRIMITIVE_RETURN(primitive_name(Number));
}
\f
whether the corresponding primitive is implemented or not.
*/
-Built_In_Primitive(Prim_Get_Primitive_Address, 2, "GET-PRIMITIVE-ADDRESS", 0x103)
-Define_Primitive(Prim_Get_Primitive_Address, 2, "GET-PRIMITIVE-ADDRESS")
+DEFINE_PRIMITIVE("GET-PRIMITIVE-ADDRESS", Prim_Get_Primitive_Address, 2)
{
extern Pointer find_primitive();
Boolean intern_p, allow_p;
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/fasdump.c,v 9.31 1987/11/17 08:09:49 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasdump.c,v 9.32 1987/12/04 22:16:00 jinx Rel $
This file contains code for fasdump and dump-band.
*/
The code for dumping pure is severely broken and conditionalized out.
*/
-Built_In_Primitive(Prim_Prim_Fasdump, 3, "PRIMITIVE-FASDUMP", 0x56)
-Define_Primitive(Prim_Prim_Fasdump, 3, "PRIMITIVE-FASDUMP")
+
+DEFINE_PRIMITIVE("PRIMITIVE-FASDUMP", Prim_Prim_Fasdump, 3)
{
Pointer Object, File_Name, Flag, *New_Object;
Pointer *table_start, *table_end;
table_start = initialize_primitive_table(Free, table_end);
if (table_start >= table_end)
{
- Primitive_GC(table_end - table_start);
+ Primitive_GC(table_start - Free);
}
Fasdump_Free_Calc(NewFree, NewMemTop, Orig_New_Free);
file is loaded back using BAND_LOAD, PROCEDURE is called with an
argument of NIL.
*/
-Built_In_Primitive(Prim_Band_Dump, 2, "DUMP-BAND", 0xB7)
-Define_Primitive(Prim_Band_Dump, 2, "DUMP-BAND")
+
+DEFINE_PRIMITIVE("DUMP-BAND", Prim_Band_Dump, 2)
{
extern Pointer compiler_utilities;
Pointer Combination, *table_start, *table_end, *saved_free;
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/fasload.c,v 9.31 1987/11/17 08:10:13 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasload.c,v 9.32 1987/12/04 22:16:13 jinx Rel $
The "fast loader" which reads in and relocates binary files and then
interns symbols. It is called with one argument: the (character
break;
case TC_PRIMITIVE:
- *Next_Pointer++ = load_renumber_table[Get_Integer(Temp)];
+ *Next_Pointer++ = load_renumber_table[PRIMITIVE_NUMBER(Temp)];
break;
case TC_PCOMB0:
*Next_Pointer++ =
Make_Non_Pointer(TC_PCOMB0,
- load_renumber_table[Get_Integer(Temp)]);
+ load_renumber_table[PRIMITIVE_NUMBER(Temp)]);
break;
case TC_MANIFEST_NM_VECTOR:
will be a piece of SCode which is then evaluated to perform
definitions in some environment.
*/
-Built_In_Primitive(Prim_Binary_Fasload, 1, "BINARY-FASLOAD", 0x57)
-Define_Primitive(Prim_Binary_Fasload, 1, "BINARY-FASLOAD")
+
+DEFINE_PRIMITIVE("BINARY-FASLOAD", Prim_Binary_Fasload, 1)
{
long result;
Primitive_1_Arg();
Returns the filename (as a Scheme string) from which the runtime system
was band loaded (load-band'ed ?), or NIL if the system was fasl'ed.
*/
-Built_In_Primitive(Prim_reload_band_name, 0, "RELOAD-BAND-NAME", 0x1A3)
-Define_Primitive(Prim_reload_band_name, 0, "RELOAD-BAND-NAME")
+
+DEFINE_PRIMITIVE("RELOAD-BAND-NAME", Prim_reload_band_name, 0)
{
Primitive_0_Args();
if (reload_band_name == NULL)
{
- return NIL;
+ PRIMITIVE_RETURN(NIL);
}
- return (C_String_To_Scheme_String(reload_band_name));
+ PRIMITIVE_RETURN(C_String_To_Scheme_String(reload_band_name));
}
/* Utility for load band below. */
which is typically a file created by DUMP-BAND. The file can,
however, be any file which can be loaded with BINARY-FASLOAD.
*/
-Built_In_Primitive(Prim_Band_Load, 1, "LOAD-BAND", 0xB9)
-Define_Primitive(Prim_Band_Load, 1, "LOAD-BAND")
+
+DEFINE_PRIMITIVE("LOAD-BAND", Prim_Band_Load, 1)
{
extern char *malloc();
extern strcpy(), free();
Finish_String_Inversion()
{
-
if (Byte_Invert_Fasl_Files)
{
while (String_Chain != NIL)
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/findprim.c,v 9.31 1987/12/03 19:30:52 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/findprim.c,v 9.32 1987/12/04 22:13:04 jinx Exp $
*
* Preprocessor to find and declare defined primitives.
*
static char Inexistent_Error_String[] =
"Primitive_Error(ERR_UNIMPLEMENTED_PRIMITIVE)";
-
+\f
static int C_Size = 0;
static int A_Size = 0;
static int S_Size = 0;
static int F_Size = 0;
+
+void
+update_from_entry(primitive_descriptor)
+ descriptor *primitive_descriptor;
+{
+ int temp;
+ temp = strlen(primitive_descriptor->C_Name);
+ if (temp > C_Size)
+ {
+ C_Size = temp;
+ }
+ temp = strlen(primitive_descriptor->Arity);
+ if (temp > A_Size)
+ {
+ A_Size = temp;
+ }
+ temp = strlen(primitive_descriptor->Scheme_Name);
+ if (temp > S_Size)
+ {
+ S_Size = temp;
+ }
+ temp = strlen(primitive_descriptor->File_Name);
+ if (temp > F_Size)
+ {
+ F_Size = temp;
+ }
+ return;
+}
\f
pseudo_void
create_normal_entry()
(token_processors [1]) = NULL;
The_Kind = &External_Kind[0];
The_Variable = &External_Variable[0];
+ update_from_entry(&Inexistent_Entry);
return;
}
(token_processors [2]) = NULL;
The_Kind = &Default_Kind[0];
The_Variable = &Default_Variable[0];
- return;
-}
-
-void
-initialize_from_entry(primitive_descriptor)
- descriptor *primitive_descriptor;
-{
- C_Size = strlen(primitive_descriptor->C_Name);
- A_Size = strlen(primitive_descriptor->Arity);
- S_Size = strlen(primitive_descriptor->Scheme_Name);
- F_Size = strlen(primitive_descriptor->File_Name);
+ update_from_entry(&Inexistent_Entry);
return;
}
\f
{
Result_Buffer[index] = &Inexistent_Entry;
}
- initialize_from_entry(&Inexistent_Entry);
+ update_from_entry(&Inexistent_Entry);
return;
}
\f
initialize_index_size()
{
if (Built_in_p)
+ {
max = Built_in_table_size;
+ }
else
+ {
max = buffer_index;
+ }
find_index_size(max, max_index_size);
max -= 1;
return;
register int how_many;
{
for(; --how_many >= 0;)
+ {
putc(' ', output);
+ }
return;
}
(primitive_descriptor->Scheme_Name));
print_spaces(S_Size-(strlen(primitive_descriptor->Scheme_Name)));
fprintf(output, " %s ", The_Kind);
- find_index_size(index, index_size);
- print_spaces(max_index_size - index_size);
- fprintf(output, "0x%x in %s %c/", index, (primitive_descriptor->File_Name), '*');
+ if (index >= 0)
+ {
+ find_index_size(index, index_size);
+ print_spaces(max_index_size - index_size);
+ fprintf(output, "0x%x", index);
+ }
+ else
+ {
+ print_spaces(max_index_size - 1);
+ fprintf(output, "???");
+ }
+ fprintf(output, " in %s %c/", (primitive_descriptor->File_Name), '*');
return;
}
fprintf(output, " Primitive_%s_Args();\n", (primitive_descriptor->Arity));
fprintf(output, "\n");
fprintf(output, " %s;\n", error_string);
+ fprintf(output, " /%cNOTREACHED%c/\n", '*', '*');
fprintf(output, "}\n");
return;
}
fprintf(output, "Pointer (*(%s_Procedure_Table[]))() = {\n", The_Kind);
- for (count = 0; count < last; count++)
+ for (count = 0; count <= last; count++)
{
print_entry(count, Result_Buffer[count]);
fprintf(output, ",\n");
}
- print_entry(last, Result_Buffer[last]);
+ print_entry(-1, &Inexistent_Entry);
fprintf(output, "\n};\n\f\n");
+ /* Print the names table. */
+
+ fprintf(output, "char *%s_Name_Table[] = {\n", The_Kind);
+
+ for (count = 0; count < last; count++)
+ {
+ fprintf(output, " \"%s\",\n", ((Result_Buffer[count])->Scheme_Name));
+ }
+ fprintf(output, " \"%s\"\n", ((Result_Buffer[last])->Scheme_Name));
+ fprintf(output, "};\n\f\n");
+\f
/* Print the arity table. */
fprintf(output, "int %s_Arity_Table[] = {\n", The_Kind);
fprintf(output, " %s\n", ((Result_Buffer[last])->Arity));
fprintf(output, "};\n\f\n");
- /* Print the names table. */
+ /* Print the counts table. */
- fprintf(output, "char *%s_Name_Table[] = {\n", The_Kind);
+ fprintf(output, "int %s_Count_Table[] = {\n", The_Kind);
for (count = 0; count < last; count++)
{
- fprintf(output, " \"%s\",\n", ((Result_Buffer[count])->Scheme_Name));
+ fprintf(output,
+ " (%s * sizeof(Pointer)),\n",
+ ((Result_Buffer[count])->Arity));
}
- fprintf(output, " \"%s\"\n", ((Result_Buffer[last])->Scheme_Name));
+ fprintf(output,
+ " (%s * sizeof(Pointer))\n",
+ ((Result_Buffer[last])->Arity));
fprintf(output, "};\n\n");
return;
fprintf(output, "#include \"usrdef.h\"\n\n");
- fprintf(output, "long %s = %d;\n\n", The_Variable, max);
+ fprintf(output,
+ "long %s = %d; /%c = 0x%x %c/\n\n",
+ The_Variable, max, '*', max, '*');
+
if (Built_in_p)
+ {
fprintf(output,
"/%c The number of implemented primitives is %d. %c/\n\n",
'*', buffer_index, '*');
+ }
if (max < 0)
{
if (check)
+ {
fprintf(stderr, "No primitives found!\n");
+ }
/* C does not understand the empty array, thus it must be faked. */
/* Dummy entry */
Result_Buffer[0] = &Dummy_Entry;
- initialize_from_entry(&Dummy_Entry);
+ update_from_entry(&Dummy_Entry);
print_procedure(&Dummy_Entry, &Dummy_Error_String[0]);
-
+ fprintf(output, "\n");
}
\f
else
fprintf(output, " %s(),\n", &(Data_Buffer[count].C_Name)[0]);
}
- if (Built_in_p)
- {
- fprintf(output, " %s();\n\n", &(Inexistent_Entry.C_Name)[0]);
- print_procedure(&Inexistent_Entry, &Inexistent_Error_String[0]);
- }
- else
- {
- fprintf(output, " %s();\n", &(Data_Buffer[end].C_Name)[0]);
- }
+ fprintf(output, " %s();\n\n", &(Data_Buffer[end].C_Name)[0]);
}
+ print_procedure(&Inexistent_Entry, &Inexistent_Error_String[0]);
fprintf(output, "\f\n");
print_primitives((max < 0) ? 0 : max);
return;
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/futures.h,v 9.22 1987/07/07 19:59:21 cph Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/futures.h,v 9.23 1987/12/04 22:16:33 jinx Rel $
*
* This file contains macros useful for dealing with futures
*/
(Vector_Ref((P), FUTURE_IS_DETERMINED) != TRUTH))
#ifdef COMPILE_FUTURES
+
/* Touch_In_Primitive is used by primitives which are not
- * strict in an argument but which touch it none the less.
+ * strict in an argument but which touch it none the less.
*/
-#define Touch_In_Primitive(P, To_Where) \
-{ Pointer Value = (P); \
- while (Type_Code(Value) == TC_FUTURE) \
- { if (Future_Has_Value(Value)) \
- { if (Future_Is_Keep_Slot(Value)) Log_Touch_Of_Future(Value);\
- Value = Future_Value(Value); \
- } \
- else \
- { Back_Out_Of_Primitive(); \
- Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+2)); \
- Save_Cont(); \
- Push(Value); \
- Push(Get_Fixed_Obj_Slot(System_Scheduler)); \
- Push(STACK_FRAME_HEADER+1); \
- Pushed(); \
- longjmp(*Back_To_Eval, PRIM_APPLY); \
- } \
- } \
- To_Where = Value; \
+#define Touch_In_Primitive(P, To_Where) \
+{ \
+ Pointer Value; \
+ \
+ Value = (P); \
+ while (OBJECT_TYPE(Value) == TC_FUTURE) \
+ { \
+ if (Future_Has_Value(Value)) \
+ { \
+ if (Future_Is_Keep_Slot(Value)) \
+ { \
+ Log_Touch_Of_Future(Value); \
+ } \
+ Value = Future_Value(Value); \
+ } \
+ else \
+ { \
+ Val = Value; \
+ PRIMITIVE_ABORT(PRIM_TOUCH); \
+ } \
+ } \
+ To_Where = Value; \
+}
+
+#define TOUCH_SETUP(object) \
+{ \
+ Save_Cont(); \
+ Will_Push(STACK_ENV_EXTRA_SLOTS + 2); \
+ Push(object); \
+ Push(Get_Fixed_Obj_Slot(System_Scheduler)); \
+ Push(STACK_FRAME_HEADER + 1); \
+ Pushed(); \
}
\f
/* NOTES ON FUTURES, derived from the rest of the interpreter code */
ASSUMPTION: The SYMBOL slot of a VARIABLE does NOT contain a future, nor
do the cached lexical address slots.
- ASSUMPTION: Compiled code calls to the interpreter require the results
- be touched before returning to the compiled code. This may be very wrong.
-
ASSUMPTION: History objects are never created using futures.
ASSUMPTION: State points, which are created only by the interpreter,
*/
/* KNOWN PROBLEMS:
- (1) Garbage collector should be modified to splice out futures.
+ (1) Garbage collector should be modified to splice out futures. DONE.
(2) Purify should be looked at and we should decide what to do about
purifying an object with a reference to a future (it should probably
of touched futures about which the scheme portion of the system has
not yet been informed
*/
-#define Log_Touch_Of_Future(F) \
+#define Log_Touch_Of_Future(F) \
if (Logging_On()) \
-{ Pointer TFV = Touched_Futures_Vector(); \
- long Count = Get_Integer(User_Vector_Ref(TFV, 0))+1; \
- User_Vector_Ref(TFV, 0) = FIXNUM_0 + Count; \
+{ \
+ Pointer TFV; \
+ long Count; \
+ \
+ TFV = Touched_Futures_Vector(); \
+ Count = Get_Integer(User_Vector_Ref(TFV, 0)) + 1; \
+ User_Vector_Ref(TFV, 0) = MAKE_UNSIGNED_FIXNUM(Count); \
if (Count < Vector_Length(TFV)) \
- User_Vector_Ref(TFV, Count) = Make_New_Pointer(TC_VECTOR, F); \
+ { \
+ User_Vector_Ref(TFV, Count) = Make_New_Pointer(TC_VECTOR, F); \
+ } \
}
/* Call_Future_Logging calls a user defined scheme routine if the vector
of touched futures has a nonzero length.
*/
#define Must_Report_References() \
-( Logging_On() && \
+( (Logging_On()) && \
(Get_Integer(User_Vector_Ref(Touched_Futures_Vector(), 0)) > 0))
#define Call_Future_Logging() \
{ \
- Will_Push(STACK_ENV_EXTRA_SLOTS+2); \
+ Will_Push(STACK_ENV_EXTRA_SLOTS + 2); \
Push(Touched_Futures_Vector()); \
Push(Get_Fixed_Obj_Slot(Future_Logger)); \
- Push(STACK_FRAME_HEADER+1); \
+ Push(STACK_FRAME_HEADER + 1); \
Pushed(); \
Touched_Futures_Vector() = NIL; \
goto Apply_Non_Trapping; \
#endif /* FUTURE_LOGGING */
#define FUTURE_VARIABLE_SPLICE(P, Offset, Value) \
-while (Type_Code(Value) == TC_FUTURE && Future_Spliceable(Value)) \
-{ Value = Future_Value(Value); \
- Vector_Set(P, Offset, Value); \
+{ \
+ while ((OBJECT_TYPE(Value) == TC_FUTURE) && Future_Spliceable(Value)) \
+ { \
+ Value = Future_Value(Value); \
+ Vector_Set(P, Offset, Value); \
+ } \
}
\f
#else /* not COMPILE_FUTURES */
#define Touch_In_Primitive(P, To_Where) To_Where = (P)
+#define TOUCH_SETUP(object) Microcode_Termination(TERM_TOUCH)
#define Log_Touch_Of_Future(F) { }
#define Call_Future_Logging()
#define Must_Report_References() (false)
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.24 1987/11/17 08:11:37 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/gc.h,v 9.25 1987/12/04 22:16:46 jinx Rel $
*
* Garbage collection related macros of sufficient utility to be
* included in all compilations.
#define GC_ENABLED_P() (INTERRUPT_ENABLED_P(INT_GC))
-#define GC_Check(Amount) (((Amount + Free) >= MemTop) && \
- (GC_ENABLED_P()))
+#define GC_Check(Amount) \
+(((Amount + Free) >= MemTop) && (GC_ENABLED_P()))
-#define Space_Before_GC() ((GC_ENABLED_P()) ? \
- (MemTop - Free) : \
- (Heap_Top - Free))
+#define Space_Before_GC() \
+((GC_ENABLED_P()) ? \
+ ((Free <= MemTop) ? (MemTop - Free) : 0) : \
+ (Heap_Top - Free))
#define Request_GC(Amount) \
{ \
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/intercom.c,v 9.23 1987/07/07 21:02:14 cph Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/intercom.c,v 9.24 1987/12/04 22:16:56 jinx Rel $
*
* Single-processor simulation of locking, propagating, and
* communicating stuff.
processors have begun execution of WORK (or TEST returns false).
*/
\f
-Define_Primitive(Prim_Send_Global_Interrupt, 3, "GLOBAL-INTERRUPT")
+DEFINE_PRIMITIVE("GLOBAL-INTERRUPT", Prim_Send_Global_Interrupt, 3)
{
long Saved_Zone, Which_Level;
Push(STACK_FRAME_HEADER);
Pushed();
Restore_Time_Zone();
- longjmp(*Back_To_Eval, PRIM_APPLY);
+ PRIMITIVE_ABORT(PRIM_APPLY);
/*NOTREACHED*/
}
return Do_It;
}
\f
-Define_Primitive(Prim_Put_Work, 1, "PUT-WORK")
+DEFINE_PRIMITIVE("PUT-WORK", Prim_Put_Work, 1)
{
Pointer The_Queue, Queue_Tail, New_Entry;
Primitive_1_Arg();
*Free++ = NIL;
}
else
+ {
Primitive_GC_If_Needed(2);
+ }
Queue_Tail = Vector_Ref(The_Queue, CONS_CDR);
New_Entry = Make_Pointer(TC_WEAK_CONS, Free);
*Free++ = Arg1;
*Free++ = NIL;
Vector_Set(The_Queue, CONS_CDR, New_Entry);
if (Queue_Tail == NIL)
+ {
Vector_Set(The_Queue, CONS_CAR, New_Entry);
- else Vector_Set(Queue_Tail, CONS_CDR, New_Entry);
- return TRUTH;
+ }
+ else
+ {
+ Vector_Set(Queue_Tail, CONS_CDR, New_Entry);
+ }
+ PRIMITIVE_RETURN(TRUTH);
}
-
-Define_Primitive(Prim_Put_Work_In_Front, 1, "PUT-WORK-IN-FRONT")
-{ Pointer The_Queue, Queue_Head, New_Entry;
+\f
+DEFINE_PRIMITIVE("PUT-WORK-IN-FRONT", Prim_Put_Work_In_Front, 1)
+{
+ Pointer The_Queue, Queue_Head, New_Entry;
Primitive_1_Arg();
The_Queue = Get_Fixed_Obj_Slot(The_Work_Queue);
- if (The_Queue==NIL)
+ if (The_Queue == NIL)
{ Primitive_GC_If_Needed(4);
The_Queue = Make_Pointer(TC_LIST, Free);
Set_Fixed_Obj_Slot(The_Work_Queue, The_Queue);
*Free++ = NIL;
*Free++ = NIL;
}
- else Primitive_GC_If_Needed(2);
+ else
+ {
+ Primitive_GC_If_Needed(2);
+ }
Queue_Head = Vector_Ref(The_Queue, CONS_CDR);
New_Entry = Make_Pointer(TC_WEAK_CONS, Free);
*Free++ = Arg1;
*Free++ = Queue_Head;
Vector_Set(The_Queue, CONS_CAR, New_Entry);
- if (Queue_Head==NIL) Vector_Set(The_Queue, CONS_CDR, New_Entry);
+ if (Queue_Head == NIL)
+ {
+ Vector_Set(The_Queue, CONS_CDR, New_Entry);
+ }
+ PRIMITIVE_RETURN(TRUTH);
}
-
-Define_Primitive(Prim_Drain_Queue, 0, "DRAIN-WORK-QUEUE!")
+\f
+DEFINE_PRIMITIVE("DRAIN-WORK-QUEUE!", Prim_Drain_Queue, 0)
{
Pointer The_Queue;
Primitive_0_Args();
The_Queue = Get_Fixed_Obj_Slot(The_Work_Queue);
Set_Fixed_Obj_Slot(The_Work_Queue, NIL);
- return ((The_Queue != NIL) ?
- Vector_Ref(The_Queue, CONS_CAR) :
- NIL);
+ PRIMITIVE_RETURN((The_Queue != NIL) ?
+ Vector_Ref(The_Queue, CONS_CAR) :
+ NIL);
}
-Define_Primitive(Prim_Peek_Queue, 0, "PEEK-AT-WORK-QUEUE")
-{ Pointer The_Queue, This_Cons, Last_Cons;
+DEFINE_PRIMITIVE("PEEK-AT-WORK-QUEUE", Prim_Peek_Queue, 0)
+{
+ Pointer The_Queue, This_Cons, Last_Cons;
Primitive_0_Args();
The_Queue = Get_Fixed_Obj_Slot(The_Work_Queue);
Last_Cons = NIL;
for (The_Queue = Vector_Ref(The_Queue, CONS_CAR);
The_Queue != NIL;
- The_Queue = Vector_Ref(The_Queue, CONS_CDR)) {
+ The_Queue = Vector_Ref(The_Queue, CONS_CDR))
+ {
Primitive_GC_If_Needed(2);
This_Cons = Make_Pointer(TC_LIST, Free);
*Free++ = Vector_Ref(The_Queue, CONS_CAR);
*Free++ = Last_Cons;
- Last_Cons = This_Cons; }
+ Last_Cons = This_Cons;
+ }
+
+ PRIMITIVE_RETURN(This_Cons);
+}
+\f
+DEFINE_PRIMITIVE("GET-WORK", Prim_Get_Work, 1)
+{
+ Pointer Get_Work();
+ Primitive_1_Arg();
- return This_Cons;
+ PRIMITIVE_RETURN(Get_Work(Arg1));
+}
+
+Pointer Get_Work(Arg1)
+ Pointer Arg1;
+{
+ Pointer The_Queue, Queue_Head, Result, The_Prim;
+
+ /* This gets this primitive's code which is in the expression register. */
+ The_Prim = Fetch_Expression();
+ The_Queue = Get_Fixed_Obj_Slot(The_Work_Queue);
+ if (The_Queue != NIL)
+ {
+ Queue_Head = Vector_Ref(The_Queue, CONS_CAR);
+ }
+ if ((The_Queue == NIL) || (Queue_Head == NIL))
+ if (Arg1 == NIL)
+ {
+ printf("\nNo work available, but some has been requested!\n");
+ Microcode_Termination(TERM_EXIT);
+ }
+ else
+ {
+ Pop_Primitive_Frame(1);
+ Will_Push(2 * (STACK_ENV_EXTRA_SLOTS + 1) + 1 + CONTINUATION_SIZE);
+ Push(NIL); /* Upon return, no hope if there is no work */
+ Push(The_Prim);
+ Push(STACK_FRAME_HEADER+1);
+ Store_Expression(NIL);
+ Store_Return(RC_INTERNAL_APPLY);
+ Save_Cont();
+ Push(Arg1);
+ Push(STACK_FRAME_HEADER);
+ Pushed();
+ PRIMITIVE_ABORT(PRIM_APPLY);
+ }
+ Result = Vector_Ref(Queue_Head, CONS_CAR);
+ Queue_Head = Vector_Ref(Queue_Head, CONS_CDR);
+ Vector_Set(The_Queue, CONS_CAR, Queue_Head);
+ if (Queue_Head == NIL)
+ {
+ Vector_Set(The_Queue, CONS_CDR, NIL);
+ }
+ return (Result);
}
\f
-Define_Primitive(Prim_Await_Sync, 1, "AWAIT-SYNCHRONY")
+DEFINE_PRIMITIVE("AWAIT-SYNCHRONY", Prim_Await_Sync, 1)
{
Primitive_1_Arg();
Arg_1_Type(TC_LIST);
if (Type_Code(Vector_Ref(Arg1, CONS_CDR)) != TC_FIXNUM)
+ {
Primitive_Error(ERR_ARG_1_BAD_RANGE);
- return TRUTH;
+ }
+ PRIMITIVE_RETURN(TRUTH);
}
-Define_Primitive(Prim_N_Interps, 0, "N-INTERPRETERS")
+DEFINE_PRIMITIVE("N-INTERPRETERS", Prim_N_Interps, 0)
{
Primitive_0_Args();
- return Make_Unsigned_Fixnum(1);
+ PRIMITIVE_RETURN(MAKE_UNSIGNED_FIXNUM(1));
}
-Define_Primitive(Prim_My_Proc, 0, "MY-PROCESSOR-NUMBER")
+DEFINE_PRIMITIVE("MY-PROCESSOR-NUMBER", Prim_My_Proc, 0)
{
Primitive_0_Args();
- return Make_Unsigned_Fixnum(0);
+ PRIMITIVE_RETURN(MAKE_UNSIGNED_FIXNUM(0));
}
-Define_Primitive(Prim_My_Interp_Number, 0, "MY-INTERPRETER-NUMBER")
+DEFINE_PRIMITIVE("MY-INTERPRETER-NUMBER", Prim_My_Interp_Number, 0)
{
Primitive_0_Args();
- return Make_Unsigned_Fixnum(0);
+ PRIMITIVE_RETURN(MAKE_UNSIGNED_FIXNUM(0));
}
-Define_Primitive(Prim_Zero_Zones, 0, "ZERO-ZONES")
+DEFINE_PRIMITIVE("ZERO-ZONES", Prim_Zero_Zones, 0)
{
long i;
Primitive_0_Args();
#ifdef METERING
for (i=0; i < Max_Meters; i++)
- Time_Meters[i]=0;
+ {
+ Time_Meters[i] = 0;
+ }
Old_Time=Sys_Clock();
#endif
- return TRUTH;
+ PRIMITIVE_RETURN(TRUTH);
}
\f
/* These are really used by GC on a true parallel machine */
-Define_Primitive(Prim_GC_Needed, 0, "GC-NEEDED?")
+DEFINE_PRIMITIVE("GC-NEEDED?", Prim_GC_Needed, 0)
{
Primitive_0_Args();
- if ((Free+GC_Space_Needed) >= MemTop) return TRUTH;
- else return NIL;
+ if ((Free + GC_Space_Needed) >= MemTop)
+ {
+ PRIMITIVE_RETURN(TRUTH);
+ }
+ else
+ {
+ PRIMITIVE_RETURN(NIL);
+ }
}
-Define_Primitive(Prim_Slave_Before, 0, "SLAVE-GC-BEFORE-SYNC")
+DEFINE_PRIMITIVE("SLAVE-GC-BEFORE-SYNC", Prim_Slave_Before, 0)
{
Primitive_0_Args();
- return TRUTH;
+ PRIMITIVE_RETURN(TRUTH);
}
-Define_Primitive(Prim_Slave_After, 0, "SLAVE-GC-AFTER-SYNC")
+DEFINE_PRIMITIVE("SLAVE-GC-AFTER-SYNC", Prim_Slave_After, 0)
{
Primitive_0_Args();
- return TRUTH;
+ PRIMITIVE_RETURN(TRUTH);
}
-Define_Primitive(Prim_Master_Before, 0, "MASTER-GC-BEFORE-SYNC")
+DEFINE_PRIMITIVE("MASTER-GC-BEFORE-SYNC", Prim_Master_Before, 0)
{
Primitive_0_Args();
- return TRUTH;
+ PRIMITIVE_RETURN(TRUTH);
}
/* This primitive caches the Scheme object for the garbage collector
- primitive so that it does not have to perform an expensive search
- each time.
+ primitive so that it does not have to perform a potentially
+ expensive search each time.
*/
-Define_Primitive(Prim_Master_GC, 1, "MASTER-GC-LOOP")
+DEFINE_PRIMITIVE("MASTER-GC-LOOP", Prim_Master_GC, 1)
{
static Pointer gc_prim = NIL;
extern Pointer make_primitive();
Push(gc_prim);
Push(STACK_FRAME_HEADER + 1);
Pushed();
- longjmp(*Back_To_Eval, PRIM_APPLY);
+ PRIMITIVE_ABORT(PRIM_APPLY);
}
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.36 1987/11/20 08:18:21 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/interp.c,v 9.37 1987/12/04 22:17:11 jinx Rel $
*
* This file contains the heart of the Scheme Scode
* interpreter
* ordered alphabetically by return code name.
*/
\f
+#define Prepare_Pop_Return_Interrupt(Return_Code, Contents_of_Val) \
+{ \
+ Store_Return(Return_Code); \
+ Save_Cont(); \
+ Store_Return(RC_RESTORE_VALUE); \
+ Store_Expression(Contents_of_Val); \
+ Save_Cont(); \
+}
+
#define Interrupt(Masked_Code) \
{ \
Export_Registers(); \
Interrupt(PENDING_INTERRUPTS()); \
}
+#define Eval_GC_Check(Amount) \
+if (GC_Check(Amount)) \
+{ \
+ Prepare_Eval_Repeat(); \
+ Immediate_GC(Amount); \
+}
+\f
#define Prepare_Eval_Repeat() \
{ \
Will_Push(CONTINUATION_SIZE+1); \
Pushed(); \
}
-#define Eval_GC_Check(Amount) \
-if (GC_Check(Amount)) \
-{ \
- Prepare_Eval_Repeat(); \
- Immediate_GC(Amount); \
-}
-
#define Eval_Error(Err) \
{ \
Export_Registers(); \
goto Internal_Apply; \
}
-#define Prepare_Pop_Return_Interrupt(Return_Code, Contents_of_Val) \
+#define BACK_OUT_AFTER_PRIMITIVE() \
{ \
- Store_Return(Return_Code); \
- Save_Cont(); \
- Store_Return(RC_RESTORE_VALUE); \
- Store_Expression(Contents_of_Val); \
- Save_Cont(); \
+ Export_Registers(); \
+ Back_Out_Of_Primitive(); \
+ Import_Registers(); \
}
\f
#define Reduces_To(Expr) \
#ifdef COMPILE_FUTURES
-/* Arg_Type_Error handles the error returns from primitives which type check
- their arguments and restarts them or suspends if the argument is a future. */
+/* ARG_TYPE_ERROR handles the error returns from primitives which type check
+ their arguments and restarts them or suspends if the argument is a future.
+ */
-#define Arg_Type_Error(Arg_No, Err_No) \
+#define ARG_TYPE_ERROR(Arg_No, Err_No) \
{ \
fast Pointer *Arg, Orig_Arg; \
\
- Arg = &(Stack_Ref(Arg_No-1)); \
+ Arg = &(Stack_Ref((Arg_No - 1) + STACK_ENV_FIRST_ARG)); \
Orig_Arg = *Arg; \
\
- if (Type_Code(*Arg) != TC_FUTURE) \
+ if (OBJECT_TYPE(*Arg) != TC_FUTURE) \
{ \
Pop_Return_Error(Err_No); \
} \
\
- while ((Type_Code(*Arg) == TC_FUTURE) && (Future_Has_Value(*Arg))) \
+ while ((OBJECT_TYPE(*Arg) == TC_FUTURE) && (Future_Has_Value(*Arg))) \
{ \
if (Future_Is_Keep_Slot(*Arg)) \
{ \
} \
*Arg = Future_Value(*Arg); \
} \
- if (Type_Code(*Arg) != TC_FUTURE) \
+ if (OBJECT_TYPE(*Arg) != TC_FUTURE) \
{ \
goto Apply_Non_Trapping; \
} \
\
- Save_Cont(); \
- Will_Push(STACK_ENV_EXTRA_SLOTS+2); \
- Push(*Arg); /* Arg 1: The future itself */ \
- Push(Get_Fixed_Obj_Slot(System_Scheduler)); \
- Push(STACK_FRAME_HEADER+1); \
- Pushed(); \
+ TOUCH_SETUP(*Arg); \
*Arg = Orig_Arg; \
goto Apply_Non_Trapping; \
}
if (Future_Has_Value(*Arg)) \
{ \
if (Future_Is_Keep_Slot(*Arg)) \
+ { \
Log_Touch_Of_Future(*Arg); \
+ } \
*Arg = Future_Value(*Arg); \
} \
else \
{ \
- Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+2)); \
Store_Return(RC_INTERNAL_APPLY); \
Val = NIL; \
- Save_Cont(); \
- Push(*Arg); \
- Push(Get_Fixed_Obj_Slot(System_Scheduler)); \
- Push(STACK_FRAME_HEADER+1); \
- Pushed(); \
+ TOUCH_SETUP(*Arg); \
*Arg = Orig_Answer; \
goto Internal_Apply; \
} \
{ \
fast Pointer Orig_Val = Val; \
\
- while (Type_Code(Val) == TC_FUTURE) \
+ while (OBJECT_TYPE(Val) == TC_FUTURE) \
{ \
if (Future_Has_Value(Val)) \
{ \
if (Future_Is_Keep_Slot(Val)) \
+ { \
Log_Touch_Of_Future(Val); \
+ } \
Val = Future_Value(Val); \
} \
else \
{ \
Save_Cont(); \
- Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+2)); \
+ Will_Push(CONTINUATION_SIZE + + (STACK_ENV_EXTRA_SLOTS + 2)); \
Store_Return(RC_RESTORE_VALUE); \
Store_Expression(Orig_Val); \
Save_Cont(); \
Push(Val); \
Push(Get_Fixed_Obj_Slot(System_Scheduler)); \
- Push(STACK_FRAME_HEADER+1); \
+ Push(STACK_FRAME_HEADER + 1); \
Pushed(); \
goto Internal_Apply; \
} \
} \
}
+\f
+/* This saves stuff unnecessarily in most cases.
+ For example, when Which_Way is PRIM_APPLY, Val, Env, Expr,
+ and Return_Code are undefined.
+ */
+
+#define LOG_FUTURES() \
+{ \
+ if (Must_Report_References()) \
+ { \
+ Save_Cont(); \
+ Will_Push(CONTINUATION_SIZE + 2); \
+ Push(Val); \
+ Save_Env(); \
+ Store_Return(RC_REPEAT_DISPATCH); \
+ Store_Expression(MAKE_SIGNED_FIXNUM(CODE_MAP(Which_Way))); \
+ Save_Cont(); \
+ Pushed(); \
+ Call_Future_Logging(); \
+ } \
+}
-#else /* Not compiling FUTURES code */
+#else /* not COMPILE_FUTURES */
#define Pop_Return_Val_Check()
+
#define Apply_Future_Check(Name, Object) Name = (Object)
-#define Arg_Type_Error(Arg_No, Err_No) Pop_Return_Error(Err_No)
+#define ARG_TYPE_ERROR(Arg_No, Err_No) \
+{ \
+ Pop_Return_Error(Err_No) \
+}
+
+#define LOG_FUTURES()
+
+#endif /* COMPILE_FUTURES */
+\f
+/* Notes on Repeat_Dispatch:
+
+ The codes used (values of Which_Way) are divided into two groups:
+ Those for which the primitive has already backed out, and those for
+ which the back out code has not yet been executed, and is therefore
+ executed below.
+
+ Under most circumstances the distinction is moot, but if there are
+ futures in the system, and future touches must be logged, the code
+ must be set up to "interrupt" the dispatch, and proceed it later.
+ The primitive back out code must be done before the furure is
+ logged, so all of these codes are split into two versions: one set
+ before doing the back out, and another afterwards.
+ */
+
+/* This is assumed to be larger (in absolute value) than any PRIM_<mumble>
+ and ERR_<mumble>.
+ */
+#define PRIM_BIAS_AMOUNT 1000
+
+#if (MAX_ERROR >= PRIM_BIAS_AMOUNT)
+#include "Inconsistency: errors.h and interp.c"
#endif
+
+#define CODE_MAP(code) \
+((code < 0) ? \
+ (code - PRIM_BIAS_AMOUNT) : \
+ (code + PRIM_BIAS_AMOUNT))
+
+#define CODE_UNMAP(code) \
+((code < 0) ? \
+ (code + PRIM_BIAS_AMOUNT) : \
+ (code - PRIM_BIAS_AMOUNT))
+
+#define CODE_MAPPED_P(code) \
+((code < (- PRIM_BIAS_AMOUNT)) || \
+ (code >= PRIM_BIAS_AMOUNT))
\f
-/* The EVAL/APPLY ying/yang */
+/*
+ The EVAL/APPLY ying/yang
+ */
void
Interpret(dumped_p)
Reg_Block = &Registers[0];
- /* Primitives jump back here for errors, requests to
- * evaluate an expression, apply a function, or handle an
- * interrupt request. On errors or interrupts they leave
- * their arguments on the stack, the primitive itself in
- * Expression, and a RESTART_PRIMITIVE continuation in the
- * return register. In the other cases, they have removed
- * their stack frames entirely.
+ /* Primitives jump back here for errors, requests to evaluate an
+ * expression, apply a function, or handle an interrupt request. On
+ * errors or interrupts they leave their arguments on the stack, the
+ * primitive itself in Expression. The code should do a primitive
+ * backout in these cases, but not in others (apply, eval, etc.), since
+ * the primitive itself will have left the state of the interpreter ready
+ * for operation.
*/
Which_Way = setjmp(*Back_To_Eval);
Set_Time_Zone(Zone_Working);
Import_Registers();
- if (Must_Report_References())
- { Save_Cont();
- Will_Push(CONTINUATION_SIZE + 2);
- Push(Val);
- Save_Env();
- Store_Return(RC_REPEAT_DISPATCH);
- Store_Expression(Make_Non_Pointer(TC_FIXNUM, Which_Way));
- Save_Cont();
- Pushed();
- Call_Future_Logging();
- }
\f
Repeat_Dispatch:
switch (Which_Way)
- { case PRIM_APPLY:
+ {
+ case PRIM_APPLY:
+ LOG_FUTURES();
goto Internal_Apply;
case PRIM_NO_TRAP_APPLY:
+ LOG_FUTURES();
goto Apply_Non_Trapping;
case PRIM_DO_EXPRESSION:
+ LOG_FUTURES();
Reduces_To(Fetch_Expression());
case PRIM_NO_TRAP_EVAL:
- New_Reduction(Fetch_Expression(),Fetch_Env());
+ LOG_FUTURES();
+ New_Reduction(Fetch_Expression(), Fetch_Env());
goto Eval_Non_Trapping;
- case 0:
- if (!dumped_p)
+ case 0: /* first time */
+ if (dumped_p)
{
- break;
+ goto Pop_Return;
+ }
+ else
+ {
+ break; /* fall into eval */
}
- /* Else fall through */
case PRIM_POP_RETURN:
+ LOG_FUTURES();
goto Pop_Return;
-
- default:
- Pop_Return_Error(Which_Way);
+\f
+ case PRIM_TOUCH:
+ BACK_OUT_AFTER_PRIMITIVE();
+ LOG_FUTURES();
+ /* fall through */
+ case CODE_MAP(PRIM_TOUCH):
+ TOUCH_SETUP(Val);
+ goto Internal_Apply;
case PRIM_INTERRUPT:
- {
+ BACK_OUT_AFTER_PRIMITIVE();
+ LOG_FUTURES();
+ /* fall through */
+ case CODE_MAP(PRIM_INTERRUPT):
Save_Cont();
Interrupt(PENDING_INTERRUPTS());
- }
case ERR_ARG_1_WRONG_TYPE:
- Arg_Type_Error(1, ERR_ARG_1_WRONG_TYPE);
+ BACK_OUT_AFTER_PRIMITIVE();
+ LOG_FUTURES();
+ /* fall through */
+ case CODE_MAP(ERR_ARG_1_WRONG_TYPE):
+ ARG_TYPE_ERROR(1, ERR_ARG_1_WRONG_TYPE);
case ERR_ARG_2_WRONG_TYPE:
- Arg_Type_Error(2, ERR_ARG_2_WRONG_TYPE);
+ BACK_OUT_AFTER_PRIMITIVE();
+ LOG_FUTURES();
+ /* fall through */
+ case CODE_MAP(ERR_ARG_2_WRONG_TYPE):
+ ARG_TYPE_ERROR(2, ERR_ARG_2_WRONG_TYPE);
case ERR_ARG_3_WRONG_TYPE:
- Arg_Type_Error(3, ERR_ARG_3_WRONG_TYPE);
+ BACK_OUT_AFTER_PRIMITIVE();
+ LOG_FUTURES();
+ /* fall through */
+ case CODE_MAP(ERR_ARG_3_WRONG_TYPE):
+ ARG_TYPE_ERROR(3, ERR_ARG_3_WRONG_TYPE);
+
+ default:
+ {
+ if (!CODE_MAPPED_P(Which_Way))
+ {
+ BACK_OUT_AFTER_PRIMITIVE();
+ LOG_FUTURES();
+ }
+ else
+ {
+ Which_Way = CODE_UNMAP(Which_Way);
+ }
+ Pop_Return_Error(Which_Way);
+ }
}
\f
Do_Expression:
Reduces_To_Nth(IN_PACKAGE_EXPRESSION);
}
Pop_Return_Error(ERR_BAD_FRAME);
-\f
+
#ifdef COMPILE_FUTURES
case RC_FINISH_GLOBAL_INT:
Export_Registers();
break;
#endif
- case RC_GC_CHECK:
- if (Get_Integer(Fetch_Expression()) > Space_Before_GC())
- {
- Export_Registers();
- Microcode_Termination(TERM_GC_OUT_OF_SPACE);
- }
- break;
-
case RC_HALT:
Export_Registers();
Microcode_Termination(TERM_TERM_HANDLER);
\f
- case RC_INTERNAL_APPLY:
-
-Internal_Apply:
-/* Branch here to perform a function application.
+/* Internal_Apply, the core of the application mechanism.
+ Branch here to perform a function application.
At this point the top of the stack contains an application frame
which consists of the following elements (see sdata.h):
\f
/* Interpret(), continued */
+ case RC_INTERNAL_APPLY:
+Internal_Apply:
+
if (Microcode_Does_Stepping && Trapping &&
(Fetch_Apply_Trapper() != NIL))
{
Count = Get_Integer(Stack_Ref(STACK_ENV_HEADER));
Top_Of_Stack() = Fetch_Apply_Trapper();
- Push(STACK_FRAME_HEADER+Count);
+ Push(STACK_FRAME_HEADER + Count);
Stop_Trapping();
}
case TC_PRIMITIVE:
{
- long nargs;
- fast long primitive_code;
+ fast long nargs;
- primitive_code = OBJECT_DATUM(Function);
- if (primitive_code > MAX_PRIMITIVE)
+ if (!IMPLEMENTED_PRIMITIVE_P(Function))
{
Apply_Error(ERR_UNIMPLEMENTED_PRIMITIVE);
}
- /* Note that the test below will fail for lexpr primitives. */
+ /* Note that the first test below will fail for lexpr primitives. */
- nargs = (OBJECT_DATUM(Stack_Ref(STACK_ENV_HEADER)) -
- (STACK_ENV_FIRST_ARG - 1));
- if (nargs != PRIMITIVE_ARITY(primitive_code))
+ nargs = ((OBJECT_DATUM(Stack_Ref(STACK_ENV_HEADER))) -
+ (STACK_ENV_FIRST_ARG - 1));
+ if (nargs != PRIMITIVE_ARITY(Function))
{
- if (PRIMITIVE_ARITY(primitive_code) != LEXPR_PRIMITIVE_ARITY)
+ if (PRIMITIVE_ARITY(Function) != LEXPR_PRIMITIVE_ARITY)
{
Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
}
Regs[REGBLOCK_LEXPR_ACTUALS] = ((Pointer) nargs);
}
+
Stack_Pointer = Simulate_Popping(STACK_ENV_FIRST_ARG);
Store_Expression(Function);
Export_Regs_Before_Primitive();
- Metering_Apply_Primitive(Val, primitive_code);
+ Metering_Apply_Primitive(Val, Function);
Import_Regs_After_Primitive();
Pop_Primitive_Frame(nargs);
/* This error code means that compiled code
attempted to call an unimplemented primitive.
*/
- extern void Back_Out_Of_Primitive();
- Export_Registers();
- Back_Out_Of_Primitive();
- Import_Registers();
- goto Repeat_Dispatch;
+ BACK_OUT_AFTER_PRIMITIVE();
+ Pop_Return_Error( ERR_UNIMPLEMENTED_PRIMITIVE);
}
\f
case ERR_EXECUTE_MANIFEST_VECTOR:
case RC_NORMAL_GC_DONE:
End_GC_Hook();
+ if (GC_Space_Needed < 0)
+ {
+ /* Paranoia */
+
+ GC_Space_Needed = 0;
+ }
if (GC_Check(GC_Space_Needed))
- { fprintf(stderr,
- "\nGC just ended. The free pointer is at 0x%x, the top of this heap\n",
- Free);
- fprintf(stderr,
- "is at 0x%x, and we are trying to cons 0x%x objects. Dead!\n",
- MemTop, GC_Space_Needed);
- Microcode_Termination(TERM_NO_SPACE);
+ {
+ Microcode_Termination(TERM_GC_OUT_OF_SPACE);
}
GC_Space_Needed = 0;
Val = Fetch_Expression();
Push(Fetch_Expression());
Push(Fetch_Apply_Trapper());
Push(STACK_FRAME_HEADER + 1 +
- PRIMITIVE_N_PARAMETERS(OBJECT_DATUM(Fetch_Expression())));
+ PRIMITIVE_N_PARAMETERS(Fetch_Expression()));
Pushed();
Stop_Trapping();
goto Apply_Non_Trapping;
}
+
/* NOTE: This code must match the code in the TC_PRIMITIVE
case of Internal_Apply.
- This code is simpler because it need not deal with lexpr
- primitives.
+ This code is simpler because:
+ 1) The arity was checked at syntax time.
+ 2) We don't have to deal with "lexpr" primitives.
+ 3) We don't need to worry about unimplemented primitives because
+ unimplemented primitives will cause an error at invocation.
*/
- {
- fast long primitive_code;
- primitive_code = OBJECT_DATUM(Fetch_Expression());
- if (primitive_code > MAX_PRIMITIVE)
- {
- Push(Fetch_Expression());
- Push(STACK_FRAME_HEADER + PRIMITIVE_N_PARAMETERS(primitive_code));
- Apply_Error(ERR_UNIMPLEMENTED_PRIMITIVE);
- }
+ {
+ fast Pointer primitive;
+ primitive = Fetch_Expression();
Export_Regs_Before_Primitive();
- Metering_Apply_Primitive(Val, primitive_code);
+ Metering_Apply_Primitive(Val, primitive);
Import_Regs_After_Primitive();
- Pop_Primitive_Frame(PRIMITIVE_ARITY(primitive_code));
+ Pop_Primitive_Frame(PRIMITIVE_ARITY(primitive));
if (Must_Report_References())
{
Store_Expression(Val);
/* Interpret(), continued */
case RC_PCOMB3_DO_1:
- { Pointer Temp;
+ {
+ Pointer Temp;
+
Temp = Pop(); /* Value of arg. 3 */
Restore_Env();
Push(Temp); /* Save arg. 3 again */
/* Interpret(), continued */
case RC_PURIFY_GC_1:
- { Pointer GC_Daemon_Proc, Result;
+ {
+ Pointer GC_Daemon_Proc, Result;
+
Export_Registers();
Result = Purify_Pass_2(Fetch_Expression());
Import_Registers();
if (Result == NIL)
- { /* The object does not fit in Constant space.
+ {
+ /* The object does not fit in Constant space.
There is no need to run the daemons, and we should let the runtime
system know what happened.
*/
break;
}
GC_Daemon_Proc = Get_Fixed_Obj_Slot(GC_Daemon);
- if (GC_Daemon_Proc==NIL)
- { Val = TRUTH;
+ if (GC_Daemon_Proc == NIL)
+ {
+ Val = TRUTH;
break;
}
Store_Expression(NIL);
/* Interpret(), continued */
case RC_RESTORE_HISTORY:
- { Pointer Stacklet;
+ {
+ Pointer Stacklet;
+
Export_Registers();
if (! Restore_History(Fetch_Expression()))
- { Import_Registers();
+ {
+ Import_Registers();
Save_Cont();
Will_Push(CONTINUATION_SIZE);
Store_Expression(Val);
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.27 1987/11/20 08:17:10 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/interp.h,v 9.28 1987/12/04 22:17:56 jinx Exp $
*
* Macros used by the interpreter and some utilities.
*
\f
/* Primitive utility macros */
-/* The first two are only valid for implemented primitives. */
+/* A primitive object has two components (besides the type code), a
+ table index in the low 12 bits (assuming datum fields are 24 bits
+ wide), and a virtual index in the upper 12 bits. The table index
+ is always guaranteed to be a valid entry into
+ Primitive_Procedure_Table. For unimplemented primitives it is the
+ index of the last entry in the table, which causes an error when
+ invoked. For implemented primitives it is the real index. The
+ virtual index is 0 for implemented primitives (for histerical
+ reasons), and the actual virtual index (higher than any real table
+ index) for unimplemented primitives.
+ */
+
+#define PRIMITIVE_TABLE_INDEX(primitive) \
+((primitive) & HALF_ADDRESS_MASK)
+
+#define PRIMITIVE_VIRTUAL_INDEX(primitive) \
+(((primitive) >> HALF_ADDRESS_LENGTH) & HALF_ADDRESS_MASK)
+
+#define MAKE_PRIMITIVE_OBJECT(virtual, real) \
+(Make_Non_Pointer(TC_PRIMITIVE, (((virtual) << HALF_ADDRESS_LENGTH) | (real))))
+
+/* Does this fail for the first unimplemented primitive if there are no
+ implemented primitives?
+ */
+
+#define IMPLEMENTED_PRIMITIVE_P(primitive) \
+(PRIMITIVE_VIRTUAL_INDEX(primitive) == 0)
+
+#define PRIMITIVE_NUMBER(primitive) \
+((IMPLEMENTED_PRIMITIVE_P(primitive)) ? \
+ (PRIMITIVE_TABLE_INDEX(primitive)) : \
+ (PRIMITIVE_VIRTUAL_INDEX(primitive)))
+
+/* This will automagically cause an error if the primitive is
+ not implemented.
+ */
+
+#define Internal_Apply_Primitive(primitive) \
+((*(Primitive_Procedure_Table[PRIMITIVE_TABLE_INDEX(primitive)]))())
-#define Internal_Apply_Primitive(primitive_code) \
- ((*(Primitive_Procedure_Table[primitive_code]))())
+/* This is only valid for implemented primitives. */
-#define PRIMITIVE_ARITY(primitive_code) \
- (Primitive_Arity_Table[primitive_code])
+#define PRIMITIVE_ARITY(primitive) \
+(Primitive_Arity_Table[PRIMITIVE_TABLE_INDEX(primitive)])
extern long primitive_to_arity();
-#define PRIMITIVE_N_PARAMETERS(primitive_code) \
- (primitive_to_arity(primitive_code))
+#define PRIMITIVE_N_PARAMETERS(primitive) \
+ (primitive_to_arity(primitive))
/* This is only valid during a primitive call. */
extern long primitive_to_arguments();
-#define PRIMITIVE_N_ARGUMENTS(primitive_code) \
- (primitive_to_arguments(primitive_code))
+#define PRIMITIVE_N_ARGUMENTS(primitive) \
+ (primitive_to_arguments(primitive))
#define Pop_Primitive_Frame(NArgs) \
Stack_Pointer = Simulate_Popping(NArgs)
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.32 1987/11/17 08:14:38 jinx Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/memmag.c,v 9.33 1987/12/04 22:18:09 jinx Rel $ */
/* Memory management top level.
have changed.
*/
-Built_In_Primitive(Prim_Garbage_Collect, 1, "GARBAGE-COLLECT", 0x3A)
-Define_Primitive(Prim_Garbage_Collect, 1, "GARBAGE-COLLECT")
+DEFINE_PRIMITIVE("GARBAGE-COLLECT", Prim_Garbage_Collect, 1)
{
Pointer GC_Daemon_Proc;
Primitive_1_Arg();
Store_Expression(Make_Unsigned_Fixnum(MemTop - Free));
Save_Cont();
Pushed();
- longjmp( *Back_To_Eval, PRIM_POP_RETURN);
+ PRIMITIVE_ABORT(PRIM_POP_RETURN);
/*NOTREACHED*/
}
- Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+1));
+ Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS + 1));
Store_Return(RC_NORMAL_GC_DONE);
Store_Expression(Make_Unsigned_Fixnum(MemTop - Free));
Save_Cont();
Push(GC_Daemon_Proc);
Push(STACK_FRAME_HEADER);
Pushed();
- longjmp(*Back_To_Eval, PRIM_APPLY);
+ PRIMITIVE_ABORT(PRIM_APPLY);
/* The following comment is by courtesy of LINT, your friendly sponsor. */
/*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/object.h,v 9.26 1987/10/09 16:12:57 jinx Rel $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/object.h,v 9.27 1987/12/04 22:18:23 jinx Rel $ */
/* This file contains definitions pertaining to the C view of
Scheme pointers: widths of fields, extraction macros, pre-computed
#ifndef b32 /* Portable versions */
#define ADDRESS_LENGTH (POINTER_LENGTH-TYPE_CODE_LENGTH)
-#define ADDRESS_MASK ((1<<ADDRESS_LENGTH) - 1)
+#define ADDRESS_MASK ((1 << ADDRESS_LENGTH) - 1)
#define TYPE_CODE_MASK (~ADDRESS_MASK)
/* FIXNUM_LENGTH does NOT include the sign bit! */
-#define FIXNUM_LENGTH (ADDRESS_LENGTH-1)
-#define FIXNUM_SIGN_BIT (1<<FIXNUM_LENGTH)
+#define FIXNUM_LENGTH (ADDRESS_LENGTH - 1)
+#define FIXNUM_SIGN_BIT (1 << FIXNUM_LENGTH)
#define SIGN_MASK (TYPE_CODE_MASK | FIXNUM_SIGN_BIT)
-#define SMALLEST_FIXNUM (-1<<FIXNUM_LENGTH)
-#define BIGGEST_FIXNUM (~(-1<<FIXNUM_LENGTH))
+#define SMALLEST_FIXNUM (-1 << FIXNUM_LENGTH)
+#define BIGGEST_FIXNUM (~(-1 << FIXNUM_LENGTH))
+
+#define HALF_ADDRESS_LENGTH (ADDRESS_LENGTH / 2)
+#define HALF_ADDRESS_MASK ((1 << HALF_ADDRESS_LENGTH) - 1)
#else /* 32 bit word versions */
#define SMALLEST_FIXNUM 0xFF800000
#define BIGGEST_FIXNUM 0x007FFFFF
+#define HALF_ADDRESS_LENGTH 12
+#define HALF_ADDRESS_MASK 0x00000FFF
+
#endif
\f
#ifndef UNSIGNED_SHIFT /* Portable version */
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.h,v 9.38 1987/11/17 08:14:59 jinx Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/prim.h,v 9.39 1987/12/04 22:18:35 jinx Rel $ */
\f
/*
Primitive declarations.
extern Pointer (*(Primitive_Procedure_Table[]))();
extern int Primitive_Arity_Table[];
+extern int Primitive_Count_Table[];
extern char *Primitive_Name_Table[];
extern long MAX_PRIMITIVE;
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/prims.h,v 9.30 1987/11/23 04:55:17 cph Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/prims.h,v 9.31 1987/12/04 22:18:44 jinx Exp $ */
/* This file contains some macros for defining primitives,
for argument type or value checking, and for accessing
#define Primitive_Error signal_error_from_primitive
#define Primitive_Interrupt signal_interrupt_from_primitive
-#define Special_Primitive_Interrupt specl_interrupt_from_primitive
#define Primitive_GC(Amount) \
{ \
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/primutl.c,v 9.43 1987/11/18 19:30:52 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/primutl.c,v 9.44 1987/12/04 22:18:58 jinx Rel $
*
* This file contains the support routines for mapping primitive names
* to numbers within the microcode. Primitives are written in C
/* Common utilities. */
/*
- In primitive_name_to_code and primitive_code_to_name, size is really
- 1 less than size. It is really the index of the last valid entry.
+ In primitive_name_to_code, size is really 1 less than size.
+ It is really the index of the last valid entry.
*/
#if false
return ((long) (-1));
}
-#else /* false */
+#else /* not false */
\f
/* This version performs a log (base 2) search.
The table is assumed to be ordered alphabetically.
#endif /* false */
\f
-char *
-primitive_code_to_name(code, table, size)
- int code;
- char *table[];
- int size;
-{
- if ((code > size) || (code < 0))
- {
- return ((char *) NULL);
- }
- else
- {
- return table[code];
- }
-}
-
long
-primitive_code_to_arity(code, table, size)
- int code;
- int table[];
- int size;
+primitive_code_to_arity(number)
+ long number;
{
- if ((code > size) || (code < 0))
+ if (number <= MAX_PRIMITIVE)
{
- return ((long) -1);
+ return ((long) Primitive_Arity_Table[number]);
}
else
{
- return ((long) table[code]);
+ Pointer entry;
+ long arity;
+
+ entry = User_Vector_Ref(Undefined_Primitives_Arity,
+ (number - MAX_PRIMITIVE));
+ if (entry == NIL)
+ {
+ return ((long) UNKNOWN_PRIMITIVE_ARITY);
+ }
+ else
+ {
+ Sign_Extend(entry, arity);
+ }
+ return (arity);
}
}
\f
extern long primitive_to_arity();
long
-primitive_to_arity(code)
- int code;
+primitive_to_arity(primitive)
+ Pointer primitive;
{
- if (code <= MAX_PRIMITIVE)
- {
- return
- ((long)
- (primitive_code_to_arity(code,
- &Primitive_Arity_Table[0],
- MAX_PRIMITIVE)));
- }
- else
- {
- Pointer entry;
- long arity;
-
- entry = User_Vector_Ref(Undefined_Primitives_Arity,
- (code - MAX_PRIMITIVE));
- if (entry == NIL)
- {
- return ((long) UNKNOWN_PRIMITIVE_ARITY);
- }
- else
- {
- Sign_Extend(entry, arity);
- }
- return (arity);
- }
+ return (primitive_code_to_arity(PRIMITIVE_NUMBER(primitive)));
}
extern long primitive_to_arguments();
*/
long
-primitive_to_arguments(code)
- long code;
+primitive_to_arguments(primitive)
+ Pointer primitive;
{
long arity;
- arity = primitive_to_arity(code);
+ arity = primitive_code_to_arity(PRIMITIVE_NUMBER(primitive));
if (arity == ((long) LEXPR_PRIMITIVE_ARITY))
{
return (arity);
}
\f
-extern char *primitive_to_name();
-
char *
-primitive_to_name(code)
- int code;
+primitive_code_to_name(code)
+ int code;
{
char *string;
}
return (string);
}
+\f
+extern char *primitive_to_name();
+
+char *
+primitive_to_name(primitive)
+ Pointer primitive;
+{
+ return (primitive_code_to_name(PRIMITIVE_NUMBER(primitive)));
+}
/* this avoids some consing. */
old_arity = Primitive_Arity_Table[i];
if ((arity == UNKNOWN_PRIMITIVE_ARITY) || (arity == old_arity))
{
- return (Make_Non_Pointer(TC_PRIMITIVE, i));
+ return (MAKE_PRIMITIVE_OBJECT(0, i));
}
else
{
}
}
}
- return (Make_Non_Pointer(TC_PRIMITIVE, (MAX_PRIMITIVE + i)));
+ return (MAKE_PRIMITIVE_OBJECT((MAX_PRIMITIVE + i), (MAX_PRIMITIVE + 1)));
}
}
}
}
User_Vector_Set(Undefined_Primitives, 0, (MAKE_UNSIGNED_FIXNUM(Max)));
}
- return (Make_Non_Pointer(TC_PRIMITIVE, (MAX_PRIMITIVE + Max)));
+ return (MAKE_PRIMITIVE_OBJECT((MAX_PRIMITIVE + Max), (MAX_PRIMITIVE + 1)));
}
\f
/* Dumping and loading primitive object references. */
dump_renumber_primitive(primitive)
fast Pointer primitive;
{
+ fast long number;
fast Pointer result;
- result = internal_renumber_table[OBJECT_DATUM(primitive)];
+ number = PRIMITIVE_NUMBER(primitive);
+ result = internal_renumber_table[number];
if (result == NIL)
{
result = Make_Non_Pointer(OBJECT_TYPE(primitive),
next_primitive_renumber);
- internal_renumber_table[OBJECT_DATUM(primitive)] = result;
+ internal_renumber_table[number] = result;
external_renumber_table[next_primitive_renumber] = primitive;
next_primitive_renumber += 1;
return (result);
if (start < end)
{
- *start++ = MAKE_SIGNED_FIXNUM(primitive_to_arity(((int) code)));
+ *start++ = MAKE_SIGNED_FIXNUM(primitive_code_to_arity(((int) code)));
}
return
- copy_c_string_to_scheme_string(primitive_to_name(((int) code)),
+ copy_c_string_to_scheme_string(primitive_code_to_name(((int) code)),
start,
end);
}
((count < next_primitive_renumber) && (start < end));
count += 1)
{
- code = (OBJECT_DATUM(external_renumber_table[count]));
+ code = (PRIMITIVE_NUMBER(external_renumber_table[count]));
start = copy_primitive_information(code, start, end);
}
return (start);
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/step.c,v 9.23 1987/11/17 08:16:54 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/step.c,v 9.24 1987/12/04 22:19:24 jinx Rel $
*
* Support for the stepper
*/
/* Support of stepping primitives */
/**********************************/
-long Install_Traps(Hunk3, Return_Hook_Too)
/* UGLY ... this knows (a) that it is called with the primitive frame
already popped off the stack; and (b) the order in which Save_Cont
stores things on the stack.
*/
-Pointer Hunk3;
-Boolean Return_Hook_Too;
-{ Pointer Eval_Hook, Apply_Hook, Return_Hook;
+
+void
+Install_Traps(Hunk3, Return_Hook_Too)
+ Pointer Hunk3;
+ Boolean Return_Hook_Too;
+{
+ Pointer Eval_Hook, Apply_Hook, Return_Hook;
+
Stop_Trapping();
Eval_Hook = Vector_Ref(Hunk3, HUNK_CXR0);
Apply_Hook = Vector_Ref(Hunk3, HUNK_CXR1);
Return_Hook = Vector_Ref(Hunk3, HUNK_CXR2);
Set_Fixed_Obj_Slot(Stepper_State, Hunk3);
- Trapping = (Eval_Hook != NIL) | (Apply_Hook != NIL);
+ Trapping = ((Eval_Hook != NIL) | (Apply_Hook != NIL));
if (Microcode_Does_Stepping && Return_Hook_Too && (Return_Hook != NIL))
- { /* Here it is ... gross and ugly. We know that the top of stack
+ {
+ /* Here it is ... gross and ugly. We know that the top of stack
has the existing return code to be clobbered, since it was put
there by Save_Cont.
*/
*Return_Hook_Address = Make_Non_Pointer(TC_RETURN_CODE,
RC_RETURN_TRAP_POINT);
}
+ return;
}
\f
/* (PRIMITIVE-EVAL-STEP EXPRESSION ENV HUNK3)
APPLY or return.
*/
-Built_In_Primitive(Prim_Eval_Step, 3, "PRIMITIVE-EVAL-STEP", 0xCA)
-Define_Primitive(Prim_Eval_Step, 3, "PRIMITIVE-EVAL-STEP")
+DEFINE_PRIMITIVE("PRIMITIVE-EVAL-STEP", Prim_Eval_Step, 3)
{
Primitive_3_Args();
Pop_Primitive_Frame(3);
Store_Expression(Arg1);
Store_Env(Arg2);
- longjmp(*Back_To_Eval, PRIM_NO_TRAP_EVAL);
+ PRIMITIVE_ABORT(PRIM_NO_TRAP_EVAL);
/*NOTREACHED*/
}
\f
required before actually building a frame
*/
-Built_In_Primitive(Prim_Apply_Step, 3, "PRIMITIVE-APPLY-STEP", 0xCB)
-Define_Primitive(Prim_Apply_Step, 3, "PRIMITIVE-APPLY-STEP")
+DEFINE_PRIMITIVE("PRIMITIVE-APPLY-STEP", Prim_Apply_Step, 3)
{
Pointer Next_From_Slot, *Next_To_Slot;
long Number_Of_Args, i;
Next_From_Slot = Vector_Ref(Next_From_Slot, CONS_CDR);
}
if (Next_From_Slot != NIL)
+ {
Primitive_Error(ERR_ARG_2_WRONG_TYPE);
+ }
Install_Traps(Arg3, true);
Pop_Primitive_Frame(3);
Next_From_Slot = Arg2;
Push(Arg1); /* The function */
Push(STACK_FRAME_HEADER + Number_Of_Args);
Pushed();
- longjmp(*Back_To_Eval, PRIM_NO_TRAP_APPLY);
+ PRIMITIVE_ABORT(PRIM_NO_TRAP_APPLY);
/*NOTREACHED*/
}
\f
this is ever changed, be sure to check for COMPILE_STEPPER flag!
*/
-Built_In_Primitive(Prim_Return_Step, 2, "PRIMITIVE-RETURN-STEP", 0xCC)
-Define_Primitive(Prim_Return_Step, 2, "PRIMITIVE-RETURN-STEP")
+DEFINE_PRIMITIVE("PRIMITIVE-RETURN-STEP", Prim_Return_Step, 2)
{
Pointer Return_Hook;
Primitive_2_Args();
Return_Hook = Vector_Ref(Arg2, HUNK_CXR2);
if (Return_Hook != NIL)
+ {
Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ }
Install_Traps(Arg2, false);
- return Arg1;
+ PRIMITIVE_RETURN(Arg1);
}
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.38 1987/11/17 08:17:03 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/storage.c,v 9.39 1987/12/04 22:19:35 jinx Exp $
This file defines the storage for global variables for
the Scheme Interpreter. */
/* 0x13 */ "COMPILER-DEATH",
/* 0x14 */ "GC-OUT-OF-SPACE",
/* 0x15 */ "NO-SPACE",
-/* 0x16 */ "SIGNAL"
+/* 0x16 */ "SIGNAL",
+/* 0x17 */ "TOUCH"
};
/* If you change this table, change the Term_Messages table below as well. */
-#if (MAX_TERMINATION != 0x16)
+#if (MAX_TERMINATION != 0x17)
/* Cause an error */
#include "Inconsistency: errors.h and storage.c (Termination code table)"
#endif
/* 0x13 */ "Mismatch between compiled code and compiled code support",
/* 0x14 */ "Out of space after garbage collection",
/* 0x15 */ "Out of memory: Available memory exceeded",
-/* 0x16 */ "Unhandled signal received"
+/* 0x16 */ "Unhandled signal received",
+/* 0x17 */ "Touch without futures support"
};
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.35 1987/11/17 08:20:10 jinx Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utils.c,v 9.36 1987/12/04 22:20:24 jinx Rel $ */
/* This file contains utilities for interrupts, errors, etc. */
{
Pointer Int_Vector, Handler;
long i, Int_Number, The_Int_Code, New_Int_Enb;
- long Save_Space;
The_Int_Code = FETCH_INTERRUPT_CODE();
Int_Vector = (Get_Fixed_Obj_Slot (System_Interrupt_Vector));
if (Int_Number >= (Vector_Length (Int_Vector)))
{
fprintf (stderr,
- "\nInterrupt out of range: 0x%x (vector length = 0x%x)\n",
+ "\nInterrupt out of range: %ld (vector length = %ld)\n",
Int_Number, (Vector_Length (Int_Vector)));
fprintf (stderr,
- "Interrupts = 0x%x, Mask= 0x%x, Masked = 0x%x\n",
+ "Interrupts = 0x%08lx, Mask = 0x%08lx, Masked = 0x%08lx\n",
FETCH_INTERRUPT_CODE(),
FETCH_INTERRUPT_MASK(),
Masked_Interrupts);
Passed_Checks: /* This label may be used in Global_Interrupt_Hook */
Stop_History();
- Save_Space = CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS+3;
- if ((New_Int_Enb + 1) == INT_GC)
- {
- Save_Space += CONTINUATION_SIZE;
- }
- Will_Push(Save_Space);
+ Will_Push(CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS + 3);
/* Return from interrupt handler will re-enable interrupts */
Store_Return(RC_RESTORE_INT_MASK);
Store_Expression(MAKE_SIGNED_FIXNUM(FETCH_INTERRUPT_MASK()));
Save_Cont();
- if ((New_Int_Enb + 1) == INT_GC)
- {
- Store_Return(RC_GC_CHECK);
- Store_Expression(Make_Unsigned_Fixnum(GC_Space_Needed));
- Save_Cont();
- }
+/*
+ There used to be some code here for gc checks, but that is done
+ uniformly now by RC_NORMAL_GC_DONE.
+ */
/* Now make an environment frame for use in calling the
* user supplied interrupt routine. It will be given
Push(MAKE_SIGNED_FIXNUM(FETCH_INTERRUPT_MASK()));
Push(MAKE_SIGNED_FIXNUM(The_Int_Code));
Push(Handler);
- Push(STACK_FRAME_HEADER+2);
+ Push(STACK_FRAME_HEADER + 2);
Pushed();
/* Turn off interrupts */
SET_INTERRUPT_MASK(New_Int_Enb);
void
Back_Out_Of_Primitive ()
{
- long nargs, code;
+ long nargs;
Pointer primitive;
/* Setup a continuation to return to compiled code if the primitive is
*/
primitive = Fetch_Expression();
- code = OBJECT_DATUM(primitive);
- nargs = PRIMITIVE_N_ARGUMENTS(code);
+ nargs = PRIMITIVE_N_ARGUMENTS(primitive);
if (OBJECT_TYPE(Stack_Ref(nargs)) == TC_RETURN_ADDRESS)
{
compiler_apply_procedure(nargs);
\f
/* Useful error procedures */
+/* Note that backing out of the primitives happens after aborting,
+ not before.
+ This guarantees that the interpreter state is consistent, since the
+ longjmp restores the relevant registers even if the primitive was
+ invoked from compiled code.
+ */
+
extern void
signal_error_from_primitive(),
signal_interrupt_from_primitive(),
- specl_interrupt_from_primitive(),
error_wrong_type_arg(),
error_bad_range_arg(),
error_external_return();
signal_error_from_primitive (error_code)
long error_code;
{
- Back_Out_Of_Primitive ();
+
PRIMITIVE_ABORT(error_code);
/*NOTREACHED*/
}
void
signal_interrupt_from_primitive ()
{
- Back_Out_Of_Primitive ();
- PRIMITIVE_ABORT(PRIM_INTERRUPT);
- /*NOTREACHED*/
-}
-
-void
-specl_interrupt_from_primitive(local_mask)
- int local_mask;
-{
- Back_Out_Of_Primitive();
- Save_Cont();
- Store_Return(RC_RESTORE_INT_MASK);
- Store_Expression(MAKE_SIGNED_FIXNUM(FETCH_INTERRUPT_MASK()));
- SET_INTERRUPT_MASK(local_mask);
PRIMITIVE_ABORT(PRIM_INTERRUPT);
/*NOTREACHED*/
}
#ifdef ENABLE_DEBUGGING_TOOLS
Pointer
-Apply_Primitive (Primitive_Number)
- long Primitive_Number;
+Apply_Primitive (primitive)
+ Pointer primitive;
{
Pointer Result, *Saved_Stack;
- int NArgs;
- if (Primitive_Number > MAX_PRIMITIVE)
- {
- Primitive_Error(ERR_UNDEFINED_PRIMITIVE);
- }
if (Primitive_Debug)
{
- Print_Primitive(Primitive_Number);
+ Print_Primitive(primitive);
}
- NArgs = PRIMITIVE_N_ARGUMENTS(Primitive_Number);
Saved_Stack = Stack_Pointer;
- Result = Internal_Apply_Primitive(Primitive_Number);
+ Result = Internal_Apply_Primitive(primitive);
if (Saved_Stack != Stack_Pointer)
{
- Print_Expression(Make_Non_Pointer(TC_PRIMITIVE, Primitive_Number),
- "Stack bad after ");
+
+ int NArgs;
+
+ NArgs = PRIMITIVE_N_ARGUMENTS(primitive);
+ Print_Expression(primitive, "Stack bad after ");
fprintf(stderr,
"\nStack was 0x%x, now 0x%x, #args=%d.\n",
Saved_Stack, Stack_Pointer, NArgs);
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 10.10 1987/12/04 05:16:15 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/version.h,v 10.11 1987/12/04 22:20:47 jinx Exp $
This file contains version information for the microcode. */
\f
#define VERSION 10
#endif
#ifndef SUBVERSION
-#define SUBVERSION 10
+#define SUBVERSION 11
#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/v8/src/microcode/const.h,v 9.25 1987/11/17 08:08:36 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/const.h,v 9.26 1987/12/04 22:14:55 jinx Rel $
*
* Named constants used throughout the interpreter
*
#define PRIM_NO_TRAP_EVAL -5
#define PRIM_NO_TRAP_APPLY -6
#define PRIM_POP_RETURN -7
+#define PRIM_TOUCH -8
/* Some numbers of parameters which mean something special */
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.36 1987/11/20 08:18:21 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/interp.c,v 9.37 1987/12/04 22:17:11 jinx Rel $
*
* This file contains the heart of the Scheme Scode
* interpreter
* ordered alphabetically by return code name.
*/
\f
+#define Prepare_Pop_Return_Interrupt(Return_Code, Contents_of_Val) \
+{ \
+ Store_Return(Return_Code); \
+ Save_Cont(); \
+ Store_Return(RC_RESTORE_VALUE); \
+ Store_Expression(Contents_of_Val); \
+ Save_Cont(); \
+}
+
#define Interrupt(Masked_Code) \
{ \
Export_Registers(); \
Interrupt(PENDING_INTERRUPTS()); \
}
+#define Eval_GC_Check(Amount) \
+if (GC_Check(Amount)) \
+{ \
+ Prepare_Eval_Repeat(); \
+ Immediate_GC(Amount); \
+}
+\f
#define Prepare_Eval_Repeat() \
{ \
Will_Push(CONTINUATION_SIZE+1); \
Pushed(); \
}
-#define Eval_GC_Check(Amount) \
-if (GC_Check(Amount)) \
-{ \
- Prepare_Eval_Repeat(); \
- Immediate_GC(Amount); \
-}
-
#define Eval_Error(Err) \
{ \
Export_Registers(); \
goto Internal_Apply; \
}
-#define Prepare_Pop_Return_Interrupt(Return_Code, Contents_of_Val) \
+#define BACK_OUT_AFTER_PRIMITIVE() \
{ \
- Store_Return(Return_Code); \
- Save_Cont(); \
- Store_Return(RC_RESTORE_VALUE); \
- Store_Expression(Contents_of_Val); \
- Save_Cont(); \
+ Export_Registers(); \
+ Back_Out_Of_Primitive(); \
+ Import_Registers(); \
}
\f
#define Reduces_To(Expr) \
#ifdef COMPILE_FUTURES
-/* Arg_Type_Error handles the error returns from primitives which type check
- their arguments and restarts them or suspends if the argument is a future. */
+/* ARG_TYPE_ERROR handles the error returns from primitives which type check
+ their arguments and restarts them or suspends if the argument is a future.
+ */
-#define Arg_Type_Error(Arg_No, Err_No) \
+#define ARG_TYPE_ERROR(Arg_No, Err_No) \
{ \
fast Pointer *Arg, Orig_Arg; \
\
- Arg = &(Stack_Ref(Arg_No-1)); \
+ Arg = &(Stack_Ref((Arg_No - 1) + STACK_ENV_FIRST_ARG)); \
Orig_Arg = *Arg; \
\
- if (Type_Code(*Arg) != TC_FUTURE) \
+ if (OBJECT_TYPE(*Arg) != TC_FUTURE) \
{ \
Pop_Return_Error(Err_No); \
} \
\
- while ((Type_Code(*Arg) == TC_FUTURE) && (Future_Has_Value(*Arg))) \
+ while ((OBJECT_TYPE(*Arg) == TC_FUTURE) && (Future_Has_Value(*Arg))) \
{ \
if (Future_Is_Keep_Slot(*Arg)) \
{ \
} \
*Arg = Future_Value(*Arg); \
} \
- if (Type_Code(*Arg) != TC_FUTURE) \
+ if (OBJECT_TYPE(*Arg) != TC_FUTURE) \
{ \
goto Apply_Non_Trapping; \
} \
\
- Save_Cont(); \
- Will_Push(STACK_ENV_EXTRA_SLOTS+2); \
- Push(*Arg); /* Arg 1: The future itself */ \
- Push(Get_Fixed_Obj_Slot(System_Scheduler)); \
- Push(STACK_FRAME_HEADER+1); \
- Pushed(); \
+ TOUCH_SETUP(*Arg); \
*Arg = Orig_Arg; \
goto Apply_Non_Trapping; \
}
if (Future_Has_Value(*Arg)) \
{ \
if (Future_Is_Keep_Slot(*Arg)) \
+ { \
Log_Touch_Of_Future(*Arg); \
+ } \
*Arg = Future_Value(*Arg); \
} \
else \
{ \
- Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+2)); \
Store_Return(RC_INTERNAL_APPLY); \
Val = NIL; \
- Save_Cont(); \
- Push(*Arg); \
- Push(Get_Fixed_Obj_Slot(System_Scheduler)); \
- Push(STACK_FRAME_HEADER+1); \
- Pushed(); \
+ TOUCH_SETUP(*Arg); \
*Arg = Orig_Answer; \
goto Internal_Apply; \
} \
{ \
fast Pointer Orig_Val = Val; \
\
- while (Type_Code(Val) == TC_FUTURE) \
+ while (OBJECT_TYPE(Val) == TC_FUTURE) \
{ \
if (Future_Has_Value(Val)) \
{ \
if (Future_Is_Keep_Slot(Val)) \
+ { \
Log_Touch_Of_Future(Val); \
+ } \
Val = Future_Value(Val); \
} \
else \
{ \
Save_Cont(); \
- Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+2)); \
+ Will_Push(CONTINUATION_SIZE + + (STACK_ENV_EXTRA_SLOTS + 2)); \
Store_Return(RC_RESTORE_VALUE); \
Store_Expression(Orig_Val); \
Save_Cont(); \
Push(Val); \
Push(Get_Fixed_Obj_Slot(System_Scheduler)); \
- Push(STACK_FRAME_HEADER+1); \
+ Push(STACK_FRAME_HEADER + 1); \
Pushed(); \
goto Internal_Apply; \
} \
} \
}
+\f
+/* This saves stuff unnecessarily in most cases.
+ For example, when Which_Way is PRIM_APPLY, Val, Env, Expr,
+ and Return_Code are undefined.
+ */
+
+#define LOG_FUTURES() \
+{ \
+ if (Must_Report_References()) \
+ { \
+ Save_Cont(); \
+ Will_Push(CONTINUATION_SIZE + 2); \
+ Push(Val); \
+ Save_Env(); \
+ Store_Return(RC_REPEAT_DISPATCH); \
+ Store_Expression(MAKE_SIGNED_FIXNUM(CODE_MAP(Which_Way))); \
+ Save_Cont(); \
+ Pushed(); \
+ Call_Future_Logging(); \
+ } \
+}
-#else /* Not compiling FUTURES code */
+#else /* not COMPILE_FUTURES */
#define Pop_Return_Val_Check()
+
#define Apply_Future_Check(Name, Object) Name = (Object)
-#define Arg_Type_Error(Arg_No, Err_No) Pop_Return_Error(Err_No)
+#define ARG_TYPE_ERROR(Arg_No, Err_No) \
+{ \
+ Pop_Return_Error(Err_No) \
+}
+
+#define LOG_FUTURES()
+
+#endif /* COMPILE_FUTURES */
+\f
+/* Notes on Repeat_Dispatch:
+
+ The codes used (values of Which_Way) are divided into two groups:
+ Those for which the primitive has already backed out, and those for
+ which the back out code has not yet been executed, and is therefore
+ executed below.
+
+ Under most circumstances the distinction is moot, but if there are
+ futures in the system, and future touches must be logged, the code
+ must be set up to "interrupt" the dispatch, and proceed it later.
+ The primitive back out code must be done before the furure is
+ logged, so all of these codes are split into two versions: one set
+ before doing the back out, and another afterwards.
+ */
+
+/* This is assumed to be larger (in absolute value) than any PRIM_<mumble>
+ and ERR_<mumble>.
+ */
+#define PRIM_BIAS_AMOUNT 1000
+
+#if (MAX_ERROR >= PRIM_BIAS_AMOUNT)
+#include "Inconsistency: errors.h and interp.c"
#endif
+
+#define CODE_MAP(code) \
+((code < 0) ? \
+ (code - PRIM_BIAS_AMOUNT) : \
+ (code + PRIM_BIAS_AMOUNT))
+
+#define CODE_UNMAP(code) \
+((code < 0) ? \
+ (code + PRIM_BIAS_AMOUNT) : \
+ (code - PRIM_BIAS_AMOUNT))
+
+#define CODE_MAPPED_P(code) \
+((code < (- PRIM_BIAS_AMOUNT)) || \
+ (code >= PRIM_BIAS_AMOUNT))
\f
-/* The EVAL/APPLY ying/yang */
+/*
+ The EVAL/APPLY ying/yang
+ */
void
Interpret(dumped_p)
Reg_Block = &Registers[0];
- /* Primitives jump back here for errors, requests to
- * evaluate an expression, apply a function, or handle an
- * interrupt request. On errors or interrupts they leave
- * their arguments on the stack, the primitive itself in
- * Expression, and a RESTART_PRIMITIVE continuation in the
- * return register. In the other cases, they have removed
- * their stack frames entirely.
+ /* Primitives jump back here for errors, requests to evaluate an
+ * expression, apply a function, or handle an interrupt request. On
+ * errors or interrupts they leave their arguments on the stack, the
+ * primitive itself in Expression. The code should do a primitive
+ * backout in these cases, but not in others (apply, eval, etc.), since
+ * the primitive itself will have left the state of the interpreter ready
+ * for operation.
*/
Which_Way = setjmp(*Back_To_Eval);
Set_Time_Zone(Zone_Working);
Import_Registers();
- if (Must_Report_References())
- { Save_Cont();
- Will_Push(CONTINUATION_SIZE + 2);
- Push(Val);
- Save_Env();
- Store_Return(RC_REPEAT_DISPATCH);
- Store_Expression(Make_Non_Pointer(TC_FIXNUM, Which_Way));
- Save_Cont();
- Pushed();
- Call_Future_Logging();
- }
\f
Repeat_Dispatch:
switch (Which_Way)
- { case PRIM_APPLY:
+ {
+ case PRIM_APPLY:
+ LOG_FUTURES();
goto Internal_Apply;
case PRIM_NO_TRAP_APPLY:
+ LOG_FUTURES();
goto Apply_Non_Trapping;
case PRIM_DO_EXPRESSION:
+ LOG_FUTURES();
Reduces_To(Fetch_Expression());
case PRIM_NO_TRAP_EVAL:
- New_Reduction(Fetch_Expression(),Fetch_Env());
+ LOG_FUTURES();
+ New_Reduction(Fetch_Expression(), Fetch_Env());
goto Eval_Non_Trapping;
- case 0:
- if (!dumped_p)
+ case 0: /* first time */
+ if (dumped_p)
{
- break;
+ goto Pop_Return;
+ }
+ else
+ {
+ break; /* fall into eval */
}
- /* Else fall through */
case PRIM_POP_RETURN:
+ LOG_FUTURES();
goto Pop_Return;
-
- default:
- Pop_Return_Error(Which_Way);
+\f
+ case PRIM_TOUCH:
+ BACK_OUT_AFTER_PRIMITIVE();
+ LOG_FUTURES();
+ /* fall through */
+ case CODE_MAP(PRIM_TOUCH):
+ TOUCH_SETUP(Val);
+ goto Internal_Apply;
case PRIM_INTERRUPT:
- {
+ BACK_OUT_AFTER_PRIMITIVE();
+ LOG_FUTURES();
+ /* fall through */
+ case CODE_MAP(PRIM_INTERRUPT):
Save_Cont();
Interrupt(PENDING_INTERRUPTS());
- }
case ERR_ARG_1_WRONG_TYPE:
- Arg_Type_Error(1, ERR_ARG_1_WRONG_TYPE);
+ BACK_OUT_AFTER_PRIMITIVE();
+ LOG_FUTURES();
+ /* fall through */
+ case CODE_MAP(ERR_ARG_1_WRONG_TYPE):
+ ARG_TYPE_ERROR(1, ERR_ARG_1_WRONG_TYPE);
case ERR_ARG_2_WRONG_TYPE:
- Arg_Type_Error(2, ERR_ARG_2_WRONG_TYPE);
+ BACK_OUT_AFTER_PRIMITIVE();
+ LOG_FUTURES();
+ /* fall through */
+ case CODE_MAP(ERR_ARG_2_WRONG_TYPE):
+ ARG_TYPE_ERROR(2, ERR_ARG_2_WRONG_TYPE);
case ERR_ARG_3_WRONG_TYPE:
- Arg_Type_Error(3, ERR_ARG_3_WRONG_TYPE);
+ BACK_OUT_AFTER_PRIMITIVE();
+ LOG_FUTURES();
+ /* fall through */
+ case CODE_MAP(ERR_ARG_3_WRONG_TYPE):
+ ARG_TYPE_ERROR(3, ERR_ARG_3_WRONG_TYPE);
+
+ default:
+ {
+ if (!CODE_MAPPED_P(Which_Way))
+ {
+ BACK_OUT_AFTER_PRIMITIVE();
+ LOG_FUTURES();
+ }
+ else
+ {
+ Which_Way = CODE_UNMAP(Which_Way);
+ }
+ Pop_Return_Error(Which_Way);
+ }
}
\f
Do_Expression:
Reduces_To_Nth(IN_PACKAGE_EXPRESSION);
}
Pop_Return_Error(ERR_BAD_FRAME);
-\f
+
#ifdef COMPILE_FUTURES
case RC_FINISH_GLOBAL_INT:
Export_Registers();
break;
#endif
- case RC_GC_CHECK:
- if (Get_Integer(Fetch_Expression()) > Space_Before_GC())
- {
- Export_Registers();
- Microcode_Termination(TERM_GC_OUT_OF_SPACE);
- }
- break;
-
case RC_HALT:
Export_Registers();
Microcode_Termination(TERM_TERM_HANDLER);
\f
- case RC_INTERNAL_APPLY:
-
-Internal_Apply:
-/* Branch here to perform a function application.
+/* Internal_Apply, the core of the application mechanism.
+ Branch here to perform a function application.
At this point the top of the stack contains an application frame
which consists of the following elements (see sdata.h):
\f
/* Interpret(), continued */
+ case RC_INTERNAL_APPLY:
+Internal_Apply:
+
if (Microcode_Does_Stepping && Trapping &&
(Fetch_Apply_Trapper() != NIL))
{
Count = Get_Integer(Stack_Ref(STACK_ENV_HEADER));
Top_Of_Stack() = Fetch_Apply_Trapper();
- Push(STACK_FRAME_HEADER+Count);
+ Push(STACK_FRAME_HEADER + Count);
Stop_Trapping();
}
case TC_PRIMITIVE:
{
- long nargs;
- fast long primitive_code;
+ fast long nargs;
- primitive_code = OBJECT_DATUM(Function);
- if (primitive_code > MAX_PRIMITIVE)
+ if (!IMPLEMENTED_PRIMITIVE_P(Function))
{
Apply_Error(ERR_UNIMPLEMENTED_PRIMITIVE);
}
- /* Note that the test below will fail for lexpr primitives. */
+ /* Note that the first test below will fail for lexpr primitives. */
- nargs = (OBJECT_DATUM(Stack_Ref(STACK_ENV_HEADER)) -
- (STACK_ENV_FIRST_ARG - 1));
- if (nargs != PRIMITIVE_ARITY(primitive_code))
+ nargs = ((OBJECT_DATUM(Stack_Ref(STACK_ENV_HEADER))) -
+ (STACK_ENV_FIRST_ARG - 1));
+ if (nargs != PRIMITIVE_ARITY(Function))
{
- if (PRIMITIVE_ARITY(primitive_code) != LEXPR_PRIMITIVE_ARITY)
+ if (PRIMITIVE_ARITY(Function) != LEXPR_PRIMITIVE_ARITY)
{
Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
}
Regs[REGBLOCK_LEXPR_ACTUALS] = ((Pointer) nargs);
}
+
Stack_Pointer = Simulate_Popping(STACK_ENV_FIRST_ARG);
Store_Expression(Function);
Export_Regs_Before_Primitive();
- Metering_Apply_Primitive(Val, primitive_code);
+ Metering_Apply_Primitive(Val, Function);
Import_Regs_After_Primitive();
Pop_Primitive_Frame(nargs);
/* This error code means that compiled code
attempted to call an unimplemented primitive.
*/
- extern void Back_Out_Of_Primitive();
- Export_Registers();
- Back_Out_Of_Primitive();
- Import_Registers();
- goto Repeat_Dispatch;
+ BACK_OUT_AFTER_PRIMITIVE();
+ Pop_Return_Error( ERR_UNIMPLEMENTED_PRIMITIVE);
}
\f
case ERR_EXECUTE_MANIFEST_VECTOR:
case RC_NORMAL_GC_DONE:
End_GC_Hook();
+ if (GC_Space_Needed < 0)
+ {
+ /* Paranoia */
+
+ GC_Space_Needed = 0;
+ }
if (GC_Check(GC_Space_Needed))
- { fprintf(stderr,
- "\nGC just ended. The free pointer is at 0x%x, the top of this heap\n",
- Free);
- fprintf(stderr,
- "is at 0x%x, and we are trying to cons 0x%x objects. Dead!\n",
- MemTop, GC_Space_Needed);
- Microcode_Termination(TERM_NO_SPACE);
+ {
+ Microcode_Termination(TERM_GC_OUT_OF_SPACE);
}
GC_Space_Needed = 0;
Val = Fetch_Expression();
Push(Fetch_Expression());
Push(Fetch_Apply_Trapper());
Push(STACK_FRAME_HEADER + 1 +
- PRIMITIVE_N_PARAMETERS(OBJECT_DATUM(Fetch_Expression())));
+ PRIMITIVE_N_PARAMETERS(Fetch_Expression()));
Pushed();
Stop_Trapping();
goto Apply_Non_Trapping;
}
+
/* NOTE: This code must match the code in the TC_PRIMITIVE
case of Internal_Apply.
- This code is simpler because it need not deal with lexpr
- primitives.
+ This code is simpler because:
+ 1) The arity was checked at syntax time.
+ 2) We don't have to deal with "lexpr" primitives.
+ 3) We don't need to worry about unimplemented primitives because
+ unimplemented primitives will cause an error at invocation.
*/
- {
- fast long primitive_code;
- primitive_code = OBJECT_DATUM(Fetch_Expression());
- if (primitive_code > MAX_PRIMITIVE)
- {
- Push(Fetch_Expression());
- Push(STACK_FRAME_HEADER + PRIMITIVE_N_PARAMETERS(primitive_code));
- Apply_Error(ERR_UNIMPLEMENTED_PRIMITIVE);
- }
+ {
+ fast Pointer primitive;
+ primitive = Fetch_Expression();
Export_Regs_Before_Primitive();
- Metering_Apply_Primitive(Val, primitive_code);
+ Metering_Apply_Primitive(Val, primitive);
Import_Regs_After_Primitive();
- Pop_Primitive_Frame(PRIMITIVE_ARITY(primitive_code));
+ Pop_Primitive_Frame(PRIMITIVE_ARITY(primitive));
if (Must_Report_References())
{
Store_Expression(Val);
/* Interpret(), continued */
case RC_PCOMB3_DO_1:
- { Pointer Temp;
+ {
+ Pointer Temp;
+
Temp = Pop(); /* Value of arg. 3 */
Restore_Env();
Push(Temp); /* Save arg. 3 again */
/* Interpret(), continued */
case RC_PURIFY_GC_1:
- { Pointer GC_Daemon_Proc, Result;
+ {
+ Pointer GC_Daemon_Proc, Result;
+
Export_Registers();
Result = Purify_Pass_2(Fetch_Expression());
Import_Registers();
if (Result == NIL)
- { /* The object does not fit in Constant space.
+ {
+ /* The object does not fit in Constant space.
There is no need to run the daemons, and we should let the runtime
system know what happened.
*/
break;
}
GC_Daemon_Proc = Get_Fixed_Obj_Slot(GC_Daemon);
- if (GC_Daemon_Proc==NIL)
- { Val = TRUTH;
+ if (GC_Daemon_Proc == NIL)
+ {
+ Val = TRUTH;
break;
}
Store_Expression(NIL);
/* Interpret(), continued */
case RC_RESTORE_HISTORY:
- { Pointer Stacklet;
+ {
+ Pointer Stacklet;
+
Export_Registers();
if (! Restore_History(Fetch_Expression()))
- { Import_Registers();
+ {
+ Import_Registers();
Save_Cont();
Will_Push(CONTINUATION_SIZE);
Store_Expression(Val);
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.26 1987/10/09 16:12:57 jinx Rel $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/object.h,v 9.27 1987/12/04 22:18:23 jinx Rel $ */
/* This file contains definitions pertaining to the C view of
Scheme pointers: widths of fields, extraction macros, pre-computed
#ifndef b32 /* Portable versions */
#define ADDRESS_LENGTH (POINTER_LENGTH-TYPE_CODE_LENGTH)
-#define ADDRESS_MASK ((1<<ADDRESS_LENGTH) - 1)
+#define ADDRESS_MASK ((1 << ADDRESS_LENGTH) - 1)
#define TYPE_CODE_MASK (~ADDRESS_MASK)
/* FIXNUM_LENGTH does NOT include the sign bit! */
-#define FIXNUM_LENGTH (ADDRESS_LENGTH-1)
-#define FIXNUM_SIGN_BIT (1<<FIXNUM_LENGTH)
+#define FIXNUM_LENGTH (ADDRESS_LENGTH - 1)
+#define FIXNUM_SIGN_BIT (1 << FIXNUM_LENGTH)
#define SIGN_MASK (TYPE_CODE_MASK | FIXNUM_SIGN_BIT)
-#define SMALLEST_FIXNUM (-1<<FIXNUM_LENGTH)
-#define BIGGEST_FIXNUM (~(-1<<FIXNUM_LENGTH))
+#define SMALLEST_FIXNUM (-1 << FIXNUM_LENGTH)
+#define BIGGEST_FIXNUM (~(-1 << FIXNUM_LENGTH))
+
+#define HALF_ADDRESS_LENGTH (ADDRESS_LENGTH / 2)
+#define HALF_ADDRESS_MASK ((1 << HALF_ADDRESS_LENGTH) - 1)
#else /* 32 bit word versions */
#define SMALLEST_FIXNUM 0xFF800000
#define BIGGEST_FIXNUM 0x007FFFFF
+#define HALF_ADDRESS_LENGTH 12
+#define HALF_ADDRESS_MASK 0x00000FFF
+
#endif
\f
#ifndef UNSIGNED_SHIFT /* Portable version */
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 10.10 1987/12/04 05:16:15 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/version.h,v 10.11 1987/12/04 22:20:47 jinx Exp $
This file contains version information for the microcode. */
\f
#define VERSION 10
#endif
#ifndef SUBVERSION
-#define SUBVERSION 10
+#define SUBVERSION 11
#endif
#ifndef UCODE_TABLES_FILENAME
projects / mit-scheme.git / commitdiff