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.34 1987/09/21 21:55:23 jinx Rel $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchdmp.c,v 9.35 1987/11/17 08:06:17 jinx Exp $ */
/* bchgcl, bchmmg, bchpur, and bchdmp can replace gcloop, memmag,
purify, and fasdump, respectively, to provide garbage collection
#include "lookup.h" /* UNCOMPILED_VARIABLE */
#define In_Fasdump
#include "bchgcc.h"
+#include "fasl.h"
#include "dump.c"
-extern Pointer Make_Prim_Exts();
+extern Pointer
+ dump_renumber_primitive(),
+ *initialize_primitive_table(),
+ *cons_primitive_table(),
+ *cons_whole_primitive_table();
+
static char *dump_file_name;
static int real_gc_file, dump_file;
static Pointer *saved_free;
fasdump_normal_end(); \
}
-#define fasdump_remember_to_fix(location, contents) \
-{ \
- if ((fixup == fixup_buffer) && (!reset_fixes())) \
- return false; \
- *--fixup = contents; \
- *--fixup = ((Pointer) location); \
+#define fasdump_remember_to_fix(location, contents)
+{
+ if ((fixup == fixup_buffer) && (!reset_fixes()))
+ return false;
+ *--fixup = contents;
+ *--fixup = ((Pointer) location);
}
\f
Boolean
fasdump_exit(length)
long length;
{
- extern int ftruncate(), unlink();
fast Pointer *fixes, *fix_address;
Boolean result;
Free = saved_free;
gc_file = real_gc_file;
- ftruncate(dump_file, length);
- result = (close(dump_file) == 0);
+#if true
+ {
+ extern int ftruncate();
+
+ ftruncate(dump_file, length);
+ result = (close(dump_file) == 0);
+ }
+#else
+ {
+ extern int truncate();
+
+ result = (close(dump_file) == 0);
+ truncate(dump_file_name, length);
+ }
+#endif
if (length == 0)
+ {
+ extern int unlink();
+
unlink(dump_file_name);
+ }
dump_file_name = ((char *) NULL);
fixes = fixup;
-
+\f
next_buffer:
while (fixes != fixup_buffer_end)
fixup = fixes;
Fasdump_Exit_Hook();
- return result;
+ return (result);
}
Boolean
fixup_count += 1;
if ((lseek(real_gc_file, (fixup_count * GC_BUFFER_BYTES), 0) == -1) ||
(write(real_gc_file, fixup_buffer, GC_BUFFER_BYTES) != GC_BUFFER_BYTES))
- return false;
+ {
+ return (false);
+ }
fixup = fixup_buffer_end;
- return true;
+ return (true);
}
\f
/* A copy of GCLoop, with minor modifications. */
{
case TC_BROKEN_HEART:
if (OBJECT_DATUM(Temp) == 0)
+ {
break;
+ }
if (Scan != (Get_Pointer(Temp)))
{
fprintf(stderr, "\ndumploop: Broken heart in scan.\n");
Microcode_Termination(TERM_BROKEN_HEART);
}
if (Scan != scan_buffer_top)
+ {
goto end_dumploop;
+ }
+
/* The -1 is here because of the Scan++ in the for header. */
- Scan = dump_and_reload_scan_buffer(0, &success) - 1;
+
+ Scan = (dump_and_reload_scan_buffer(0, &success) - 1);
if (!success)
+ {
return false;
+ }
continue;
-
+\f
case TC_MANIFEST_NM_VECTOR:
case TC_MANIFEST_SPECIAL_NM_VECTOR:
/* Check whether this bumps over current buffer,
and if so we need a new bufferfull. */
Scan += Get_Integer(Temp);
if (Scan < scan_buffer_top)
+ {
break;
+ }
else
{
unsigned long overflow;
Scan = ((dump_and_reload_scan_buffer((overflow / GC_DISK_BUFFER_SIZE), &success) +
(overflow % GC_DISK_BUFFER_SIZE)) - 1);
if (!success)
+ {
return false;
+ }
break;
}
-\f
- case TC_PRIMITIVE_EXTERNAL:
+
+ case TC_PRIMITIVE:
+ case TC_PCOMB0:
+ *Scan = dump_renumber_primitive(*Scan);
+ break;
+
case TC_STACK_ENVIRONMENT:
case_Fasload_Non_Pointer:
break;
New_Address = Make_Broken_Heart(C_To_Scheme(To_Address));
copy_vector(&success);
if (!success)
+ {
return false;
+ }
*Saved_Old = New_Address;
*Scan = Relocate_Compiled(Temp, Get_Pointer(New_Address), Saved_Old);
continue;
}
-
+\f
case_Cell:
fasdump_normal_pointer(copy_cell(), 1);
fasdump_transport_end(2);
fasdump_normal_end();
}
-\f
+
case_Triple:
fasdump_normal_pointer(copy_triple(), 3);
fasdump_transport_end(3);
fasdump_normal_end();
}
-
+\f
case_Quadruple:
fasdump_normal_pointer(copy_quadruple(), 4);
Move_Vector:
copy_vector(&success);
if (!success)
+ {
return false;
+ }
fasdump_normal_end();
case TC_FUTURE:
fasdump_normal_setup();
if (!(Future_Spliceable(Temp)))
+ {
goto Move_Vector;
+ }
*Scan = Future_Value(Temp);
Scan -= 1;
continue;
end_dumploop:
*To_ptr = To;
*To_Address_ptr = To_Address;
- return true;
+ return (true);
}
\f
/* (PRIMITIVE-FASDUMP object-to-dump file-name flag)
*/
Built_In_Primitive(Prim_Prim_Fasdump, 3, "PRIMITIVE-FASDUMP", 0x56)
+Define_Primitive(Prim_Prim_Fasdump, 3, "PRIMITIVE-FASDUMP")
{
Boolean success;
- long length, hlength;
- Pointer Prim_Exts, *dumped_object, *exts, *free_buffer;
+ long length, hlength, tlength, tsize;
+ Pointer *dumped_object, *free_buffer;
+ Pointer *table_start, *table_end, *table_top;
Pointer header[FASL_HEADER_LENGTH];
Primitive_3_Args();
- success = true;
- if (Type_Code(Arg2) != TC_CHARACTER_STRING)
- Primitive_Error(ERR_ARG_2_WRONG_TYPE);
+ CHECK_ARG (2, STRING_P);
dump_file_name = Scheme_String_To_C_String(Arg2);
+
dump_file = open(dump_file_name, GC_FILE_FLAGS, 0666);
if (dump_file < 0)
+ {
Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ }
- Prim_Exts = Make_Prim_Exts();
-
+ success = true;
real_gc_file = gc_file;
gc_file = dump_file;
saved_free = Free;
fixup = fixup_buffer_end;
fixup_count = -1;
+
+ table_top = &saved_free[Space_Before_GC()];
+ table_start = initialize_primitive_table(saved_free, table_end);
+ if (table_start >= table_top)
+ {
+ fasdump_exit(0);
+ Primitive_GC(table_top - saved_free);
+ }
\f
#if (GC_DISK_BUFFER_SIZE <= FASL_HEADER_LENGTH)
#include "error in bchdmp.c: FASL_HEADER_LENGTH too large"
*free_buffer++ = Arg1;
dumped_object = Free;
Free += 1;
- *free_buffer++ = Prim_Exts;
- exts = Free;
- Free += 1;
if (!dumploop((initialize_scan_buffer() + FASL_HEADER_LENGTH),
&free_buffer, &Free))
}
length = (Free - dumped_object);
- prepare_dump_header(header, length, dumped_object, dumped_object,
- 0, Constant_Space, exts);
- hlength = (FASL_HEADER_LENGTH * sizeof(Pointer));
+
+ table_end = cons_primitive_table(table_start, table_top, &tlength);
+ if (table_end >= table_top)
+ {
+ fasdump_exit(0);
+ Primitive_GC(table_top - saved_free);
+ }
+
+ tsize = (table_end - table_start);
+ hlength = (sizeof(Pointer) * tsize);
+ if ((lseek(gc_file,
+ 0,
+ (sizeof(Pointer) * (length + FASL_HEADER_LENGTH))) == -1) ||
+ (write(gc_file, ((char *) &table_start[0]), hlength) != hlength))
+ {
+ fasdump_exit(0);
+ PRIMITIVE_RETURN(NIL);
+ }
+
+ hlength = (sizeof(Pointer) * FASL_HEADER_LENGTH);
+ prepare_dump_header(header, dumped_object, length, dumped_object,
+ 0, Constant_Space, tlength, tsize);
if ((lseek(gc_file, 0, 0) == -1) ||
(write(gc_file, ((char *) &header[0]), hlength) != hlength))
{
fasdump_exit(0);
PRIMITIVE_RETURN(NIL);
}
- PRIMITIVE_RETURN(fasdump_exit((sizeof(Pointer) * length) + hlength) ?
+ PRIMITIVE_RETURN(fasdump_exit((sizeof(Pointer) *
+ (length + tsize)) + hlength) ?
TRUTH : NIL);
}
\f
argument of NIL.
*/
Built_In_Primitive(Prim_Band_Dump, 2, "DUMP-BAND", 0xB7)
+Define_Primitive(Prim_Band_Dump, 2, "DUMP-BAND")
{
extern Pointer compiler_utilities;
- Pointer Combination, Ext_Prims;
- long Arg1Type;
+ Pointer Combination, *table_start, *table_end, *saved_free;
+ long Arg1Type, table_length;
Boolean result;
Primitive_2_Args();
Band_Dump_Permitted();
Arg1Type = Type_Code(Arg1);
if ((Arg1Type != TC_CONTROL_POINT) &&
- (Arg1Type != TC_PRIMITIVE) &&
- (Arg1Type != TC_PRIMITIVE_EXTERNAL) &&
- (Arg1Type != TC_EXTENDED_PROCEDURE)) Arg_1_Type(TC_PROCEDURE);
+ (Arg1Type != TC_EXTENDED_PROCEDURE) &&
+ (Arg1Type != TC_PRIMITIVE))
+ {
+ Arg_1_Type(TC_PROCEDURE);
+ }
Arg_2_Type(TC_CHARACTER_STRING);
+
if (!Open_Dump_File(Arg2, WRITE_FLAG))
+ {
Primitive_Error(ERR_ARG_2_BAD_RANGE);
- /* Free cannot be saved around this code since Make_Prim_Exts will
- intern the undefined externals and potentially allocate space.
- */
- Ext_Prims = Make_Prim_Exts();
+ }
+ Primitive_GC_If_Needed(5);
+ saved_free = Free;
Combination = Make_Pointer(TC_COMBINATION_1, Free);
Free[COMB_1_FN] = Arg1;
Free[COMB_1_ARG_1] = NIL;
Free += 2;
*Free++ = Combination;
*Free++ = compiler_utilities;
- *Free = Make_Pointer(TC_LIST, Free-2);
+ *Free = Make_Pointer(TC_LIST, (Free - 2));
Free++; /* Some compilers are TOO clever about this and increment Free
before calculating Free-2! */
- *Free++ = Ext_Prims;
- /* Aligning here confuses some of the counts computed.
- Align_Float(Free);
- */
- result = Write_File(((long) (Free - Heap_Bottom)), Heap_Bottom, (Free - 2),
- ((long) (Free_Constant - Constant_Space)),
- Constant_Space, (Free - 1));
- result = (result && Close_Dump_File());
+ table_start = Free;
+ table_end = cons_whole_primitive_table(Free, Heap_Top, &table_length);
+ if (table_end >= Heap_Top)
+ {
+ result = false;
+ }
+ else
+ {
+#if false
+ /* Aligning here confuses some of the counts computed. */
+ Align_Float(Free);
+#endif
+ result = Write_File((Free - 1),
+ ((long) (Free - Heap_Bottom)), Heap_Bottom,
+ ((long) (Free_Constant - Constant_Space)),
+ Constant_Space,
+ table_start, table_length,
+ ((long) (table_end - table_start)));
+ }
+ /* The and is short-circuit, so it must be done in this order. */
+ result = (Close_Dump_File() && result);
Band_Dump_Exit_Hook();
+ Free = saved_free;
if (result)
+ {
PRIMITIVE_RETURN(TRUTH);
+ }
else
{
extern int unlink();
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.37 1987/10/09 16:08:36 jinx Rel $ */
+/* $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 $ */
/* Memory management top level. Garbage collection to disk.
int Our_Heap_Size, Our_Stack_Size, Our_Constant_Size;
{
Heap_Top = (Heap_Bottom + Our_Heap_Size);
- Set_Mem_Top (Heap_Top - GC_Reserve);
+ SET_MEMTOP(Heap_Top - GC_Reserve);
Free = Heap_Bottom;
Constant_Top = (Constant_Space + Our_Constant_Size);
Free_Constant = Constant_Space;
return;
}
\f
+/* Here is the set up for the full garbage collection:
+
+ - First it makes the constant space and stack into one large area
+ by "hiding" the gap between them with a non-marked header.
+
+ - Then it saves away all the relevant microcode registers into new
+ space, making this the root for garbage collection.
+
+ - Then it does the actual garbage collection in 4 steps:
+ 1) Trace constant space.
+ 2) Trace objects pointed out by the root and constant space.
+ 3) Trace the precious objects, remembering where consing started.
+ 4) Update all weak pointers.
+
+ - Load new space to memory.
+
+ - Finally it restores the microcode registers from the copies in
+ new space.
+*/
+\f
void
GC(initial_weak_chain)
Pointer initial_weak_chain;
{
- static Pointer *Root, *Result, *end_of_constant_area,
- The_Precious_Objects, *Root2, *free_buffer;
+ Pointer
+ *Root, *Result, *end_of_constant_area,
+ The_Precious_Objects, *Root2, *free_buffer;
free_buffer = initialize_free_buffer();
Free = Heap_Bottom;
- Set_Mem_Top(Heap_Top - GC_Reserve);
+ SET_MEMTOP(Heap_Top - GC_Reserve);
Weak_Chain = initial_weak_chain;
/* Save the microcode registers so that they can be relocated */
*free_buffer++ = Fixed_Objects;
*free_buffer++ = Make_Pointer(UNMARKED_HISTORY_TYPE, History);
- *free_buffer++ = Undefined_Externals;
+ *free_buffer++ = Undefined_Primitives;
+ *free_buffer++ = Undefined_Primitives_Arity;
*free_buffer++ = Get_Current_Stacklet();
*free_buffer++ = ((Prev_Restore_History_Stacklet == NULL) ?
NIL :
*free_buffer++ = Fluid_Bindings;
Free += (free_buffer - free_buffer_bottom);
if (free_buffer >= free_buffer_top)
+ {
free_buffer = dump_and_reset_free_buffer((free_buffer - free_buffer_top),
NULL);
+ }
/* The 4 step GC */
end_transport(NULL);
Fix_Weak_Chain();
+
+ /* Load new space into memory. */
+
load_buffer(0, Heap_Bottom,
((Free - Heap_Bottom) * sizeof(Pointer)),
"new space");
Set_Fixed_Obj_Slot(Lost_Objects_Base, Make_Pointer(TC_ADDRESS, Root2));
History = Get_Pointer(*Root++);
- Undefined_Externals = *Root++;
+ Undefined_Primitives = *Root++;
+ Undefined_Primitives_Arity = *Root++;
+
+ /* Set_Current_Stacklet is sometimes a No-Op! */
+
Set_Current_Stacklet(*Root);
- Root += 1; /* Set_Current_Stacklet is sometimes a No-Op! */
+ Root += 1;
if (*Root == NIL)
{
Prev_Restore_History_Stacklet = NULL;
Root += 1;
}
else
+ {
Prev_Restore_History_Stacklet = Get_Pointer(*Root++);
+ }
Current_State_Point = *Root++;
Fluid_Bindings = *Root++;
Free_Stacklets = NULL;
*/
Built_In_Primitive(Prim_Garbage_Collect, 1, "GARBAGE-COLLECT", 0x3A)
+Define_Primitive(Prim_Garbage_Collect, 1, "GARBAGE-COLLECT")
{
Pointer GC_Daemon_Proc;
Primitive_1_Arg();
}
GC_Reserve = Get_Integer(Arg1);
GC(NIL);
- IntCode &= ~INT_GC;
+ CLEAR_INTERRUPT(INT_GC);
Pop_Primitive_Frame(1);
GC_Daemon_Proc = Get_Fixed_Obj_Slot(GC_Daemon);
if (GC_Daemon_Proc == NIL)
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchpur.c,v 9.34 1987/08/06 06:06:22 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bchpur.c,v 9.35 1987/11/17 08:06:48 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
have changed.
*/
Built_In_Primitive(Prim_Primitive_Purify, 2, "PRIMITIVE-PURIFY", 0xB4)
+Define_Primitive(Prim_Primitive_Purify, 2, "PRIMITIVE-PURIFY")
{
Pointer object, purify_result, daemon;
Primitive_2_Args();
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/bignum.c,v 9.24 1987/10/02 23:57:57 mhwu Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/bignum.c,v 9.25 1987/11/17 08:06:58 jinx Rel $
This file contains the procedures for handling BIGNUM Arithmetic.
*/
it returns the corresponding bignum.
*/
Built_In_Primitive(Prim_Fix_To_Big, 1, "COERCE-FIXNUM-TO-BIGNUM", 0x67)
+Define_Primitive(Prim_Fix_To_Big, 1, "COERCE-FIXNUM-TO-BIGNUM")
{
Primitive_1_Arg();
BIGNUM. */
Built_In_Primitive (Prim_Big_To_Fix, 1, "COERCE-BIGNUM-TO-FIXNUM", 0x68)
+Define_Primitive (Prim_Big_To_Fix, 1, "COERCE-BIGNUM-TO-FIXNUM")
{
Primitive_1_Arg ();
represent the BIGNUM in that radix.
*/
Built_In_Primitive(Prim_Listify_Bignum, 2, "LISTIFY-BIGNUM", 0x50)
+Define_Primitive(Prim_Listify_Bignum, 2, "LISTIFY-BIGNUM")
{
fast bigdigit *TOP1, *size;
quick Pointer *RFree;
}
Built_In_Primitive(Prim_Plus_Bignum, 2, "PLUS-BIGNUM", 0x4C)
+Define_Primitive(Prim_Plus_Bignum, 2, "PLUS-BIGNUM")
Binary_Primitive(plus_signed_bignum)
Built_In_Primitive(Prim_Minus_Bignum, 2, "MINUS-BIGNUM", 0x4D)
+Define_Primitive(Prim_Minus_Bignum, 2, "MINUS-BIGNUM")
Binary_Primitive(minus_signed_bignum)
Built_In_Primitive(Prim_Multiply_Bignum, 2, "MULTIPLY-BIGNUM", 0x4E)
+Define_Primitive(Prim_Multiply_Bignum, 2, "MULTIPLY-BIGNUM")
Binary_Primitive(multiply_signed_bignum)
\f
/* (DIVIDE-BIGNUM ONE-BIGNUM ANOTHER_BIGNUM)
*/
Built_In_Primitive(Prim_Divide_Bignum, 2, "DIVIDE-BIGNUM", 0x4F)
+Define_Primitive(Prim_Divide_Bignum, 2, "DIVIDE-BIGNUM")
{
Pointer Result, *End_Of_First, *First, *Second, *Orig_Free=Free;
Primitive_2_Args();
}
Built_In_Primitive(Prim_Zero_Bignum, 1, "ZERO-BIGNUM?", 0x6F)
+Define_Primitive(Prim_Zero_Bignum, 1, "ZERO-BIGNUM?")
Unary_Predicate(LEN(ARG) == 0)
Built_In_Primitive(Prim_Positive_Bignum, 1, "POSITIVE-BIGNUM?", 0x53)
+Define_Primitive(Prim_Positive_Bignum, 1, "POSITIVE-BIGNUM?")
Unary_Predicate((LEN(ARG) != 0) && POS_BIGNUM(ARG))
Built_In_Primitive(Prim_Negative_Bignum, 1, "NEGATIVE-BIGNUM?", 0x80)
+Define_Primitive(Prim_Negative_Bignum, 1, "NEGATIVE-BIGNUM?")
Unary_Predicate((LEN(ARG) != 0) && NEG_BIGNUM(ARG))
/* All the binary bignum predicates take two arguments and return NIL
}
Built_In_Primitive(Prim_Equal_Bignum, 2, "EQUAL-BIGNUM?", 0x51)
+Define_Primitive(Prim_Equal_Bignum, 2, "EQUAL-BIGNUM?")
Binary_Predicate(EQUAL)
Built_In_Primitive(Prim_Greater_Bignum, 2, "GREATER-THAN-BIGNUM?", 0x82)
+Define_Primitive(Prim_Greater_Bignum, 2, "GREATER-THAN-BIGNUM?")
Binary_Predicate(ONE_BIGGER)
Built_In_Primitive(Prim_Less_Bignum, 2, "LESS-THAN-BIGNUM?", 0x52)
+Define_Primitive(Prim_Less_Bignum, 2, "LESS-THAN-BIGNUM?")
Binary_Predicate(TWO_BIGGER)
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/bintopsb.c,v 9.28 1987/09/21 21:54:48 jinx Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bintopsb.c,v 9.29 1987/11/17 08:02:39 jinx Exp $
*
* This File contains the code to translate internal format binary
* files to portable format.
*
*/
\f
-/* Cheap renames */
+/* IO definitions */
#define Internal_File Input_File
#define Portable_File Output_File
#include "translate.h"
#include "trap.h"
-static Boolean Shuffle_Bytes = false;
-static Boolean upgrade_traps = false;
-
-static Pointer *Mem_Base;
-static long Heap_Relocation, Constant_Relocation;
-static long Free, Scan, Free_Constant, Scan_Constant;
-static long Objects, Constant_Objects;
-static Pointer *Free_Objects, *Free_Cobjects;
-
-static long NFlonums;
-static long NIntegers, NBits;
-static long NBitstrs, NBBits;
-static long NStrings, NChars;
-
long
Load_Data(Count, To_Where)
long Count;
#define Reloc_or_Load_Debug false
+#include "fasl.h"
+#define INHIBIT_FASL_VERSION_CHECK
#include "load.c"
+#include "bltdef.h"
\f
-/* Utility macros and procedures
- Pointer Objects handled specially in the portable format.
-*/
+/* Character macros and procedures */
+
+extern int strlen();
#ifndef isalpha
#include <ctype.h>
-#endif
+#endif /* isalpha */
#ifndef ispunct
s = &punctuation[0];
while (*s != '\0')
+ {
if (*s++ == c)
- return true;
- return false;
+ {
+ return (true);
+ }
+ }
+ return (false);
}
-#endif
+#endif /* ispunct */
+\f
+/* Global data */
+
+static Boolean Shuffle_Bytes = false;
+static Boolean upgrade_traps = false;
+static Boolean upgrade_primitives = false;
+
+/* Needed to upgrade */
+#define TC_PRIMITIVE_EXTERNAL 0x10
+
+static Boolean upgrade_lengths = false;
+
+#define STRING_LENGTH_TO_LONG(value) \
+((long) (upgrade_lengths ? Get_Integer(value) : (value)))
+
+static Pointer *Mem_Base;
+static long Heap_Relocation, Constant_Relocation;
+static long Free, Scan, Free_Constant, Scan_Constant;
+static long Objects, Constant_Objects;
+static Pointer *Free_Objects, *Free_Cobjects;
+static Pointer *primitive_table;
+
+static long NFlonums;
+static long NIntegers, NBits;
+static long NBitstrs, NBBits;
+static long NStrings, NChars;
+static long NPChars;
+\f
#define OUT(s) \
fprintf(Portable_File, s); \
break
case ' ' : OUT(" ");
default:
if ((isalpha(c)) || (isdigit(c)) || (ispunct(c)))
+ {
putc(c, Portable_File);
+ }
else
{
fprintf(stderr,
fprintf(Portable_File, "\X%x ", ((int) c));
}
}
+ return;
}
\f
#define Do_Compound(Code, Rel, Fre, Scn, Obj, FObj, kernel_code) \
Old_Contents = *Old_Address; \
\
if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
- Mem_Base[(Scn)] = \
- Make_New_Pointer((Code), Old_Contents); \
+ { \
+ Mem_Base[(Scn)] = Make_New_Pointer((Code), Old_Contents); \
+ } \
else \
{ \
kernel_code; \
*(FObj)++ = Make_Non_Pointer((type), 0); \
*(FObj)++ = Old_Contents; \
while(--length >= 0) \
+ { \
*(FObj)++ = *Old_Address++; \
+ } \
}
\f
#define do_string_kernel() \
temp = ((val < 0) ? -val : val);
for (size_in_bits = 0; temp != 0; size_in_bits += 1)
+ {
temp = temp >> 1;
+ }
fprintf(Portable_File, "%02x %c ",
TC_FIXNUM,
(val < 0 ? '-' : '+'));
if (val == 0)
+ {
fprintf(Portable_File, "0\n");
+ }
else
{
fprintf(Portable_File, "%ld ", size_in_bits);
}
\f
void
-print_a_string(from)
- Pointer *from;
+print_a_string_internal(len, string)
+ fast long len;
+ fast char *string;
{
- fast long len;
- fast char *string;
- long maxlen;
-
- maxlen = pointer_to_char((Get_Integer(*from++))-1);
- len = Get_Integer(*from++);
- fprintf(Portable_File, "%02x %ld %ld ",
- TC_CHARACTER_STRING,
- (Compact_P ? len : maxlen),
- len);
- string = ((char *) from);
+ fprintf(Portable_File, "%ld ", len);
if (Shuffle_Bytes)
{
while(len > 0)
{
print_a_char(string[3], "print_a_string");
if (len > 1)
+ {
print_a_char(string[2], "print_a_string");
+ }
if (len > 2)
+ {
print_a_char(string[1], "print_a_string");
+ }
if (len > 3)
+ {
print_a_char(string[0], "print_a_string");
+ }
len -= 4;
string += 4;
}
}
else
+ {
while(--len >= 0)
+ {
print_a_char(*string++, "print_a_string");
+ }
+ }
putc('\n', Portable_File);
return;
}
\f
void
+print_a_string(from)
+ Pointer *from;
+{
+ long len;
+ long maxlen;
+
+ maxlen = pointer_to_char((Get_Integer(*from++)) - 1);
+ len = STRING_LENGTH_TO_LONG(*from++);
+
+ fprintf(Portable_File,
+ "%02x %ld ",
+ TC_CHARACTER_STRING,
+ (Compact_P ? len : maxlen));
+
+ print_a_string_internal(len, ((char *) from));
+ return;
+}
+
+void
+print_a_primitive(arity, length, name)
+ long arity, length;
+ char *name;
+{
+ fprintf(Portable_File, "%ld ", arity);
+ print_a_string_internal(length, name);
+ return;
+}
+\f
+void
print_a_bignum(from)
Pointer *from;
{
the_number = BIGNUM(from);
temp = LEN(the_number);
if (temp == 0)
+ {
fprintf(Portable_File, "%02x + 0\n",
(Compact_P ? TC_FIXNUM : TC_BIG_FIXNUM));
+ }
else
{
fast long tail;
temp = ((long) (*Bignum_Top(the_number)));
temp != 0;
size_in_bits += 1)
+ {
temp = temp >> 1;
-
+ }
+\f
fprintf(Portable_File, "%02x %c %ld ",
(Compact_P ? TC_FIXNUM : TC_BIG_FIXNUM),
(NEG_BIGNUM(the_number) ? '-' : '+'),
size_in_bits);
tail = size_in_bits % SHIFT;
if (tail == 0)
+ {
tail = SHIFT;
+ }
temp = 0;
size_in_bits = 0;
the_top = Bignum_Top(the_number);
}
}
if (size_in_bits > 0)
+ {
fprintf(Portable_File, "%01lx\n", (temp & 0xf));
+ }
else
+ {
fprintf(Portable_File, "\n");
+ }
}
return;
}
\f
/* The following procedure assumes that a C long is at least 4 bits. */
+void
print_a_bit_string(from)
Pointer *from;
{
}
}
if (leftover_bits != 0)
+ {
fprintf(Portable_File, "%01lx", (accumulator & 0xf));
+ }
}
fprintf(Portable_File, "\n");
return;
}
\f
+void
print_a_flonum(val)
double val;
{
}
fprintf(Portable_File, "%01x", digit);
}
- fprintf(Portable_File, "\n");
+ putc('\n', Portable_File);
return;
}
\f
Old_Contents = *Old_Address; \
\
if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
- Mem_Base[(Scn)] = \
- Make_New_Pointer(Type_Code(This), Old_Contents); \
+ { \
+ Mem_Base[(Scn)] = Make_New_Pointer(Type_Code(This), Old_Contents); \
+ } \
else \
{ \
*Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
Old_Contents = *Old_Address; \
\
if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
- Mem_Base[(Scn)] = \
- Make_New_Pointer(Type_Code(This), Old_Contents); \
+ { \
+ Mem_Base[(Scn)] = Make_New_Pointer(Type_Code(This), Old_Contents); \
+ } \
else \
{ \
*Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
Mem_Base[(Fre)++] = *Old_Address++; \
} \
}
-
+\f
#define Do_Triple(Code, Rel, Fre, Scn, Obj, FObj) \
{ \
Old_Address += (Rel); \
Old_Contents = *Old_Address; \
\
if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
- Mem_Base[(Scn)] = \
- Make_New_Pointer(Type_Code(This), Old_Contents); \
+ { \
+ Mem_Base[(Scn)] = Make_New_Pointer(Type_Code(This), Old_Contents); \
+ } \
else \
{ \
*Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
} \
}
+#define Do_Quad(Code, Rel, Fre, Scn, Obj, FObj) \
+{ \
+ Old_Address += (Rel); \
+ Old_Contents = *Old_Address; \
+ \
+ if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
+ { \
+ Mem_Base[(Scn)] = Make_New_Pointer(Type_Code(This), Old_Contents); \
+ } \
+ else \
+ { \
+ *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
+ Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \
+ Mem_Base[(Fre)++] = Old_Contents; \
+ Mem_Base[(Fre)++] = *Old_Address++; \
+ Mem_Base[(Fre)++] = *Old_Address++; \
+ Mem_Base[(Fre)++] = *Old_Address++; \
+ } \
+}
+\f
#define Do_Vector(Code, Rel, Fre, Scn, Obj, FObj) \
{ \
Old_Address += (Rel); \
Old_Contents = *Old_Address; \
\
if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
- Mem_Base[(Scn)] = \
- Make_New_Pointer(Type_Code(This), Old_Contents); \
+ { \
+ Mem_Base[(Scn)] = Make_New_Pointer(Type_Code(This), Old_Contents); \
+ } \
else \
{ \
fast long len; \
fprintf(stderr, \
"%s: File is not portable: Pointer to stack.\n", \
Program_Name); \
- exit(1); \
+ quit(1); \
} \
(Scn) += 1; \
break; \
}
\f
+/* Primitive upgrading code. */
+
+#define PRIMITIVE_UPGRADE_SPACE 2048
+static Pointer *internal_renumber_table;
+static Pointer *external_renumber_table;
+static Pointer *external_prim_name_table;
+static Boolean found_ext_prims = false;
+
+Pointer *
+relocate(object)
+ Pointer object;
+{
+ Pointer *result;
+ result = (Get_Pointer(object) + ((Datum(object) < Const_Base) ?
+ Heap_Relocation :
+ Constant_Relocation));
+ return (result);
+}
+
+Pointer
+upgrade_primitive(prim)
+ Pointer prim;
+{
+ long datum, type, new_type, code;
+ Pointer new;
+
+ datum = OBJECT_DATUM(prim);
+ type = OBJECT_TYPE(prim);
+ if (type != TC_PRIMITIVE_EXTERNAL)
+ {
+ code = datum;
+ new_type = type;
+ }
+ else
+ {
+ found_ext_prims = true;
+ code = (datum + (MAX_BUILTIN_PRIMITIVE + 1));
+ new_type = TC_PRIMITIVE;
+ }
+\f
+ new = internal_renumber_table[code];
+ if (new == NIL)
+ {
+ /*
+ This does not need to check for overflow because the worst case
+ was checked in setup_primitive_upgrade;
+ */
+
+ new = Make_Non_Pointer(new_type, Primitive_Table_Length);
+ internal_renumber_table[code] = new;
+ external_renumber_table[Primitive_Table_Length] = prim;
+ Primitive_Table_Length += 1;
+ if (type == TC_PRIMITIVE_EXTERNAL)
+ {
+ NPChars +=
+ STRING_LENGTH_TO_LONG((((Pointer *) (external_prim_name_table[datum]))
+ [STRING_LENGTH]));
+ }
+ else
+ {
+ NPChars += strlen(builtin_prim_name_table[datum]);
+ }
+ return (new);
+ }
+ else
+ {
+ return (Make_New_Pointer(new_type, new));
+ }
+}
+\f
+Pointer *
+setup_primitive_upgrade(Heap)
+ Pointer *Heap;
+{
+ fast long count, length;
+ Pointer *old_prims_vector;
+
+ internal_renumber_table = &Heap[0];
+ external_renumber_table =
+ &internal_renumber_table[PRIMITIVE_UPGRADE_SPACE];
+ external_prim_name_table =
+ &external_renumber_table[PRIMITIVE_UPGRADE_SPACE];
+
+ old_prims_vector = relocate(Ext_Prim_Vector);
+ if (*old_prims_vector == NIL)
+ {
+ length = 0;
+ }
+ else
+ {
+ old_prims_vector = relocate(*old_prims_vector);
+ length = Get_Integer(*old_prims_vector);
+ old_prims_vector += VECTOR_DATA;
+ for (count = 0; count < length; count += 1)
+ {
+ Pointer *temp;
+
+ /* symbol */
+ temp = relocate(old_prims_vector[count]);
+ /* string */
+ temp = relocate(temp[SYMBOL_NAME]);
+ external_prim_name_table[count] = ((Pointer) temp);
+ }
+ }
+ length += (MAX_BUILTIN_PRIMITIVE + 1);
+ if (length > PRIMITIVE_UPGRADE_SPACE)
+ {
+ fprintf(stderr, "%s: Too many primitives.\n", Program_Name);
+ fprintf(stderr,
+ "Increase PRIMITIVE_UPGRADE_SPACE and recompile %s.\n",
+ Program_Name);
+ quit(1);
+ }
+ for (count = 0; count < length; count += 1)
+ {
+ internal_renumber_table[count] = NIL;
+ }
+ NPChars = 0;
+ return (&external_prim_name_table[PRIMITIVE_UPGRADE_SPACE]);
+}
+\f
/* Processing of a single area */
#define Do_Area(Code, Area, Bound, Obj, FObj) \
while(*Area != *Bound)
{
This = Mem_Base[*Area];
+
+#ifdef PRIMITIVE_EXTERNAL_REUSED
+ if (upgrade_primitives && (Type_Code(This) == TC_PRIMITIVE_EXTERNAL))
+ {
+ Mem_Base[*Area] = upgrade_primitive(This);
+ *Area += 1;
+ continue;
+ }
+#endif /* PRIMITIVE_EXTERNAL_REUSED */
+
Switch_by_GC_Type(This)
{
+#ifndef PRIMITIVE_EXTERNAL_REUSED
+
+ case TC_PRIMITIVE_EXTERNAL:
+
+#endif /* PRIMITIVE_EXTERNAL_REUSED */
+
+ case TC_PRIMITIVE:
+ case TC_PCOMB0:
+ if (upgrade_primitives)
+ {
+ Mem_Base[*Area] = upgrade_primitive(This);
+ }
+ *Area += 1;
+ break;
+\f
case TC_MANIFEST_NM_VECTOR:
if (Null_NMV)
{
i = Get_Integer(This);
*Area += 1;
for ( ; --i >= 0; *Area += 1)
+ {
Mem_Base[*Area] = NIL;
+ }
break;
}
- /* else, Unknown object! */
fprintf(stderr, "%s: File is not portable: NMH found\n",
Program_Name);
*Area += 1 + Get_Integer(This);
{
fprintf(stderr, "%s: Broken Heart found in scan.\n",
Program_Name);
- exit(1);
+ quit(1);
}
*Area += 1;
break;
fprintf(stderr,
"%s: File is not portable: Compiled code.\n",
Program_Name);
- exit(1);
-\f
+ quit(1);
+
case TC_FIXNUM:
NIntegers += 1;
NBits += fixnum_to_bits;
/* Fall through */
case TC_MANIFEST_SPECIAL_NM_VECTOR:
- case TC_PRIMITIVE_EXTERNAL:
case_simple_Non_Pointer:
*Area += 1;
break;
-
+\f
case_Cell:
Do_Pointer(*Area, Do_Cell);
fprintf(stderr,
"%s: Bad old unassigned object. 0x%x.\n",
Program_Name, This);
- exit(1);
+ quit(1);
}
if (kind <= TRAP_MAX_IMMEDIATE)
{
fprintf(stderr,
"%s: Cannot upgrade environments.\n",
Program_Name);
- exit(1);
+ quit(1);
}
/* Fall through */
Bad_Type:
fprintf(stderr, "%s: Unknown Type Code 0x%x found.\n",
Program_Name, Type_Code(This));
- exit(1);
+ quit(1);
}
}
}
\
case TC_BIT_STRING: \
print_a_bit_string(++from); \
- from += 1 + Get_Integer(*from); \
+ from += (1 + Get_Integer(*from)); \
break; \
\
case TC_BIG_FIXNUM: \
print_a_bignum(++from); \
- from += 1 + Get_Integer(*from); \
+ from += (1 + Get_Integer(*from)); \
break; \
\
case TC_CHARACTER_STRING: \
print_a_string(++from); \
- from += 1 + Get_Integer(*from); \
+ from += (1 + Get_Integer(*from)); \
break; \
\
case TC_BIG_FLONUM: \
print_a_flonum( *((double *) (from + 1))); \
- from += 1 + float_to_pointer; \
+ from += (1 + float_to_pointer); \
break; \
\
case TC_CHARACTER: \
fprintf(stderr, \
"%s: Bad Object to print externally %lx\n", \
Program_Name, *from); \
- exit(1); \
+ quit(1); \
} \
}
-\f
-#define print_an_object(obj) \
-fprintf(Portable_File, "%02x %lx\n", \
- Type_Code(obj), Get_Integer(obj))
+#define print_an_object(obj) \
+{ \
+ fprintf(Portable_File, "%02x %lx\n", \
+ Type_Code(obj), Get_Integer(obj)); \
+}
+\f
/* Debugging Aids and Consistency Checks */
#ifdef DEBUG
-When(what, message)
+#define DEBUGGING(action) action
+
+#define WHEN(condition, message) when(condition, message)
+
+void
+when(what, message)
Boolean what;
char *message;
{
{
fprintf(stderr, "%s: Inconsistency: %s!\n",
Program_Name, (message));
- exit(1);
+ quit(1);
}
return;
}
-#define print_header(name, obj, format) \
+#define PRINT_HEADER(name, obj, format) \
{ \
fprintf(Portable_File, (format), (obj)); \
fprintf(stderr, "%s: ", (name)); \
fprintf(stderr, (format), (obj)); \
}
-#else
+#else /* not DEBUG */
+
+#define DEBUGGING(action)
-#define When(what, message)
+#define WHEN(what, message)
-#define print_header(name, obj, format) \
+#define PRINT_HEADER(name, obj, format) \
{ \
fprintf(Portable_File, (format), (obj)); \
}
-#endif
+#endif /* DEBUG */
\f
/* The main program */
+void
do_it()
{
Pointer *Heap;
fprintf(stderr,
"%s: Input file does not appear to be in FASL format.\n",
Program_Name);
- exit(1);
+ quit(1);
}
- if ((Version != FASL_FORMAT_VERSION) ||
- (Sub_Version > FASL_SUBVERSION) ||
- (Sub_Version < FASL_OLDEST_SUPPORTED) ||
- ((Machine_Type != FASL_INTERNAL_FORMAT) && (!Shuffle_Bytes)))
+ if ((Version > FASL_READ_VERSION) ||
+ (Version < FASL_OLDEST_VERSION) ||
+ (Sub_Version > FASL_READ_SUBVERSION) ||
+ (Sub_Version < FASL_OLDEST_SUBVERSION) ||
+ ((Machine_Type != FASL_INTERNAL_FORMAT) &&
+ (!Shuffle_Bytes)))
{
fprintf(stderr, "%s:\n", Program_Name);
fprintf(stderr,
Version, Sub_Version , Machine_Type);
fprintf(stderr,
"Expected: Version %d Subversion %d Machine Type %d\n",
- FASL_FORMAT_VERSION, FASL_SUBVERSION, FASL_INTERNAL_FORMAT);
- exit(1);
+ FASL_READ_VERSION, FASL_READ_SUBVERSION, FASL_INTERNAL_FORMAT);
+ quit(1);
}
if (Machine_Type == FASL_INTERNAL_FORMAT)
+ {
Shuffle_Bytes = false;
+ }
upgrade_traps = (Sub_Version < FASL_REFERENCE_TRAP);
+ upgrade_primitives = (Sub_Version < FASL_MERGED_PRIMITIVES);
+ upgrade_lengths = upgrade_primitives;
/* Constant Space not currently supported */
fprintf(stderr,
"%s: Input file has a constant space area.\n",
Program_Name);
- exit(1);
+ quit(1);
}
-
+\f
{
long Size;
- Size = ((3 * (Heap_Count + Const_Count)) + NROOTS + 1);
+ Size = ((3 * (Heap_Count + Const_Count)) +
+ (NROOTS + 1) +
+ (upgrade_primitives ?
+ (3 * PRIMITIVE_UPGRADE_SPACE) :
+ Primitive_Table_Size));
Allocate_Heap_Space(Size + HEAP_BUFFER_SPACE);
if (Heap == NULL)
fprintf(stderr,
"%s: Memory Allocation Failed. Size = %ld Scheme Pointers\n",
Program_Name, Size);
- exit(1);
+ quit(1);
}
}
+
Heap += HEAP_BUFFER_SPACE;
Initial_Align_Float(Heap);
Load_Data(Heap_Count, &Heap[0]);
Load_Data(Const_Count, &Heap[Heap_Count]);
+ Load_Data(Primitive_Table_Size, &Heap[Heap_Count + Const_Count]);
Heap_Relocation = &Heap[0] - Get_Pointer(Heap_Base);
Constant_Relocation = &Heap[Heap_Count] - Get_Pointer(Const_Base);
-#ifdef DEBUG
- fprintf(stderr, "Dumped Heap Base = 0x%08x\n", Heap_Base);
- fprintf(stderr, "Dumped Constant Base = 0x%08x\n", Const_Base);
- fprintf(stderr, "Dumped Constant Top = 0x%08x\n", Dumped_Constant_Top);
- fprintf(stderr, "Heap Count = %6d\n", Heap_Count);
- fprintf(stderr, "Constant Count = %6d\n", Const_Count);
-#endif
-\f
- /* Reformat the data */
+ DEBUGGING(fprintf(stderr,
+ "Dumped Heap Base = 0x%08x\n",
+ Heap_Base));
- NFlonums = NIntegers = NStrings = 0;
- NBits = NBBits = NChars = 0;
- Mem_Base = &Heap[Heap_Count + Const_Count];
+ DEBUGGING(fprintf(stderr,
+ "Dumped Constant Base = 0x%08x\n",
+ Const_Base));
+
+ DEBUGGING(fprintf(stderr,
+ "Dumped Constant Top = 0x%08x\n",
+ Dumped_Constant_Top));
+
+ DEBUGGING(fprintf(stderr,
+ "Heap Count = %6d\n",
+ Heap_Count));
- if (Ext_Prim_Vector == NIL)
+ DEBUGGING(fprintf(stderr,
+ "Constant Count = %6d\n",
+ Const_Count));
+\f
+ /* Determine primitive information. */
+
+ primitive_table = &Heap[Heap_Count + Const_Count];
+ if (upgrade_primitives)
{
- Mem_Base[0] = Make_Non_Pointer(TC_CELL, 2);
- Mem_Base[1] = Make_New_Pointer(TC_CELL, Dumped_Object);
- Mem_Base[2] = NIL;
- Initial_Free = NROOTS + 1;
- Scan = 1;
+ Mem_Base = setup_primitive_upgrade(primitive_table);
}
else
{
- Mem_Base[0] = Ext_Prim_Vector; /* Has CELL TYPE */
- Mem_Base[1] = Make_New_Pointer(TC_CELL, Dumped_Object);
- Initial_Free = NROOTS;
- Scan = 0;
+ fast Pointer *table;
+ fast long count, char_count;
+
+ for (char_count = 0,
+ count = Primitive_Table_Length,
+ table = primitive_table;
+ --count >= 0;)
+ {
+ char_count += STRING_LENGTH_TO_LONG(table[1 + STRING_LENGTH]);
+ table += (2 + Get_Integer(table[1 + STRING_HEADER]));
+ }
+ NPChars = char_count;
+ Mem_Base = &primitive_table[Primitive_Table_Size];
}
+\f
+ /* Reformat the data */
+
+ NFlonums = NIntegers = NStrings = 0;
+ NBits = NBBits = NChars = 0;
+
+ Mem_Base[0] = Make_New_Pointer(TC_CELL, Dumped_Object);
+ Initial_Free = NROOTS;
+ Scan = 0;
Free = Initial_Free;
Free_Objects = &Mem_Base[Heap_Count + Initial_Free];
Constant_Objects = 0;
#if true
+
Do_Area(HEAP_CODE, Scan, Free, Objects, Free_Objects);
+
#else
- /* When Constant Space finally becomes supported,
- something like this must be done. */
+
+ /*
+ When Constant Space finally becomes supported,
+ something like this must be done.
+ */
+
while (true)
{
- Do_Area(HEAP_CODE, Scan, Free, Objects, Free_Objects);
- Do_Area(CONSTANT_CODE, Scan_Constant,
- Free_Constant, Constant_Objects, Free_Cobjects);
- Do_Area(PURE_CODE, Scan_Pure, Fre_Pure, Pure_Objects, Free_Pobjects);
+ Do_Area(HEAP_CODE, Scan, Free,
+ Objects, Free_Objects);
+ Do_Area(CONSTANT_CODE, Scan_Constant, Free_Constant,
+ Constant_Objects, Free_Cobjects);
+ Do_Area(PURE_CODE, Scan_Pure, Free_Pure,
+ Pure_Objects, Free_Pobjects);
if (Scan == Free)
+ {
break;
+ }
}
+
#endif
\f
/* Consistency checks */
- When(((Free - Initial_Free) > Heap_Count), "Free overran Heap");
- When(((Free_Objects - &Mem_Base[Initial_Free + Heap_Count]) >
+ WHEN(((Free - Initial_Free) > Heap_Count), "Free overran Heap");
+
+ WHEN(((Free_Objects - &Mem_Base[Initial_Free + Heap_Count]) >
Heap_Count),
"Free_Objects overran Heap Object Space");
- When(((Free_Constant - (Initial_Free + (2 * Heap_Count))) > Const_Count),
+
+ WHEN(((Free_Constant - (Initial_Free + (2 * Heap_Count))) > Const_Count),
"Free_Constant overran Constant Space");
- When(((Free_Cobjects - &Mem_Base[Initial_Free + (2 * Heap_Count) + Const_Count]) >
+
+ WHEN(((Free_Cobjects - &Mem_Base[Initial_Free +
+ (2 * Heap_Count) + Const_Count]) >
Const_Count),
"Free_Cobjects overran Constant Object Space");
\f
/* Output the data */
+ if (found_ext_prims)
+ {
+ fprintf(stderr, "%s:\n", Program_Name);
+ fprintf(stderr, "NOTE: The arity of some primitives is not known.\n");
+ fprintf(stderr, " The portable file has %ld as their arity.\n",
+ UNKNOWN_PRIMITIVE_ARITY);
+ fprintf(stderr, " You may want to fix this by hand.\n");
+ }
+
/* Header */
- print_header("Portable Version", PORTABLE_VERSION, "%ld\n");
- print_header("Flags", Make_Flags(), "%ld\n");
- print_header("Version", FASL_FORMAT_VERSION, "%ld\n");
- print_header("Sub Version", FASL_SUBVERSION, "%ld\n");
+ PRINT_HEADER("Portable Version", PORTABLE_VERSION, "%ld\n");
+ PRINT_HEADER("Flags", Make_Flags(), "%ld\n");
+ PRINT_HEADER("Version", FASL_FORMAT_VERSION, "%ld\n");
+ PRINT_HEADER("Sub Version", FASL_SUBVERSION, "%ld\n");
- print_header("Heap Count", (Free - NROOTS), "%ld\n");
- print_header("Heap Base", NROOTS, "%ld\n");
- print_header("Heap Objects", Objects, "%ld\n");
+ PRINT_HEADER("Heap Count", (Free - NROOTS), "%ld\n");
+ PRINT_HEADER("Heap Base", NROOTS, "%ld\n");
+ PRINT_HEADER("Heap Objects", Objects, "%ld\n");
/* Currently Constant and Pure not supported, but the header is ready */
- print_header("Pure Count", 0, "%ld\n");
- print_header("Pure Base", Free_Constant, "%ld\n");
- print_header("Pure Objects", 0, "%ld\n");
+ PRINT_HEADER("Pure Count", 0, "%ld\n");
+ PRINT_HEADER("Pure Base", Free_Constant, "%ld\n");
+ PRINT_HEADER("Pure Objects", 0, "%ld\n");
+
+ PRINT_HEADER("Constant Count", 0, "%ld\n");
+ PRINT_HEADER("Constant Base", Free_Constant, "%ld\n");
+ PRINT_HEADER("Constant Objects", 0, "%ld\n");
- print_header("Constant Count", 0, "%ld\n");
- print_header("Constant Base", Free_Constant, "%ld\n");
- print_header("Constant Objects", 0, "%ld\n");
+ PRINT_HEADER("& Dumped Object", (Get_Integer(Mem_Base[0])), "%ld\n");
- print_header("& Dumped Object", (Get_Integer(Mem_Base[1])), "%ld\n");
- print_header("& Ext Prim Vector", (Get_Integer(Mem_Base[0])), "%ld\n");
+ PRINT_HEADER("Number of flonums", NFlonums, "%ld\n");
+ PRINT_HEADER("Number of integers", NIntegers, "%ld\n");
+ PRINT_HEADER("Number of bits in integers", NBits, "%ld\n");
+ PRINT_HEADER("Number of bit strings", NBitstrs, "%ld\n");
+ PRINT_HEADER("Number of bits in bit strings", NBBits, "%ld\n");
+ PRINT_HEADER("Number of character strings", NStrings, "%ld\n");
+ PRINT_HEADER("Number of characters in strings", NChars, "%ld\n");
- print_header("Number of flonums", NFlonums, "%ld\n");
- print_header("Number of integers", NIntegers, "%ld\n");
- print_header("Number of bits in integers", NBits, "%ld\n");
- print_header("Number of bit strings", NBitstrs, "%ld\n");
- print_header("Number of bits in bit strings", NBBits, "%ld\n");
- print_header("Number of character strings", NStrings, "%ld\n");
- print_header("Number of characters in strings", NChars, "%ld\n");
+ PRINT_HEADER("Number of primitives", Primitive_Table_Length, "%ld\n");
+ PRINT_HEADER("Number of characters in primitives", NPChars, "%ld\n");
\f
/* External Objects */
Free_Objects = &Mem_Base[Initial_Free + Heap_Count];
for (; Objects > 0; Objects -= 1)
+ {
print_external_object(Free_Objects);
+ }
#if false
/* Pure External Objects */
Free_Cobjects = &Mem_Base[Pure_Objects_Start];
for (; Pure_Objects > 0; Pure_Objects -= 1)
+ {
print_external_object(Free_Cobjects);
+ }
/* Constant External Objects */
print_an_object(*Free_Objects);
}
#endif
+\f
+ /* Primitives */
+
+ if (upgrade_primitives)
+ {
+ Pointer obj;
+ fast Pointer *table;
+ fast long count, datum;
+ for (count = Primitive_Table_Length,
+ table = external_renumber_table;
+ --count >= 0;)
+ {
+ obj = *table++;
+ datum = OBJECT_DATUM(obj);
+ if (OBJECT_TYPE(obj) == TC_PRIMITIVE_EXTERNAL)
+ {
+ Pointer *strobj;
+
+ strobj = ((Pointer *) (external_prim_name_table[datum]));
+ print_a_primitive(((long) UNKNOWN_PRIMITIVE_ARITY),
+ (STRING_LENGTH_TO_LONG(strobj[STRING_LENGTH])),
+ ((char *) &strobj[STRING_CHARS]));
+ }
+ else
+ {
+ char *string;
+
+ string = builtin_prim_name_table[datum];
+ print_a_primitive(((long) builtin_prim_arity_table[datum]),
+ ((long) strlen(string)),
+ string);
+ }
+ }
+ }
+ else
+ {
+ fast Pointer *table;
+ fast long count;
+ long arity;
+
+ for (count = Primitive_Table_Length, table = primitive_table;
+ --count >= 0;)
+ {
+ Sign_Extend(*table, arity);
+ table += 1;
+ print_a_primitive(arity,
+ (STRING_LENGTH_TO_LONG(table[STRING_LENGTH])),
+ ((char *) &table[STRING_CHARS]));
+ table += (1 + Get_Integer(table[STRING_HEADER]));
+ }
+ }
return;
}
\f
char *argv[];
{
Setup_Program(argc, argv, Noptions, Options);
- return;
+ do_it();
+ quit(0);
}
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/bitstr.c,v 9.34 1987/10/09 16:08:51 jinx Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/bitstr.c,v 9.35 1987/11/17 08:07:17 jinx Exp $
Bit string primitives.
Returns an uninitialized bit string of the given length. */
Built_In_Primitive (Prim_bit_string_allocate, 1, "BIT-STRING-ALLOCATE", 0xD1)
+Define_Primitive (Prim_bit_string_allocate, 1, "BIT-STRING-ALLOCATE")
{
Primitive_1_Arg ();
Returns true iff object is a bit string. */
Built_In_Primitive (Prim_bit_string_p, 1, "BIT-STRING?", 0xD3)
+Define_Primitive (Prim_bit_string_p, 1, "BIT-STRING?")
{
Primitive_1_Arg ();
set to zero if the initialization is false, one otherwise. */
Built_In_Primitive (Prim_make_bit_string, 2, "MAKE-BIT-STRING", 0xD2)
+Define_Primitive (Prim_make_bit_string, 2, "MAKE-BIT-STRING")
{
Pointer result;
Primitive_2_Args ();
otherwise fills it with ones. */
Built_In_Primitive (Prim_bit_string_fill_x, 2, "BIT-STRING-FILL!", 0x197)
+Define_Primitive (Prim_bit_string_fill_x, 2, "BIT-STRING-FILL!")
{
Primitive_2_Args ();
Returns the number of bits in BIT-STRING. */
Built_In_Primitive (Prim_bit_string_length, 1, "BIT-STRING-LENGTH", 0xD4)
+Define_Primitive (Prim_bit_string_length, 1, "BIT-STRING-LENGTH")
{
Primitive_1_Arg ();
Returns the boolean value of the indexed bit. */
Built_In_Primitive (Prim_bit_string_ref, 2, "BIT-STRING-REF", 0xD5)
+Define_Primitive (Prim_bit_string_ref, 2, "BIT-STRING-REF")
{
ref_initialization ();
as a boolean. */
Built_In_Primitive (Prim_bit_string_clear_x, 2, "BIT-STRING-CLEAR!", 0xD8)
+Define_Primitive (Prim_bit_string_clear_x, 2, "BIT-STRING-CLEAR!")
{
ref_initialization ();
as a boolean. */
Built_In_Primitive (Prim_bit_string_set_x, 2, "BIT-STRING-SET!", 0xD7)
+Define_Primitive (Prim_bit_string_set_x, 2, "BIT-STRING-SET!")
{
ref_initialization ();
Returns true the argument has no "set" bits. */
Built_In_Primitive (Prim_bit_string_zero_p, 1, "BIT-STRING-ZERO?", 0xD9)
+Define_Primitive (Prim_bit_string_zero_p, 1, "BIT-STRING-ZERO?")
{
fast Pointer *scan;
fast long i;
Returns true iff the two bit strings contain the same bits. */
Built_In_Primitive (Prim_bit_string_equal_p, 2, "BIT-STRING=?", 0x19D)
+Define_Primitive (Prim_bit_string_equal_p, 2, "BIT-STRING=?")
{
long length;
Primitive_2_Args ();
#define bit_string_xor_x_action() ^=
Built_In_Primitive( Prim_bit_string_move_x, 2, "BIT-STRING-MOVE!", 0x198)
+Define_Primitive( Prim_bit_string_move_x, 2, "BIT-STRING-MOVE!")
bitwise_op( bit_string_move_x_action)
Built_In_Primitive( Prim_bit_string_movec_x, 2, "BIT-STRING-MOVEC!", 0x199)
+Define_Primitive( Prim_bit_string_movec_x, 2, "BIT-STRING-MOVEC!")
bitwise_op( bit_string_movec_x_action)
Built_In_Primitive( Prim_bit_string_or_x, 2, "BIT-STRING-OR!", 0x19A)
+Define_Primitive( Prim_bit_string_or_x, 2, "BIT-STRING-OR!")
bitwise_op( bit_string_or_x_action)
Built_In_Primitive( Prim_bit_string_and_x, 2, "BIT-STRING-AND!", 0x19B)
+Define_Primitive( Prim_bit_string_and_x, 2, "BIT-STRING-AND!")
bitwise_op( bit_string_and_x_action)
Built_In_Primitive( Prim_bit_string_andc_x, 2, "BIT-STRING-ANDC!", 0x19C)
+Define_Primitive( Prim_bit_string_andc_x, 2, "BIT-STRING-ANDC!")
bitwise_op( bit_string_andc_x_action)
Built_In_Primitive( Prim_bit_string_xor_x, 2, "BIT-STRING-XOR!", 0x18F)
+Define_Primitive( Prim_bit_string_xor_x, 2, "BIT-STRING-XOR!")
bitwise_op( bit_string_xor_x_action)
\f
/* (BIT-SUBSTRING-MOVE-RIGHT! source start1 end1 destination start2)
Built_In_Primitive( Prim_bit_substring_move_right_x, 5,
"BIT-SUBSTRING-MOVE-RIGHT!", 0xD6)
+Define_Primitive( Prim_bit_substring_move_right_x, 5,
+ "BIT-SUBSTRING-MOVE-RIGHT!")
{
long start1, end1, start2, end2, nbits;
long end1_mod, end2_mod;
Built_In_Primitive( Prim_unsigned_to_bit_string, 2,
"UNSIGNED-INTEGER->BIT-STRING", 0xDC)
+Define_Primitive( Prim_unsigned_to_bit_string, 2,
+ "UNSIGNED-INTEGER->BIT-STRING")
{
long length;
Primitive_2_Args ();
Built_In_Primitive( Prim_bit_string_to_unsigned, 1,
"BIT-STRING->UNSIGNED-INTEGER", 0xDD)
+Define_Primitive( Prim_bit_string_to_unsigned, 1,
+ "BIT-STRING->UNSIGNED-INTEGER")
{
fast Pointer *scan;
long nwords, nbits, word;
into BIT-STRING. */
Built_In_Primitive (Prim_read_bits_x, 3, "READ-BITS!", 0xDF)
+Define_Primitive (Prim_read_bits_x, 3, "READ-BITS!")
{
read_bits_initialize();
(POINTER,OFFSET). */
Built_In_Primitive (Prim_write_bits_x, 3, "WRITE-BITS!", 0xE0)
+Define_Primitive (Prim_write_bits_x, 3, "WRITE-BITS!")
{
read_bits_initialize();
\f
Built_In_Primitive (Prim_bitstr_find_next_set_bit, 3,
"BIT-SUBSTRING-FIND-NEXT-SET-BIT", 0xDA)
+Define_Primitive (Prim_bitstr_find_next_set_bit, 3,
+ "BIT-SUBSTRING-FIND-NEXT-SET-BIT")
{
substring_find_next_initialize ();
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/boot.c,v 9.39 1987/10/09 16:09:14 jinx Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/boot.c,v 9.40 1987/11/17 08:07:35 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
/* Setup registers */
- IntEnb = INT_Mask;
- IntCode = 0;
+ INITIALIZE_INTERRUPTS();
Env = Make_Non_Pointer(GLOBAL_ENV, 0);
Trapping = false;
Return_Hook_Address = NULL;
/*NOTREACHED*/
}
\f
-/*VARARGS1*/
term_type
-Microcode_Termination(Err, Micro_Error)
- long Err, Micro_Error;
+Microcode_Termination(code)
+ long code;
{
- long value;
+ extern char *Term_Messages[];
Pointer Term_Vector;
+ long value;
- value = 1;
- if ((Err != TERM_HALT) &&
+ if ((code != TERM_HALT) &&
(Valid_Fixed_Obj_Vector()) &&
(Type_Code(Term_Vector =
Get_Fixed_Obj_Slot(Termination_Proc_Vector)) ==
TC_VECTOR) &&
- (Vector_Length(Term_Vector) > Err))
+ (Vector_Length(Term_Vector) > code))
{
+ extern long death_blow;
Pointer Handler;
- Handler = User_Vector_Ref(Term_Vector, Err);
+ Handler = User_Vector_Ref(Term_Vector, code);
if (Handler != NIL)
{
Will_Push(CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS +
- ((Err == TERM_NO_ERROR_HANDLER) ? 5 : 4));
+ ((code == TERM_NO_ERROR_HANDLER) ? 5 : 4));
Store_Return(RC_HALT);
- Store_Expression(Make_Unsigned_Fixnum(Err));
+ Store_Expression(Make_Unsigned_Fixnum(code));
Save_Cont();
- if (Err == TERM_NO_ERROR_HANDLER)
- Push(Make_Unsigned_Fixnum(Micro_Error));
+ if (code == TERM_NO_ERROR_HANDLER)
+ {
+ Push(MAKE_UNSIGNED_FIXNUM(death_blow));
+ }
Push(Val); /* Arg 3 */
Push(Fetch_Env()); /* Arg 2 */
Push(Fetch_Expression()); /* Arg 1 */
Push(Handler); /* The handler function */
- Push(STACK_FRAME_HEADER + ((Err==TERM_NO_ERROR_HANDLER) ? 4 : 3));
+ Push(STACK_FRAME_HEADER + ((code == TERM_NO_ERROR_HANDLER) ? 4 : 3));
Pushed();
longjmp(*Back_To_Eval, PRIM_NO_TRAP_APPLY);
}
}
+ putchar('\n');
+ if ((code < 0) || (code > MAX_ERROR))
+ {
+ printf("Unknown termination code 0x%x\n", code);
+ }
+ else
+ {
+ printf("%s.\n", Term_Messages[code]);
+ }
+
/* Microcode_Termination continues on the next page */
\f
/* Microcode_Termination, continued */
- putchar ('\n');
- switch(Err)
- { case TERM_BAD_PRIMITIVE:
- printf("Bad primitive invoked.");
- break;
- case TERM_BAD_PRIMITIVE_DURING_ERROR:
- printf("Error during unknown primitive.");
- break;
- case TERM_BAD_ROOT:
- printf("Band file isn't a control point.");
- break;
- case TERM_BAD_STACK:
- printf("Control stack messed up.");
- break;
- case TERM_BROKEN_HEART:
- printf("Broken heart encountered.");
- break;
- case TERM_COMPILER_DEATH:
- printf("Mismatch between compiled code and compiled code support.");
- break;
- case TERM_DISK_RESTORE:
- printf("Unrecoverable error while loading a band.");
- break;
- case TERM_EOF:
- printf("End of input stream reached.");
+ switch(code)
+ {
+ case TERM_HALT:
+ value = 0;
break;
+
case TERM_END_OF_COMPUTATION:
- Print_Expression(Val, "End of computation; final result");
- break;
- case TERM_EXIT:
- printf("Inconsistency detected.");
+ Print_Expression(Val, "Final result");
+ putchar('\n');
+ 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("Out of space after GC. Needed %d, have %d",
+ printf("Memory: required = %d; available = %d\n",
Get_Integer(Fetch_Expression()), Space_Before_GC());
- break;
- case TERM_HALT:
- printf("Moriturus te saluto.");
- value = 0;
- break;
- case TERM_INVALID_TYPE_CODE:
- printf("Bad Type: check GC_Type map.");
- break;
-\f
+ goto normal_termination;
+
case TERM_NO_ERROR_HANDLER:
- printf("No handler for error code: %d", Micro_Error);
- break;
- case TERM_NO_INTERRUPT_HANDLER:
- printf("No interrupt handler.");
- break;
- case TERM_NON_EXISTENT_CONTINUATION:
- printf("No such return code 0x%08x.", Fetch_Return());
- break;
- case TERM_NON_POINTER_RELOCATION:
- printf("Non pointer relocation!?");
- break;
- case TERM_STACK_ALLOCATION_FAILED:
- printf("No space for stack!?");
- break;
- case TERM_STACK_OVERFLOW:
- printf("Recursion depth exceeded.");
- break;
- case TERM_TERM_HANDLER:
- printf("Termination handler returned.");
- break;
- case TERM_UNIMPLEMENTED_CONTINUATION:
- printf("Return code not implemented.");
- break;
- case TERM_NO_SPACE:
- printf("Not enough memory.");
- break;
- case TERM_SIGNAL:
- printf("Unhandled signal received.");
+ /* 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;
+
default:
- printf("Termination code 0x%x.", Err);
- }
- putchar ('\n');
- if ((Trace_On_Error) && (Err != TERM_HALT))
- {
- printf( "\n\nStack trace:\n\n");
- Back_Trace();
+ normal_termination:
+ value = 1;
+ if (Trace_On_Error)
+ {
+ printf("\n\n**** Stack trace ****\n\n");
+ Back_Trace(stdout);
+ }
+ break;
}
OS_Flush_Output_Buffer();
OS_Quit();
Reset_Memory();
Exit_Hook();
Exit_Scheme(value);
+ /*NOTREACHED*/
}
\f
/* Utility primitives. */
#define ID_OS_VARIANT 9 /* OS variant (string) */
Built_In_Primitive (Prim_Microcode_Identify, 0, "MICROCODE-IDENTIFY", 0xE5)
+Define_Primitive (Prim_Microcode_Identify, 0, "MICROCODE-IDENTIFY")
{
Pointer *Result;
long i;
= (C_String_To_Scheme_String (OS_Name));
Result[(ID_OS_VARIANT + VECTOR_DATA)]
= (C_String_To_Scheme_String (OS_Variant));
- return (Make_Pointer (TC_VECTOR, Result));
+ PRIMITIVE_RETURN(Make_Pointer (TC_VECTOR, Result));
}
\f
Built_In_Primitive(Prim_Microcode_Tables_Filename,
0, "MICROCODE-TABLES-FILENAME", 0x180)
+Define_Primitive(Prim_Microcode_Tables_Filename,
+ 0, "MICROCODE-TABLES-FILENAME")
{
fast char *From, *To;
char *Prefix, *Suffix;
}
*To = '\0';
Free += STRING_CHARS + ((Count + sizeof(Pointer)) / sizeof(Pointer));
- Vector_Set(Result, STRING_LENGTH, Make_Unsigned_Fixnum(Count));
+ Vector_Set(Result, STRING_LENGTH, ((Pointer) Count));
Vector_Set(Result, STRING_HEADER,
Make_Non_Pointer(TC_MANIFEST_NM_VECTOR,
((Free - Get_Pointer(Result)) - 1)));
- return Result;
+ PRIMITIVE_RETURN(Result);
}
\f
Built_In_Primitive(Prim_Get_Command_Line, 0, "GET-COMMAND-LINE", 0x25)
+Define_Primitive(Prim_Get_Command_Line, 0, "GET-COMMAND-LINE")
{
fast int i;
Pointer result;
{
User_Vector_Set(result, i, C_String_To_Scheme_String(Saved_argv[i]));
}
- return result;
+ PRIMITIVE_RETURN(result);
}
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/char.c,v 9.22 1987/05/14 13:47:45 cph Rel $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/char.c,v 9.23 1987/11/17 08:07:53 jinx Exp $ */
/* Character primitives. */
}
\f
Built_In_Primitive (Prim_Make_Char, 2, "MAKE-CHAR", 0x14)
+Define_Primitive (Prim_Make_Char, 2, "MAKE-CHAR")
{
long bucky_bits, code;
Primitive_2_Args ();
}
Built_In_Primitive (Prim_Char_Bits, 1, "CHAR-BITS", 0x15)
+Define_Primitive (Prim_Char_Bits, 1, "CHAR-BITS")
{
Primitive_1_Arg ();
}
Built_In_Primitive (Prim_Char_Code, 1, "CHAR-CODE", 0x17)
+Define_Primitive (Prim_Char_Code, 1, "CHAR-CODE")
{
Primitive_1_Arg ();
}
Built_In_Primitive (Prim_Char_To_Integer, 1, "CHAR->INTEGER", 0x1B)
+Define_Primitive (Prim_Char_To_Integer, 1, "CHAR->INTEGER")
{
Primitive_1_Arg ();
}
Built_In_Primitive (Prim_Integer_To_Char, 1, "INTEGER->CHAR", 0x34)
+Define_Primitive (Prim_Integer_To_Char, 1, "INTEGER->CHAR")
{
Primitive_1_Arg ();
}
Built_In_Primitive (Prim_Char_Downcase, 1, "CHAR-DOWNCASE", 0x35)
+Define_Primitive (Prim_Char_Downcase, 1, "CHAR-DOWNCASE")
{
Primitive_1_Arg ();
}
Built_In_Primitive (Prim_Char_Upcase, 1, "CHAR-UPCASE", 0x36)
+Define_Primitive (Prim_Char_Upcase, 1, "CHAR-UPCASE")
{
Primitive_1_Arg ();
}
Built_In_Primitive (Prim_Ascii_To_Char, 1, "ASCII->CHAR", 0x37)
+Define_Primitive (Prim_Ascii_To_Char, 1, "ASCII->CHAR")
{
Primitive_1_Arg ();
}
Built_In_Primitive (Prim_Char_To_Ascii, 1, "CHAR->ASCII", 0x39)
+Define_Primitive (Prim_Char_To_Ascii, 1, "CHAR->ASCII")
{
Primitive_1_Arg ();
}
Built_In_Primitive (Prim_Char_Ascii_P, 1, "CHAR-ASCII?", 0x38)
+Define_Primitive (Prim_Char_Ascii_P, 1, "CHAR-ASCII?")
{
long ascii;
Primitive_1_Arg ();
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/comutl.c,v 1.8 1987/07/30 14:59:49 jinx Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/comutl.c,v 1.9 1987/11/17 08:08:27 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
\f
Built_In_Primitive (Prim_comp_code_address_block, 1,
"COMPILED-CODE-ADDRESS->BLOCK", 0xB5)
+Define_Primitive (Prim_comp_code_address_block, 1,
+ "COMPILED-CODE-ADDRESS->BLOCK")
{
Pointer *address;
Primitive_1_Arg ();
Built_In_Primitive (Prim_comp_code_address_offset, 1,
"COMPILED-CODE-ADDRESS->OFFSET", 0xAC)
+Define_Primitive (Prim_comp_code_address_offset, 1,
+ "COMPILED-CODE-ADDRESS->OFFSET")
{
long offset;
Primitive_1_Arg ();
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.24 1987/04/16 02:20:20 jinx Rel $
+/* $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 $
*
* Named constants used throughout the interpreter
*
#define PRIM_NO_TRAP_EVAL -5
#define PRIM_NO_TRAP_APPLY -6
#define PRIM_POP_RETURN -7
-\f
-/* Interrupt bits -- scanned from LSB (1) to MSB (16) */
-
-#define INT_Stack_Overflow 1 /* Local interrupt */
-#define INT_Global_GC 2
-#define INT_GC 4 /* Local interrupt */
-#define INT_Global_1 8
-#define INT_Character 16 /* Local interrupt */
-#define INT_Global_2 32
-#define INT_Timer 64 /* Local interrupt */
-#define INT_Global_3 128
-#define INT_Global_Mask \
- (INT_Global_GC | INT_Global_1 | INT_Global_2 | INT_Global_3)
-#define Global_GC_Level 1
-#define Global_1_Level 3
-#define Global_2_Level 5
-#define Global_3_Level 7
-#define MAX_INTERRUPT_NUMBER 7
-
-#define INT_Mask ((1<<(MAX_INTERRUPT_NUMBER+1))-1)
+/* Some numbers of parameters which mean something special */
+
+#define LEXPR_PRIMITIVE_ARITY -1
+#define UNKNOWN_PRIMITIVE_ARITY -2
+\f
/* Error case detection for precomputed constants */
/* VMS preprocessor does not like line continuations in conditionals */
#define REGBLOCK_TEMP 4
#define REGBLOCK_EXPR 5
#define REGBLOCK_RETURN 6
-#define REGBLOCK_MINIMUM_LENGTH 7
+#define REGBLOCK_LEXPR_ACTUALS 7
+#define REGBLOCK_MINIMUM_LENGTH 8
\f
/* Codes specifying how to start scheme at boot time. */
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/daemon.c,v 9.24 1987/04/16 02:20:30 jinx Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/daemon.c,v 9.25 1987/11/17 08:08:45 jinx Rel $
This file contains code for the Garbage Collection daemons.
There are currently two daemons, one for closing files which
*/
Built_In_Primitive(Prim_Close_Lost_Open_Files, 1, "CLOSE-LOST-OPEN-FILES", 0xC7)
+Define_Primitive(Prim_Close_Lost_Open_Files, 1, "CLOSE-LOST-OPEN-FILES")
{
extern Boolean OS_file_close();
fast Pointer *Smash, Cell, Weak_Cell, Value;
*/
Built_In_Primitive(Prim_Rehash, 2, "REHASH", 0x5C)
+Define_Primitive(Prim_Rehash, 2, "REHASH")
{
long table_size, counter;
Pointer *bucket;
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.25 1987/10/05 18:31:47 jinx Rel $
+/* $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 $
*
* Utilities to help with debugging
*/
goto SPrint;
case TC_CHARACTER_STRING:
- { long Length, i;
+ {
+ long Length, i;
char *Next, This;
+
printf("\"");
- Length = Get_Integer(Vector_Ref(Expr, STRING_LENGTH));
+ Length = ((long) (Vector_Ref(Expr, STRING_LENGTH)));
Next = (char *) Nth_Vector_Loc(Expr, STRING_CHARS);
for (i=0; i < Length; i++)
{ This = *Next++;
Return_After_Print = true;
SPrint:
Name = Vector_Ref(Expr, SYMBOL_NAME);
- Length = Get_Integer(Vector_Ref(Name, STRING_LENGTH));
+ Length = ((long) (Vector_Ref(Name, STRING_LENGTH)));
Next_Char = (char *) Nth_Vector_Loc(Name, STRING_CHARS);
for (i=0; i < Length; i++)
printf("%c", *Next_Char++);
case TC_LAMBDA:
if (Detailed)
+ {
printf("[LAMBDA (");
+ }
Do_Printing(Vector_Ref(Vector_Ref(Expr, LAMBDA_FORMALS), 1),
false);
if (Detailed)
+ {
printf(") 0x%x]", Temp_Address);
+ }
return;
case TC_LEXPR: printf("[LEXPR"); break;
case TC_PRIMITIVE:
printf("[PRIMITIVE "); Prt_PName(Temp_Address);
printf("]"); return;
- case TC_PRIMITIVE_EXTERNAL: printf("[PRIMITIVE_EXTERNAL"); break;
case TC_PROCEDURE:
- if (Detailed) printf("[PROCEDURE (");
+ if (Detailed)
+ {
+ printf("[PROCEDURE (");
+ }
Do_Printing(Vector_Ref(Expr, PROCEDURE_LAMBDA_EXPR), false);
- if (Detailed) printf(") 0x%x]", Temp_Address);
+ if (Detailed)
+ {
+ printf(") 0x%x]", Temp_Address);
+ }
return;
/* Do_Printing continues on the next page */
if ((Datum(Temp) == RC_END_OF_COMPUTATION) ||
(Datum(Temp) == RC_HALT)) return true;
if (Datum(Temp) == RC_JOIN_STACKLETS)
+ {
Stack_Pointer = Previous_Stack_Pointer(Expr);
- return false;
+ }
+ return (false);
}
\f
/* Back_Trace relies on (a) only a call to Save_Cont puts a return code on the
- stack; (b) Save_Cont pushes the expression first. */
+ stack; (b) Save_Cont pushes the expression first.
+
+ NOTE: currently Back_Trace ignores where and always
+ prints on stdout. This should eventually be fixed.
+ */
void
-Back_Trace()
+Back_Trace(where)
+ FILE *where;
{
Pointer Temp, *Old_Stack;
Back_Trace_Entry_Hook();
Old_Stack = Stack_Pointer;
while (true)
- { if (Return_Hook_Address == &Top_Of_Stack())
- { Temp = Pop();
+ {
+ if (Return_Hook_Address == &Top_Of_Stack())
+ {
+ Temp = Pop();
if (Temp != Make_Non_Pointer(TC_RETURN_CODE, RC_RETURN_TRAP_POINT))
+ {
printf("\n--> Return trap is missing here <--\n");
+ }
else
- { printf("\n[Return trap found here as expected]\n");
+ {
+ printf("\n[Return trap found here as expected]\n");
Temp = Old_Return_Code;
}
}
- else Temp = Pop();
+ else
+ {
+ Temp = Pop();
+ }
if (Type_Code(Temp) == TC_RETURN_CODE)
- { if (Print_One_Continuation_Frame(Temp))
+ {
+ if (Print_One_Continuation_Frame(Temp))
+ {
break;
+ }
}
else
- { Print_Expression(Temp, " ...");
+ {
+ Print_Expression(Temp, " ...");
if (Type_Code(Temp) == TC_MANIFEST_NM_VECTOR)
- { Stack_Pointer = Simulate_Popping(Get_Integer(Temp));
+ {
+ Stack_Pointer = Simulate_Popping(Get_Integer(Temp));
printf(" (skipping)");
}
printf("\n");
}
Stack_Pointer = Old_Stack;
Back_Trace_Exit_Hook();
+ return;
}
-
+\f
void
Print_Stack(SP)
Pointer *SP;
Saved_SP = Stack_Pointer;
Stack_Pointer = SP;
- Back_Trace();
+ Back_Trace(stdout);
Stack_Pointer = Saved_SP;
return;
}
interpreter.
*/
Built_In_Primitive(Prim_Temp_Printer, 1, "DEBUGGING-PRINTER", 0xB2)
+Define_Primitive(Prim_Temp_Printer, 1, "DEBUGGING-PRINTER")
{
Primitive_1_Arg();
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/dump.c,v 9.24 1987/06/05 04:13:39 jinx Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/dump.c,v 9.25 1987/11/17 08:09:10 jinx Rel $
*
* This file contains common code for dumping internal format binary files.
*/
\f
-#include "fasl.h"
-
void
-prepare_dump_header(Buffer, Heap_Count, Heap_Relocation, Dumped_Object,
- Constant_Count, Constant_Relocation, Prim_Exts)
- Pointer *Buffer, *Heap_Relocation, *Dumped_Object,
- *Constant_Relocation, *Prim_Exts;
- long Heap_Count, Constant_Count;
+prepare_dump_header(Buffer, Dumped_Object,
+ Heap_Count, Heap_Relocation,
+ Constant_Count, Constant_Relocation,
+ table_length, table_size)
+ Pointer
+ *Buffer, *Dumped_Object,
+ *Heap_Relocation, *Constant_Relocation;
+ long
+ Heap_Count, Constant_Count,
+ table_length, table_size;
{
long i;
#else
Make_Pointer(TC_BROKEN_HEART, Stack_Top);
#endif
- Buffer[FASL_Offset_Ext_Loc] =
- Make_Pointer(TC_BROKEN_HEART, Prim_Exts);
+ Buffer[FASL_Offset_Prim_Length] =
+ Make_Pointer(TC_BROKEN_HEART, table_length);
+ Buffer[FASL_Offset_Prim_Size] =
+ Make_Pointer(TC_BROKEN_HEART, table_size);
for (i = FASL_Offset_First_Free; i < FASL_HEADER_LENGTH; i++)
+ {
Buffer[i] = NIL;
+ }
return;
}
Boolean
-Write_File(Heap_Count, Heap_Relocation, Dumped_Object,
- Constant_Count, Constant_Relocation, Prim_Exts)
- Pointer *Heap_Relocation, *Dumped_Object,
- *Constant_Relocation, *Prim_Exts;
- long Heap_Count, Constant_Count;
+Write_File(Dumped_Object, Heap_Count, Heap_Relocation,
+ Constant_Count, Constant_Relocation,
+ table_start, table_length, table_size)
+ Pointer
+ *Dumped_Object,
+ *Heap_Relocation, *Constant_Relocation,
+ *table_start;
+ long
+ Heap_Count, Constant_Count,
+ table_length, table_size;
{
Pointer Buffer[FASL_HEADER_LENGTH];
- prepare_dump_header(Buffer,Heap_Count, Heap_Relocation, Dumped_Object,
- Constant_Count, Constant_Relocation, Prim_Exts);
+ prepare_dump_header(Buffer, Dumped_Object,
+ Heap_Count, Heap_Relocation,
+ Constant_Count, Constant_Relocation,
+ table_length, table_size);
if (Write_Data(FASL_HEADER_LENGTH, ((char *) Buffer)) !=
FASL_HEADER_LENGTH)
- return false;
+ {
+ return (false);
+ }
if (Heap_Count != 0)
{
if (Write_Data(Heap_Count, ((char *) Heap_Relocation)) !=
Heap_Count)
- return false;
+ {
+ return (false);
+ }
}
if (Constant_Count != 0)
{
if (Write_Data(Constant_Count, ((char *) Constant_Relocation)) !=
Constant_Count)
- return false;
+ {
+ return (false);
+ }
+ }
+ if (table_size != 0)
+ {
+ if (Write_Data(table_size, ((char *) table_start)) != table_size)
+ {
+ return (false);
+ }
}
- return true;
+ return (true);
}
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.25 1987/10/05 18:32:03 jinx Rel $
+/* $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 $
*
- * Error and termination code declarations. This must correspond
- * to UTABMD.SCM
+ * Error and termination code declarations.
*
*/
\f
#define ERR_UNIMPLEMENTED_PRIMITIVE 0x33
#define ERR_ILLEGAL_REFERENCE_TRAP 0x34
#define ERR_BROKEN_VARIABLE_CACHE 0x35
+#define ERR_WRONG_ARITY_PRIMITIVES 0x36
+#define ERR_IO_ERROR 0x37
-#define MAX_ERROR 0x35
+/*
+ If you add any error codes here, remember to add them to
+ storage.c and utabmd.scm as well.
+ */
+
+#define MAX_ERROR 0x37
\f
/* Termination codes: the interpreter halts on these */
#define TERM_GC_OUT_OF_SPACE 0x14
#define TERM_NO_SPACE 0x15
#define TERM_SIGNAL 0x16
+
+/*
+ If you add any termination codes here, remember to add them to
+ storage.c as well.
+ */
+
+#define MAX_TERMINATION 0x16
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.22 1987/04/16 02:21:18 jinx Rel $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/extern.c,v 9.23 1987/11/17 08:09:28 jinx Exp $ */
#include "scheme.h"
#include "primitive.h"
\f
-/* (GET-EXTERNAL-COUNTS)
- Returns a CONS of the number of external primitives defined in this
- interpreter and the number of external primitives referenced but
- not defined.
+/* Mapping between the internal and external representations of
+ 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.
+*/
+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")
+{
+ long Code, Offset;
+ Primitive_2_Args();
+
+ Arg_1_Type(TC_FIXNUM);
+ Arg_2_Type(TC_FIXNUM);
+ Code = Get_Integer(Arg1);
+ Offset = Get_Integer(Arg2);
+ switch (Code)
+ {
+ case TC_RETURN_CODE:
+ if (Offset > 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);
+ }
+ break;
+
+ default: Primitive_Error(ERR_ARG_1_BAD_RANGE);
+ }
+ return (Make_Non_Pointer(Code, Offset));
+}
+\f
+/* (MAP-MACHINE-ADDRESS-TO-CODE TYPE-CODE ADDRESS)
+ This is the inverse operation for MAP_CODE_TO_ADDRESS.
+ Given a machine ADDRESS and a TYPE-CODE (either return code or
+ 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")
+{
+ long Code, Offset;
+ Primitive_2_Args();
+
+ Arg_1_Type(TC_FIXNUM);
+ Code = Get_Integer(Arg1);
+ Arg_2_Type(Code);
+ Offset = Get_Integer(Arg2);
+ switch (Code)
+ { case TC_RETURN_CODE:
+ if (Offset > 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);
+ }
+ break;
+
+ default:
+ Primitive_Error(ERR_ARG_1_BAD_RANGE);
+ }
+ return (MAKE_UNSIGNED_FIXNUM(Offset));
+}
+\f
+/* (PRIMITIVE-PROCEDURE-ARITY INTERNAL-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")
+{
+ extern long primitive_to_arity();
+ long Prim_Num, answer;
+ Primitive_1_Arg();
+
+ Arg_1_Type(TC_PRIMITIVE);
+ Prim_Num = Get_Integer(Arg1);
+
+ if (Prim_Num >= NUMBER_OF_PRIMITIVES())
+ {
+ Primitive_Error(ERR_ARG_1_BAD_RANGE);
+ }
+ answer = primitive_to_arity(Prim_Num);
+ return (MAKE_SIGNED_FIXNUM(answer));
+}
+\f
+/* (GET-PRIMITIVE-COUNTS)
+ Returns a CONS of the number of primitives defined in this
+ interpreter and the number of primitives referenced but not
+ defined.
*/
-Built_In_Primitive(Prim_Get_External_Count, 0, "GET-EXTERNAL-COUNTS", 0x101)
+Built_In_Primitive(Prim_Get_Primitive_Counts, 0, "GET-PRIMITIVE-COUNTS", 0x101)
+Define_Primitive(Prim_Get_Primitive_Counts, 0, "GET-PRIMITIVE-COUNTS")
{
Primitive_0_Args();
- *Free++ = Make_Unsigned_Fixnum(MAX_EXTERNAL_PRIMITIVE + 1);
- *Free++ = Make_Unsigned_Fixnum(NUndefined());
- return Make_Pointer(TC_LIST, Free - 2);
+ *Free++ = MAKE_UNSIGNED_FIXNUM(NUMBER_OF_DEFINED_PRIMITIVES());
+ *Free++ = MAKE_UNSIGNED_FIXNUM(NUMBER_OF_UNDEFINED_PRIMITIVES());
+ PRIMITIVE_RETURN(Make_Pointer(TC_LIST, Free - 2));
}
\f
-/* (GET-EXTERNAL-NAME n)
+/* (GET-PRIMITIVE-NAME n)
Given a number, return the string for the name of the corresponding
- external primitive. An error if the number is out of range.
- External primitives start at 0.
+ primitive procedure. It causes an error if the number is out of range.
*/
-Built_In_Primitive(Prim_Get_Ext_Name, 1, "GET-EXTERNAL-NAME", 0x102)
+Built_In_Primitive(Prim_Get_Primitive_Name, 1, "GET-PRIMITIVE-NAME", 0x102)
+Define_Primitive(Prim_Get_Primitive_Name, 1, "GET-PRIMITIVE-NAME")
{
- extern Pointer external_primitive_name();
+ extern Pointer primitive_name();
long Number, TC;
Primitive_1_Arg();
TC = Type_Code(Arg1);
- if ((TC != TC_FIXNUM) && (TC != TC_PRIMITIVE_EXTERNAL))
+ if ((TC != TC_FIXNUM) && (TC != TC_PRIMITIVE))
+ {
Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- Range_Check(Number, Arg1, 0, MAX_EXTERNAL_PRIMITIVE+NUndefined(),
+ }
+ Range_Check(Number, Arg1, 0, (NUMBER_OF_PRIMITIVES() - 1),
ERR_ARG_1_BAD_RANGE);
- if (Number <= MAX_EXTERNAL_PRIMITIVE)
- return external_primitive_name(Number);
- else return User_Vector_Ref(Undefined_Externals,
- (Number - MAX_EXTERNAL_PRIMITIVE));
+ PRIMITIVE_RETURN(primitive_name(Number));
}
\f
-/* (GET-EXTERNAL-NUMBER name intern?)
- Given a symbol (name), return the external primitive object
- corresponding to this name.
- If intern? is true, then an external object is created if one
- didn't exist before.
- If intern? is false, NIL is returned if the primitive is not
+/* (GET-PRIMITIVE-ADDRESS name arity)
+ Given a symbol (name), return the primitive object corresponding
+ to this name.
+ arity is the number of arguments which the primitive should expect.
+ If arity is false, NIL is returned if the primitive is not
implemented even if the name alredy exists.
- Otherwise, NIL is returned if the primitive does not exist and
- the name does not exist either.
+ If arity is an integer, a primitive object will always be returned,
+ whether the corresponding primitive is implemented or not.
*/
-Built_In_Primitive(Prim_Get_Ext_Number, 2, "GET-EXTERNAL-NUMBER", 0x103)
+Built_In_Primitive(Prim_Get_Primitive_Address, 2, "GET-PRIMITIVE-ADDRESS", 0x103)
+Define_Primitive(Prim_Get_Primitive_Address, 2, "GET-PRIMITIVE-ADDRESS")
{
- extern long make_external_primitive();
+ extern Pointer find_primitive();
+ Boolean intern_p, check_p;
+ long arity;
Primitive_2_Args();
Arg_1_Type(TC_INTERNED_SYMBOL);
Touch_In_Primitive(Arg2, Arg2);
- return make_external_primitive(Arg1, Arg2);
+ if (Arg2 == NIL)
+ {
+ check_p = false;
+ intern_p = false;
+ arity = 0;
+ }
+ else
+ {
+ CHECK_ARG(2, FIXNUM_P);
+ check_p = true;
+ intern_p = true;
+ Sign_Extend(Arg2, arity);
+ }
+ PRIMITIVE_RETURN(find_primitive(Fast_Vector_Ref(Arg1, SYMBOL_NAME),
+ intern_p, arity, check_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/extern.h,v 9.27 1987/06/23 22:01:36 cph Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/extern.h,v 9.28 1987/11/17 08:09:39 jinx Exp $
*
* External declarations.
*
extern Declare_Fixed_Objects();
\f
-extern long IntCode, /* Interrupts requesting */
- IntEnb, /* Interrupts enabled */
- GC_Reserve, /* Scheme pointer overflow space in heap */
- GC_Space_Needed, /* Amount of space needed when GC triggered */
- /* Used to signal microcode errors from compiled code. */
- compiled_code_error_code;
-
-/* The lookup routines receive the slot location using these: */
-extern Pointer Lookup_Base;
-extern long Lookup_Offset;
+extern long
+ IntCode, /* Interrupts requesting */
+ IntEnb, /* Interrupts enabled */
+ temp_long, /* temporary for sign extension */
+ GC_Reserve, /* Scheme pointer overflow space in heap */
+ GC_Space_Needed, /* Amount of space needed when GC triggered */
+ /* Used to signal microcode errors from compiled code. */
+ compiled_code_error_code;
extern char *Return_Names[];
extern long 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/fasdump.c,v 9.30 1987/09/21 21:55:35 jinx Rel $
+/* $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 $
This file contains code for fasdump and dump-band.
*/
#include "gccode.h"
#include "trap.h"
#include "lookup.h"
+#include "fasl.h"
#include "dump.c"
-extern Pointer Make_Prim_Exts();
+extern Pointer
+ dump_renumber_primitive(),
+ *initialize_primitive_table(),
+ *cons_primitive_table(),
+ *cons_whole_primitive_table();
\f
/* Some statics used freely in this file */
\f
Switch_by_GC_Type(Temp)
{
- case TC_PRIMITIVE_EXTERNAL:
- case TC_STACK_ENVIRONMENT:
- case_Fasload_Non_Pointer:
+ case TC_PRIMITIVE:
+ case TC_PCOMB0:
+ *Scan = dump_renumber_primitive(*Scan);
break;
case TC_BROKEN_HEART:
Scan += Get_Integer(Temp);
break;
+ case TC_STACK_ENVIRONMENT:
+ case_Fasload_Non_Pointer:
+ break;
+
case_compiled_entry_point:
Dump_Pointer(Fasdump_Setup_Pointer(Transport_Compiled(),
Compiled_BH(false, continue)));
Type_Code(Temp));
Invalid_Type_Code();
- } /* Switch_by_GC_Type */
- } /* For loop */
+ }
+ }
NewFree = To;
Fixup = Fixes;
return true;
-} /* DumpLoop */
-\f
+}
+
Boolean
Fasdump_Exit()
{
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")
{
- Pointer Object, File_Name, Flag, *New_Object,
- *Addr_Of_New_Object, Prim_Exts;
- long Pure_Length, Length;
+ Pointer Object, File_Name, Flag, *New_Object;
+ Pointer *table_start, *table_end;
+ long Pure_Length, Length, table_length;
Boolean result;
Primitive_3_Args();
+ CHECK_ARG (2, STRING_P);
+
Object = Arg1;
File_Name = Arg2;
Flag = Arg3;
- if (Type_Code(File_Name) != TC_CHARACTER_STRING)
- Primitive_Error(ERR_ARG_2_WRONG_TYPE);
+
if (!Open_Dump_File(File_Name, WRITE_FLAG))
+ {
Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ }
#if false
if ((Flag != NIL) && (Flag != TRUTH))
#else
if (Flag != NIL)
-#endif
+#endif /* false */
+ {
Primitive_Error(ERR_ARG_3_WRONG_TYPE);
+ }
+
+ table_end = &Free[Space_Before_GC()];
+ table_start = initialize_primitive_table(Free, table_end);
+ if (table_start >= table_end)
+ {
+ Primitive_GC(table_end - table_start);
+ }
Fasdump_Free_Calc(NewFree, NewMemTop, Orig_New_Free);
Fixup = NewMemTop;
- Prim_Exts = Make_Prim_Exts();
New_Object = NewFree;
*NewFree++ = Object;
- *NewFree++ = Prim_Exts;
\f
#if false
+ /* NOTE: This is wrong!
+
+ Many things will break, among them:
+
+ Symbols will not be interned correctly in the new system.
+
+ The primitive dumping mechanism will break, since
+ dump_renumber_primitive is not being invoked by
+ either phase.
+*/
+
if (Flag == TRUTH)
{
+ Pointer *Addr_Of_New_Object;
+
+ *New_Free++ = NIL;
if (!DumpLoop(New_Object, PURE_COPY))
{
Fasdump_Exit();
PRIMITIVE_RETURN(NIL);
}
- /* Can't align.
- Align_Float(NewFree);
- */
- Pure_Length = (NewFree-New_Object) + 1;
+#if false
+ /* Can't align. */
+ Align_Float(NewFree);
+#endif
+ Pure_Length = ((NewFree - New_Object) + 1);
*NewFree++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
*NewFree++ = Make_Non_Pointer(CONSTANT_PART, Pure_Length);
if (!DumpLoop(New_Object, CONSTANT_COPY))
*NewFree++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
*NewFree++ = Make_Non_Pointer(END_OF_BLOCK, (Length - 1));
Addr_Of_New_Object = Get_Pointer(New_Object[0]);
- Prim_Exts = New_Object[1];
New_Object[0] = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR,
Pure_Length);
New_Object[1] = Make_Non_Pointer(PURE_PART, (Length - 1));
- result = Write_File(0, 0x000000, Addr_Of_New_Object,
- Length, New_Object, Prim_Exts);
+ table_start = NewFree;
+ table_end = cons_primitive_table(NewFree, Fixup, &table_length);
+ if (table_end >= Fixup)
+ {
+ Fasdump_Exit();
+ PRIMITIVE_RETURN(NIL);
+ }
+ result = Write_File(Addr_Of_New_Object, 0, 0,
+ Length, New_Object,
+ table_start, table_length,
+ ((long) (table_end - table_start)));
}
- else /* Dumping for reload into heap */
-#endif
+\f
+ else
+#endif /* Dumping for reload into heap */
{
if (!DumpLoop(New_Object, NORMAL_GC))
{
Fasdump_Exit();
PRIMITIVE_RETURN(NIL);
}
- /* Aligning might screw up some of the counters.
- Align_Float(NewFree);
- */
+#if false
+ /* Aligning might screw up some of the counters. */
+ Align_Float(NewFree);
+#endif
Length = (NewFree - New_Object);
- result = Write_File(Length, New_Object, New_Object,
- 0, Constant_Space, (New_Object + 1));
+ table_start = NewFree;
+ table_end = cons_primitive_table(NewFree, Fixup, &table_length);
+ if (table_end >= Fixup)
+ {
+ Fasdump_Exit();
+ PRIMITIVE_RETURN(NIL);
+ }
+ result = Write_File(New_Object,
+ Length, New_Object,
+ 0, Constant_Space,
+ table_start, table_length,
+ ((long) (table_end - table_start)));
}
- result = (result && Fasdump_Exit());
+
+ /* The and is short-circuit, so it must be done in this order. */
+
+ result = (Fasdump_Exit() && result);
PRIMITIVE_RETURN(result ? TRUTH : NIL);
}
\f
argument of NIL.
*/
Built_In_Primitive(Prim_Band_Dump, 2, "DUMP-BAND", 0xB7)
+Define_Primitive(Prim_Band_Dump, 2, "DUMP-BAND")
{
extern Pointer compiler_utilities;
- Pointer Combination, Ext_Prims;
- long Arg1Type;
+ Pointer Combination, *table_start, *table_end, *saved_free;
+ long Arg1Type, table_length;
Boolean result;
Primitive_2_Args();
Band_Dump_Permitted();
Arg1Type = Type_Code(Arg1);
if ((Arg1Type != TC_CONTROL_POINT) &&
- (Arg1Type != TC_PRIMITIVE) &&
- (Arg1Type != TC_PRIMITIVE_EXTERNAL) &&
- (Arg1Type != TC_EXTENDED_PROCEDURE)) Arg_1_Type(TC_PROCEDURE);
+ (Arg1Type != TC_EXTENDED_PROCEDURE) &&
+ (Arg1Type != TC_PRIMITIVE))
+ {
+ Arg_1_Type(TC_PROCEDURE);
+ }
Arg_2_Type(TC_CHARACTER_STRING);
+
if (!Open_Dump_File(Arg2, WRITE_FLAG))
+ {
Primitive_Error(ERR_ARG_2_BAD_RANGE);
- /* Free cannot be saved around this code since Make_Prim_Exts will
- intern the undefined externals and potentially allocate space.
- */
- Ext_Prims = Make_Prim_Exts();
+ }
+ Primitive_GC_If_Needed(5);
+ saved_free = Free;
Combination = Make_Pointer(TC_COMBINATION_1, Free);
Free[COMB_1_FN] = Arg1;
Free[COMB_1_ARG_1] = NIL;
Free += 2;
*Free++ = Combination;
*Free++ = compiler_utilities;
- *Free = Make_Pointer(TC_LIST, Free-2);
+ *Free = Make_Pointer(TC_LIST, (Free - 2));
Free++; /* Some compilers are TOO clever about this and increment Free
before calculating Free-2! */
- *Free++ = Ext_Prims;
- /* Aligning here confuses some of the counts computed.
- Align_Float(Free);
- */
- result = Write_File(((long) (Free - Heap_Bottom)), Heap_Bottom, (Free - 2),
- ((long) (Free_Constant - Constant_Space)),
- Constant_Space, (Free - 1));
- result = (result && Close_Dump_File());
+ table_start = Free;
+ table_end = cons_whole_primitive_table(Free, Heap_Top, &table_length);
+ if (table_end >= Heap_Top)
+ {
+ result = false;
+ }
+ else
+ {
+#if false
+ /* Aligning here confuses some of the counts computed. */
+ Align_Float(Free);
+#endif
+ result = Write_File((Free - 1),
+ ((long) (Free - Heap_Bottom)), Heap_Bottom,
+ ((long) (Free_Constant - Constant_Space)),
+ Constant_Space,
+ table_start, table_length,
+ ((long) (table_end - table_start)));
+ }
+ /* The and is short-circuit, so it must be done in this order. */
+ result = (Close_Dump_File() && result);
Band_Dump_Exit_Hook();
+ Free = saved_free;
PRIMITIVE_RETURN(result ? TRUTH : 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/fasl.h,v 9.24 1987/06/05 04:14:25 jinx Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasl.h,v 9.25 1987/11/17 08:10:04 jinx Rel $
Contains information relating to the format of FASL files.
Some information is contained in CONFIG.H.
\f
/* FASL Version */
-#define FASL_FILE_MARKER 0XFAFAFAFA
+#define FASL_FILE_MARKER 0xFAFAFAFA
/* The FASL file has a header which begins as follows: */
#define FASL_Offset_Const_Base 5 /* Address of const. area at dump */
#define FASL_Offset_Version 6 /* FASL format version info. */
#define FASL_Offset_Stack_Top 7 /* Top of stack when dumped */
-#define FASL_Offset_Ext_Loc 8 /* Where ext. prims. vector is */
+#define FASL_Offset_Prim_Length 8 /* Number of entries in primitive table */
+#define FASL_Offset_Prim_Size 9 /* Size of primitive table in Pointers */
-#define FASL_Offset_First_Free 9 /* Used to clear header */
+#define FASL_Offset_First_Free 10 /* Used to clear header */
+
+/* Aliases for backwards compatibility. */
+
+/* Where ext. prims. vector is */
+#define FASL_Offset_Ext_Loc FASL_Offset_Prim_Length
/* Version information encoding */
#define FASL_DENSE_TYPES 4
#define FASL_PADDED_STRINGS 5
#define FASL_REFERENCE_TRAP 6
+#define FASL_MERGED_PRIMITIVES 7
-/* Current parameters. */
+/* Current parameters. Always used on output. */
#define FASL_FORMAT_VERSION FASL_FORMAT_ADDED_STACK
-#define FASL_SUBVERSION FASL_REFERENCE_TRAP
-#define FASL_OLDEST_SUPPORTED FASL_PADDED_STRINGS
+#define FASL_SUBVERSION FASL_MERGED_PRIMITIVES
+
+/*
+ The definitions below correspond to the ones above. They usually
+ have the same values. They differ when the format is changing: A
+ system is built which reads the old format, but dumps the new one.
+ */
+
+#define FASL_READ_VERSION FASL_FORMAT_VERSION
+#define FASL_READ_SUBVERSION FASL_SUBVERSION
+
+/* These are for Bintopsb.
+ They are the values of the oldest supported formats.
+ */
+
+#define FASL_OLDEST_VERSION FASL_FORMAT_ADDED_STACK
+#define FASL_OLDEST_SUBVERSION FASL_PADDED_STRINGS
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.30 1987/09/21 21:55:47 jinx Rel $
+/* $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 $
The "fast loader" which reads in and relocates binary files and then
interns symbols. It is called with one argument: the (character
#define CCheck_or_Reloc_Debug Or2(Consistency_Check, Reloc_Debug)
#define Reloc_or_Load_Debug Or2(Reloc_Debug, File_Load_Debug)
+#include "fasl.h"
#include "load.c"
\f
long
read_file_start(name)
Pointer name;
{
+ long heap_length;
Boolean file_opened;
if (Type_Code(name) != TC_CHARACTER_STRING)
- return ERR_ARG_1_WRONG_TYPE;
+ {
+ return (ERR_ARG_1_WRONG_TYPE);
+ }
file_opened = Open_Dump_File(name, OPEN_FLAG);
if (Per_File)
+ {
Handle_Debug_Flags();
+ }
if (!file_opened)
- return ERR_ARG_1_BAD_RANGE;
+ {
+ return (ERR_ARG_1_BAD_RANGE);
+ }
if (!Read_Header())
- goto cannot_load;
+ {
+ Close_Dump_File();
+ return (ERR_FASL_FILE_BAD_DATA);
+ }
if (File_Load_Debug)
+ {
printf("\nMachine type %d, Version %d, Subversion %d\n",
Machine_Type, Version, Sub_Version);
-\f
-#ifdef BYTE_INVERSION
- if ((Sub_Version != FASL_SUBVERSION))
-#else
- if ((Sub_Version != FASL_SUBVERSION) ||
- (Machine_Type != FASL_INTERNAL_FORMAT))
-#endif
-
- {
- fprintf(stderr,
- "\nread_file: FASL File Version %4d Subversion %4d Machine Type %4d.\n",
- Version, Sub_Version , Machine_Type);
- fprintf(stderr,
- " Expected: Version %4d Subversion %4d Machine Type %4d.\n",
- FASL_FORMAT_VERSION, FASL_SUBVERSION, FASL_INTERNAL_FORMAT);
-
-cannot_load:
-
- Close_Dump_File();
- return ERR_FASL_FILE_BAD_DATA;
}
if (!Test_Pure_Space_Top(Free_Constant + Const_Count))
{
Close_Dump_File();
- return ERR_FASL_FILE_TOO_BIG;
+ return (ERR_FASL_FILE_TOO_BIG);
}
- if (GC_Check(Heap_Count))
+ heap_length = Heap_Count + Primitive_Table_Size + Primitive_Table_Length;
+
+ if (GC_Check(heap_length))
{
Close_Dump_File();
- Request_GC(Heap_Count);
- return PRIM_INTERRUPT;
+ Request_GC(heap_length);
+ return (PRIM_INTERRUPT);
}
- return PRIM_DONE;
+ return (PRIM_DONE);
}
\f
-void
+Pointer *
read_file_end()
{
- /* Aligning Free here confuses the counters
- Align_Float(Free);
- */
+ Pointer *table;
+
+#if false
+ /* Aligning Free here confuses the counters. */
+
+ Align_Float(Free);
+#endif
+
if (Load_Data(Heap_Count, ((char *) Free)) != Heap_Count)
{
Close_Dump_File();
- Primitive_Error(ERR_EXTERNAL_RETURN);
+ Primitive_Error(ERR_IO_ERROR);
}
-
-#ifdef BYTE_INVERSION
- Byte_Invert_Region((char *) Free, Heap_Count);
-#endif
-
+ NORMALIZE_REGION(((char *) Free), Heap_Count);
Free += Heap_Count;
+
if (Load_Data(Const_Count, ((char *) Free_Constant)) != Const_Count)
{
Close_Dump_File();
- Primitive_Error(ERR_EXTERNAL_RETURN);
+ Primitive_Error(ERR_IO_ERROR);
}
-
-#ifdef BYTE_INVERSION
- Byte_Invert_Region((char *) Free_Constant, Const_Count);
-#endif
-
+ NORMALIZE_REGION(((char *) Free_Constant), Const_Count);
Free_Constant += Const_Count;
- /* Same
- Align_Float(Free);
- */
+ table = Free;
+ if (Load_Data(Primitive_Table_Size, ((char *) Free)) !=
+ Primitive_Table_Size)
+ {
+ Close_Dump_File();
+ Primitive_Error(ERR_IO_ERROR);
+ }
+ NORMALIZE_REGION(((char *) table), Primitive_Table_Size);
+ Free += Primitive_Table_Size;
+
+#if false
+ /* Same */
+
+ Align_Float(Free);
+#endif
if (Close_Dump_File())
- return;
+ {
+ return (table);
+ }
else
- Primitive_Error(ERR_EXTERNAL_RETURN);
+ {
+ Primitive_Error(ERR_IO_ERROR);
+ }
}
\f
/* Statics used by Relocate, below */
Pointer *Result;
if ((P >= Heap_Base) && (P < Dumped_Heap_Top))
+ {
Result = (Pointer *) (P + Heap_Relocation);
+ }
else if ((P >= Const_Base) && (P < Dumped_Constant_Top))
+ {
Result = (Pointer *) (P + Const_Reloc);
+ }
else if (P < Dumped_Stack_Top)
+ {
Result = (Pointer *) (P + Stack_Relocation);
+ }
else
{
printf("Pointer out of range: 0x%x\n", P, P);
Const_Base, Dumped_Constant_Top, Dumped_Stack_Top);
Warned = true;
}
- Result = (Pointer *) 0;
+ Result = ((Pointer *) 0);
}
if (Reloc_Debug)
+ {
printf("0x%06x -> 0x%06x\n", P, Result);
- return Result;
+ }
+ return (Result);
}
#define Relocate_Into(Loc, P) (Loc) = Relocate(P)
-
-#else
-
-#define Relocate_Into(Loc, P) \
-if ((P) < Const_Base) \
- (Loc) = ((Pointer *) ((P) + Heap_Relocation)); \
-else if ((P) < Dumped_Constant_Top) \
- (Loc) = ((Pointer *) ((P) + Const_Reloc)); \
-else \
- (Loc) = ((Pointer *) ((P) + Stack_Relocation))
+\f
+#else /* not ENABLE_DEBUGGING_TOOLS */
+
+#define Relocate_Into(Loc, P) \
+{ \
+ if ((P) < Const_Base) \
+ { \
+ (Loc) = ((Pointer *) ((P) + Heap_Relocation)); \
+ } \
+ else if ((P) < Dumped_Constant_Top) \
+ { \
+ (Loc) = ((Pointer *) ((P) + Const_Reloc)); \
+ } \
+ else \
+ { \
+ (Loc) = ((Pointer *) ((P) + Stack_Relocation)); \
+ } \
+}
#ifndef Conditional_Bug
+
#define Relocate(P) \
((P < Const_Base) ? \
((Pointer *) (P + Heap_Relocation)) : \
((P < Dumped_Constant_Top) ? \
((Pointer *) (P + Const_Reloc)) : \
((Pointer *) (P + Stack_Relocation))))
-#else
+
+#else /* Conditional_Bug */
+
static Pointer *Relocate_Temp;
+
#define Relocate(P) \
(Relocate_Into(Relocate_Temp, P), Relocate_Temp)
-#endif
-#endif
+
+#endif /* Conditional_Bug */
+#endif /* ENABLE_DEBUGGING_TOOLS */
\f
/* Next_Pointer starts by pointing to the beginning of the block of
memory to be handled. This loop relocates all pointers in the
block of memory.
*/
-long
+void
Relocate_Block(Next_Pointer, Stop_At)
fast Pointer *Next_Pointer, *Stop_At;
{
+ extern Pointer *load_renumber_table;
+
if (Reloc_Debug)
+ {
fprintf(stderr,
"Relocation beginning, block=0x%x, length=0x%x, end=0x%x.\n",
- Next_Pointer, (Stop_At-Next_Pointer)-1, Stop_At);
+ Next_Pointer, (Stop_At - Next_Pointer) - 1, Stop_At);
+ }
while (Next_Pointer < Stop_At)
{
fast Pointer Temp;
Next_Pointer += 1;
break;
- case TC_PRIMITIVE_EXTERNAL:
- Found_Ext_Prims = true;
- Next_Pointer += 1;
+ case TC_PRIMITIVE:
+ *Next_Pointer++ = load_renumber_table[Get_Integer(Temp)];
+ break;
+
+ case TC_PCOMB0:
+ *Next_Pointer++ =
+ Make_Non_Pointer(TC_PCOMB0,
+ load_renumber_table[Get_Integer(Temp)]);
break;
case TC_MANIFEST_NM_VECTOR:
Next_Pointer += Get_Integer(Temp)+1;
break;
-
+\f
#ifdef BYTE_INVERSION
case TC_CHARACTER_STRING:
String_Inversion(Relocate(Datum(Temp)));
- /* THEN FALL THROUGH */
+ goto normal_pointer;
#endif
case TC_REFERENCE_TRAP:
}
/* It is a pointer, fall through. */
- case TC_STACK_ENVIRONMENT:
- case_compiled_entry_point:
/* Compiled entry points and stack environments work automagically. */
-
+ /* This should be more strict. */
default:
{
- fast long Next;
+normal_pointer:
+ {
+ fast long Next;
- Next = Datum(Temp);
- *Next_Pointer++ = Make_Pointer(Type_Code(Temp), Relocate(Next));
+ Next = Datum(Temp);
+ *Next_Pointer++ = Make_Pointer(Type_Code(Temp), Relocate(Next));
+ }
}
}
}
+ return;
}
\f
extern void Intern();
void
Intern_Block(Next_Pointer, Stop_At)
- Pointer *Next_Pointer, *Stop_At;
+ fast Pointer *Next_Pointer, *Stop_At;
{
if (Reloc_Debug)
+ {
printf("Interning a block.\n");
+ }
while (Next_Pointer < Stop_At)
{
switch (Type_Code(*Next_Pointer))
- { case TC_MANIFEST_NM_VECTOR:
- Next_Pointer += Get_Integer(*Next_Pointer)+1;
+ {
+ case TC_MANIFEST_NM_VECTOR:
+ Next_Pointer += (1 + Get_Integer(*Next_Pointer));
break;
case TC_INTERNED_SYMBOL:
- if (Type_Code(Vector_Ref(*Next_Pointer, SYMBOL_GLOBAL_VALUE)) ==
- TC_BROKEN_HEART)
- {
- Pointer Old_Symbol;
-
- Old_Symbol = *Next_Pointer;
- Vector_Set(*Next_Pointer, SYMBOL_GLOBAL_VALUE, UNBOUND_OBJECT);
- Intern(Next_Pointer);
- Primitive_GC_If_Needed(0);
- if (*Next_Pointer != Old_Symbol)
- {
- Vector_Set(Old_Symbol, SYMBOL_NAME,
- Make_New_Pointer(TC_BROKEN_HEART, *Next_Pointer));
- }
- }
- else if (Type_Code(Vector_Ref(*Next_Pointer, SYMBOL_NAME)) ==
- TC_BROKEN_HEART)
- {
- *Next_Pointer =
- Make_New_Pointer(Type_Code(*Next_Pointer),
- Fast_Vector_Ref(*Next_Pointer,
- SYMBOL_NAME));
- }
- Next_Pointer += 1;
- break;
-
- default: Next_Pointer += 1;
- }
- }
- if (Reloc_Debug)
- printf("Done interning block.\n");
- return;
-}
-\f
-/* Install the external primitives vector. This requires changing
- the Ext_Prim_Vector from a vector of symbols (which is what is
- in the FASL file) into a vector of (C format) numbers representing
- the corresponding external primitives numbers for this interpreter.
- If an external primitive is known, then the existing assigned number
- is used. If not, the symbol is added to the list of assigned
- numbers. In the case of a band load (as opposed to a fasload),
- the existing vector of known but unimplemented external primitives
- is ignored and a completely new one will be built.
-*/
-
-void
-Install_Ext_Prims(normal_fasload)
- Boolean normal_fasload;
-{
- long i;
- Pointer *Next;
-
- Vector_Set(Ext_Prim_Vector, 0,
- Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, Ext_Prim_Count));
- Next = Nth_Vector_Loc(Ext_Prim_Vector, 1);
- if (normal_fasload)
- {
- for (i = 0; i < Ext_Prim_Count; i++)
- Intern(Next++);
- }
- else
- Undefined_Externals = NIL;
- return;
-}
-\f
-void
-Update_Ext_Prims(Next_Pointer, Stop_At)
- fast Pointer *Next_Pointer, *Stop_At;
-{
- extern long make_external_primitive();
-
- for ( ; Next_Pointer < Stop_At; Next_Pointer++)
- { switch (Type_Code(*Next_Pointer))
- { case TC_MANIFEST_NM_VECTOR:
- Next_Pointer += Get_Integer(*Next_Pointer);
- break;
-
- case TC_PRIMITIVE_EXTERNAL:
- {
- long Which;
+ if (Type_Code(Vector_Ref(*Next_Pointer, SYMBOL_GLOBAL_VALUE)) ==
+ TC_BROKEN_HEART)
+ {
+ Pointer Old_Symbol;
- Which = Address(*Next_Pointer);
+ Old_Symbol = *Next_Pointer;
+ Vector_Set(*Next_Pointer, SYMBOL_GLOBAL_VALUE, UNBOUND_OBJECT);
- if (Which > Ext_Prim_Count)
- fprintf(stderr, "\nExternal Primitive 0x%x out of range.\n", Which);
- else
- {
- Pointer New_Value;
+ /* This is weird. How come Intern is not checking? */
+ Intern(Next_Pointer);
+ Primitive_GC_If_Needed(0);
- New_Value = User_Vector_Ref(Ext_Prim_Vector, Which);
- if (Type_Code(New_Value) == TC_INTERNED_SYMBOL)
+ if (*Next_Pointer != Old_Symbol)
{
- New_Value = ((Pointer) make_external_primitive(New_Value, TRUTH));
- User_Vector_Set(Ext_Prim_Vector, Which, New_Value);
+ Vector_Set(Old_Symbol, SYMBOL_NAME,
+ Make_New_Pointer(TC_BROKEN_HEART, *Next_Pointer));
}
- Store_Address(*Next_Pointer, New_Value);
}
- }
+ else if (Type_Code(Vector_Ref(*Next_Pointer, SYMBOL_NAME)) ==
+ TC_BROKEN_HEART)
+ {
+ *Next_Pointer =
+ Make_New_Pointer(Type_Code(*Next_Pointer),
+ Fast_Vector_Ref(*Next_Pointer,
+ SYMBOL_NAME));
+ }
+ Next_Pointer += 1;
+ break;
- default: break;
+ default:
+ Next_Pointer += 1;
+ break;
}
}
+ if (Reloc_Debug)
+ {
+ printf("Done interning block.\n");
+ }
return;
}
\f
load_file(from_band_load)
Boolean from_band_load;
{
- Pointer *Heap_End, *Constant_End, *Orig_Heap, *Orig_Constant, *Xtemp;
+ Pointer
+ *Heap_End, *Orig_Heap,
+ *Constant_End, *Orig_Constant,
+ *temp, *primitive_table;
+
+ extern void install_primitive_table();
+ extern Pointer *load_renumber_table;
/* Read File */
Warned = false;
#endif
+ load_renumber_table = Free;
+ Free += Primitive_Table_Length;
Orig_Heap = Free;
Orig_Constant = Free_Constant;
- read_file_end();
- Heap_End = Free;
+ primitive_table = read_file_end();
Constant_End = Free_Constant;
Heap_Relocation = ((relocation_type) Orig_Heap) - Heap_Base;
Const_Reloc = ((relocation_type) Orig_Constant) - Const_Base;
Stack_Relocation = ((relocation_type) Stack_Top) - Dumped_Stack_Top;
+\f
+#ifdef BYTE_INVERSION
+ Setup_For_String_Inversion();
+#endif
+
+ /* Setup the primitive table */
+
+ install_primitive_table(primitive_table,
+ Primitive_Table_Length,
+ from_band_load);
if (Reloc_Debug)
+ {
printf("Heap_relocation = %d = %x; Const_Reloc = %d = %x\n",
Heap_Relocation, Heap_Relocation,
Const_Reloc, Const_Reloc);
+ }
- /* Relocate the new Data */
+ /*
+ Relocate the new data.
-#ifdef BYTE_INVERSION
- Setup_For_String_Inversion();
-#endif
+ There are no pointers in the primitive table, thus
+ there is no need to relocate it.
+ */
- Found_Ext_Prims = false;
- Relocate_Block(Orig_Heap, Free);
+ Relocate_Block(Orig_Heap, primitive_table);
Relocate_Block(Orig_Constant, Free_Constant);
\f
#ifdef BYTE_INVERSION
if (!from_band_load)
{
- Intern_Block(Orig_Constant, Constant_End);
- Intern_Block(Orig_Heap, Heap_End);
- }
+ /* Again, there are no symbols in the primitive table. */
- /* Update External Primitives */
-
- if ((Ext_Prim_Vector != NIL) && Found_Ext_Prims)
- {
- Relocate_Into(Xtemp, Address(Ext_Prim_Vector));
- Ext_Prim_Vector = *Xtemp;
- Ext_Prim_Count = Vector_Length(Ext_Prim_Vector);
- Install_Ext_Prims(!from_band_load);
- Update_Ext_Prims(Orig_Heap, Free);
- Update_Ext_Prims(Orig_Constant, Free_Constant);
+ Intern_Block(Orig_Heap, primitive_table);
+ Intern_Block(Orig_Constant, Constant_End);
}
Set_Pure_Top();
- FASLOAD_RELOCATE_HOOK (Orig_Heap, Free, Orig_Constant, Free_Constant);
- Relocate_Into(Xtemp, Dumped_Object);
- return *Xtemp;
+ FASLOAD_RELOCATE_HOOK (Orig_Heap, primitive_table, Orig_Constant, Free_Constant);
+ Relocate_Into(temp, Dumped_Object);
+ return (*temp);
}
\f
/* (BINARY-FASLOAD FILE-NAME)
definitions in some environment.
*/
Built_In_Primitive(Prim_Binary_Fasload, 1, "BINARY-FASLOAD", 0x57)
+Define_Primitive(Prim_Binary_Fasload, 1, "BINARY-FASLOAD")
{
long result;
Primitive_1_Arg();
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")
{
Primitive_0_Args();
if (reload_band_name == NULL)
+ {
return NIL;
+ }
- return C_String_To_Scheme_String(reload_band_name);
+ return (C_String_To_Scheme_String(reload_band_name));
}
/* Utility for load band below. */
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")
{
extern char *malloc();
extern strcpy(), free();
\f
/* Point of no return. */
- length = Get_Integer(Fast_Vector_Ref(Arg1, STRING_LENGTH));
+ length = ((long) (Fast_Vector_Ref(Arg1, STRING_LENGTH)));
band_name = malloc(length);
if (band_name != ((char *) NULL))
+ {
strcpy(band_name, Scheme_String_To_C_String(Arg1));
+ }
/* There is some jiggery-pokery going on here to make sure
that all returns from Fasload (including error exits) return to
Back_To_Eval = ((jmp_buf *) swapped_buf);
result = load_file(true);
Back_To_Eval = saved_buf;
-
+\f
if (reload_band_name != ((char *) NULL))
+ {
free(reload_band_name);
+ }
reload_band_name = band_name;
History = Make_Dummy_History();
Store_Expression(NIL);
Save_Cont();
Store_Expression(Vector_Ref(result, 0));
-
- /* Primitive externals handled by load_file */
-
compiler_utilities = Vector_Ref(result, 1);
compiler_reset(compiler_utilities);
Store_Env(Make_Non_Pointer(GLOBAL_ENV, GO_TO_GLOBAL));
#define MAGIC_OFFSET (TC_FIXNUM + 1)
Pointer String_Chain, Last_String;
-extern Boolean Byte_Invert_Fasl_Files;
Setup_For_String_Inversion()
{
- if (!Byte_Invert_Fasl_Files)
- return;
String_Chain = NIL;
Last_String = NIL;
+ return;
}
Finish_String_Inversion()
-{ while (String_Chain != NIL)
- { long Count;
- Pointer Next;
+{
- if (!Byte_Invert_Fasl_Files) return;
+ if (Byte_Invert_Fasl_Files)
+ {
+ while (String_Chain != NIL)
+ {
+ long Count;
+ Pointer Next;
- Count = Get_Integer(Fast_Vector_Ref(String_Chain, STRING_HEADER));
- Count = 4*(Count-2)+Type_Code(String_Chain)-MAGIC_OFFSET;
- if (Reloc_Debug)
- printf("String at 0x%x: restoring length of %d.\n",
- Address(String_Chain), Count);
- Next = Fast_Vector_Ref(String_Chain, STRING_LENGTH);
- Fast_Vector_Set(String_Chain, STRING_LENGTH, Make_Unsigned_Fixnum(Count));
- String_Chain = Next;
+ Count = Get_Integer(Fast_Vector_Ref(String_Chain, STRING_HEADER));
+ Count = 4*(Count-2)+Type_Code(String_Chain)-MAGIC_OFFSET;
+ if (Reloc_Debug)
+ {
+ printf("String at 0x%x: restoring length of %d.\n",
+ Address(String_Chain), Count);
+ }
+ Next = Fast_Vector_Ref(String_Chain, STRING_LENGTH);
+ Fast_Vector_Set(String_Chain, STRING_LENGTH, ((Pointer) (Count)));
+ String_Chain = Next;
+ }
}
+ return;
}
\f
#define print_char(C) printf(((C < ' ') || (C > '|')) ? \
"\\%03o" : "%c", (C && MAX_CHAR));
String_Inversion(Orig_Pointer)
-Pointer *Orig_Pointer;
-{ Pointer *Pointer_Address;
+ Pointer *Orig_Pointer;
+{
+ Pointer *Pointer_Address;
char *To_Char;
long Code;
- if (!Byte_Invert_Fasl_Files) return;
+ if (!Byte_Invert_Fasl_Files)
+ {
+ return;
+ }
Code = Type_Code(Orig_Pointer[STRING_LENGTH]);
- if (Code == TC_FIXNUM || Code == 0) /* Already reversed? */
- { long Count, old_size, new_size, i;
+ if (Code == 0) /* Already reversed? */
+ {
+ long Count, old_size, new_size, i;
old_size = Get_Integer(Orig_Pointer[STRING_HEADER]);
new_size =
- 2+(Get_Integer(Orig_Pointer[STRING_LENGTH]))/4;
+ 2 + (((long) (Orig_Pointer[STRING_LENGTH]))) / 4;
if (Reloc_Debug)
+ {
printf("\nString at 0x%x with %d characters",
Orig_Pointer,
- Get_Integer(Orig_Pointer[STRING_LENGTH]));
+ ((long) (Orig_Pointer[STRING_LENGTH])));
+ }
if (old_size != new_size)
- { printf("\nWord count changed from %d to %d: ",
+ {
+ printf("\nWord count changed from %d to %d: ",
old_size , new_size);
printf("\nWhich, of course, is impossible!!\n");
Microcode_Termination(TERM_EXIT);
}
- Count = Get_Integer(Orig_Pointer[STRING_LENGTH])%4;
- if (Count==0) Count = 4;
+ Count = ((long) (Orig_Pointer[STRING_LENGTH])) % 4;
+ if (Count == 0)
+ {
+ Count = 4;
+ }
if (Last_String == NIL)
- String_Chain = Make_Pointer(Count+MAGIC_OFFSET, Orig_Pointer);
- else Fast_Vector_Set(Last_String, STRING_LENGTH,
- Make_Pointer(Count+MAGIC_OFFSET, Orig_Pointer));
+ {
+ String_Chain = Make_Pointer(Count + MAGIC_OFFSET, Orig_Pointer);
+ }
+ else
+ {
+ Fast_Vector_Set(Last_String, STRING_LENGTH,
+ Make_Pointer(Count + MAGIC_OFFSET, Orig_Pointer));
+ }
+\f
Last_String = Make_Pointer(TC_NULL, Orig_Pointer);
Orig_Pointer[STRING_LENGTH] = NIL;
- Count = Get_Integer(Orig_Pointer[STRING_HEADER])-1;
+ Count = Get_Integer(Orig_Pointer[STRING_HEADER]) - 1;
if (Reloc_Debug)
+ {
printf("\nCell count=%d\n", Count);
+ }
Pointer_Address = &(Orig_Pointer[STRING_CHARS]);
To_Char = (char *) Pointer_Address;
- for (i=0; i < Count; i++, Pointer_Address++)
- { int C1, C2, C3, C4;
+ for (i = 0; i < Count; i++, Pointer_Address++)
+ {
+ int C1, C2, C3, C4;
+
C4 = Type_Code(*Pointer_Address) & 0xFF;
C3 = (((long) *Pointer_Address)>>16) & 0xFF;
C2 = (((long) *Pointer_Address)>>8) & 0xFF;
C1 = ((long) *Pointer_Address) & 0xFF;
if (Reloc_Debug || (old_size != new_size))
- { print_char(C1);
+ {
+ print_char(C1);
print_char(C2);
print_char(C3);
print_char(C4);
*To_Char++ = C4;
}
}
- if (Reloc_Debug) printf("\n");
+ if (Reloc_Debug)
+ {
+ printf("\n");
+ }
+ return;
}
#endif /* BYTE_INVERSION */
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.28 1987/10/27 23:13:41 jinx Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/findprim.c,v 9.29 1987/11/17 08:04:01 jinx Exp $
*
* Preprocessor to find and declare defined primitives.
*
/*
* This program searches for a particular token which tags primitive
* definitions. This token is also a macro defined in primitive.h.
- * For each macro invocation it creates an entry in the External
- * Primitives descriptor used by Scheme. The entry consists of the C
+ * For each macro invocation it creates an entry in the primitives
+ * descriptor vector used by Scheme. The entry consists of the C
* routine implementing the primitive, the (fixed) number of arguments
* it requires, and the name Scheme uses to refer to it.
*
* Put the output file in fname. The default is to put it on the
* standard output.
*
- * -b n
- * Produce the built-in primitive table instead. The table should
- * have size n (in hex).
+ * -e or -b n (exclusive)
+ * -e: produce the old external primitive table instead of the
+ * complete primitive table.
+ * -b: Produce the old built-in primitive table instead of the
+ * complete primitive table. The table should have size n (in hex).
+ *
+ * -l fname
+ * The list of files to examine is contained in fname, one file
+ * per line. Semicolons (';') introduce comment lines.
*
* Note that some output lines are done in a strange fashion because
* some C compilers (the vms C compiler, for example) remove comments
static long Built_in_table_size;
static char *The_Token;
+static char Default_Token[] = "Define_Primitive";
static char Built_in_Token[] = "Built_In_Primitive";
static char External_Token[] = "Define_Primitive";
-static char *The_Table;
-static char Built_in_Table[] = "Primitive";
-static char External_Table[] = "External";
+static char *The_Kind;
+static char Default_Kind[] = "Primitive";
+static char Built_in_Kind[] = "Primitive";
+static char External_Kind[] = "External";
static char *The_Variable;
+static char Default_Variable[] = "MAX_PRIMITIVE";
static char Built_in_Variable[] = "MAX_PRIMITIVE";
static char External_Variable[] = "MAX_EXTERNAL_PRIMITIVE";
argv += 2;
argc -= 2;
}
- else
+ else if ((argc >= 2) && (strcmp("-e", argv[1]) == 0))
{
void initialize_external();
initialize_external();
}
+ else
+ {
+ void initialize_default();
+
+ initialize_default();
+ }
\f
/* Check whether there are any files left. */
/* *** FIX *** This should check for field overflow (n too small) */
void
-copy_token(s, cap, Size)
+copy_token(s, size)
char s[];
- boolean cap;
- int *Size;
+ int *size;
{
register int c, n;
n = 0;
while (!(whitespace(c = getc(input))))
- s[n++] = ((cap && isalpha(c) && islower(c))? toupper(c) : c);
+ {
+ s[n++] = c;
+ }
+ s[n] = '\0';
+ if (n > *size)
+ {
+ *size = n;
+ }
+ return;
+}
+\f
+void
+copy_symbol(s, size)
+ char s[];
+ int *size;
+{
+ register int c, n;
+
+ n = 0;
+ c = getc(input);
+ if (c != '\"')
+ {
+ }
+ while ((!(whitespace(c = getc(input)))) && (c != '\"'))
+ {
+ s[n++] = ((isalpha(c) && islower(c)) ? toupper(c) : c);
+ }
s[n] = '\0';
- if (n > *Size)
- *Size = n;
+ if (n > *size)
+ {
+ *size = n;
+ }
return;
}
void
-copy_string(is, s, cap, Size)
+copy_string(is, s, size)
register char *is;
char s[];
- boolean cap;
- int *Size;
+ int *size;
{
register int c, n;
n = 0;
while ((c = *is++) != '\0')
- s[n++] = ((cap && isalpha(c) && islower(c))? toupper(c) : c);
+ {
+ s[n++] = c;
+ }
s[n] = '\0';
- if (n > *Size)
- *Size = n;
+ if (n > *size)
+ {
+ *size = n;
+ }
return;
}
\f
{
"Dummy_Primitive",
"0",
- "\"DUMMY-PRIMITIVE\"",
+ "DUMMY-PRIMITIVE",
"Findprim.c"
};
{
"Prim_Inexistent",
"0",
- "No_Name",
+ "INEXISTENT-PRIMITIVE",
"Findprim.c"
};
-static char Inexistent_Real_Name[] =
- "\"INEXISTENT-PRIMITIVE\"";
-
static char Inexistent_Error_String[] =
"Primitive_Error(ERR_UNIMPLEMENTED_PRIMITIVE)";
static int A_Size = 0;
static int S_Size = 0;
static int F_Size = 0;
-
-#define DONT_CAP FALSE
-#define DO_CAP TRUE
\f
pseudo_void
-create_external_entry()
+create_normal_entry()
{
if (buffer_index >= BUFFER_SIZE)
{
error_exit(FALSE);
}
scan_to_token_start();
- copy_token((Data_Buffer[buffer_index]).C_Name, DONT_CAP, &C_Size);
+ copy_token((Data_Buffer[buffer_index]).C_Name, &C_Size);
scan_to_token_start();
- copy_token((Data_Buffer[buffer_index]).Arity, DONT_CAP, &A_Size);
+ copy_token((Data_Buffer[buffer_index]).Arity, &A_Size);
scan_to_token_start();
- copy_token((Data_Buffer[buffer_index]).Scheme_Name, DO_CAP, &S_Size);
- copy_string(file_name, (Data_Buffer[buffer_index]).File_Name, DONT_CAP, &F_Size);
+ copy_symbol((Data_Buffer[buffer_index]).Scheme_Name, &S_Size);
+ copy_string(file_name, (Data_Buffer[buffer_index]).File_Name, &F_Size);
Result_Buffer[buffer_index] = &Data_Buffer[buffer_index];
buffer_index++;
return;
{
Built_in_p = FALSE;
The_Token = &External_Token[0];
- The_Table = &External_Table[0];
+ The_Kind = &External_Kind[0];
The_Variable = &External_Variable[0];
- create_entry = create_external_entry;
+ create_entry = create_normal_entry;
+ return;
+}
+
+void
+initialize_default()
+{
+ Built_in_p = FALSE;
+ The_Token = &Default_Token[0];
+ The_Kind = &Default_Kind[0];
+ The_Variable = &Default_Variable[0];
+ create_entry = create_normal_entry;
return;
}
int index = 0;
scan_to_token_start();
- copy_token((Data_Buffer[buffer_index]).C_Name, DONT_CAP, &C_Size);
+ copy_token((Data_Buffer[buffer_index]).C_Name, &C_Size);
scan_to_token_start();
- copy_token((Data_Buffer[buffer_index]).Arity, DONT_CAP, &A_Size);
+ copy_token((Data_Buffer[buffer_index]).Arity, &A_Size);
scan_to_token_start();
- copy_token((Data_Buffer[buffer_index]).Scheme_Name, DO_CAP, &S_Size);
- copy_string(file_name, (Data_Buffer[buffer_index]).File_Name, DONT_CAP, &F_Size);
+ copy_token((Data_Buffer[buffer_index]).Scheme_Name, &S_Size);
+ copy_string(file_name, (Data_Buffer[buffer_index]).File_Name, &F_Size);
scan_to_token_start();
- copy_token(index_buffer, DONT_CAP, &index);
+ copy_token(index_buffer, &index);
index = read_index(index_buffer);
if (index >= Built_in_table_size)
{
error_exit(FALSE);
}
The_Token = &Built_in_Token[0];
- The_Table = &Built_in_Table[0];
+ The_Kind = &Built_in_Kind[0];
The_Variable = &Built_in_Variable[0];
create_entry = create_builtin_entry;
for (index = Built_in_table_size; --index >= 0; )
+ {
Result_Buffer[index] = &Inexistent_Entry;
+ }
initialize_from_entry(&Inexistent_Entry);
return;
}
{
int value;
- dprintf("comparing %s", d1->Scheme_Name);
- dprintf(" and %s.\n", d2->Scheme_Name);
+ dprintf("comparing \"%s\"", d1->Scheme_Name);
+ dprintf(" and \"%s\".\n", d2->Scheme_Name);
value = strcmp(d1->Scheme_Name, d2->Scheme_Name);
if (value > 0)
{
fprintf(output, "/%c ", '*');
print_spaces(A_Size - (strlen(primitive_descriptor->Arity)));
fprintf(output,
- "%s %s",
+ "%s \"%s\"",
(primitive_descriptor->Arity),
(primitive_descriptor->Scheme_Name));
print_spaces(S_Size-(strlen(primitive_descriptor->Scheme_Name)));
- fprintf(output, " %s ", ((Built_in_p) ? "Primitive" : "External"));
+ 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), '*');
/* Print the procedure table. */
- fprintf(output, "Pointer (*(%s_Procedure_Table[]))() = {\n", The_Table);
+ fprintf(output, "Pointer (*(%s_Procedure_Table[]))() = {\n", The_Kind);
for (count = 0; count < last; count++)
{
/* Print the arity table. */
- fprintf(output, "int %s_Arity_Table[] = {\n", The_Table);
+ fprintf(output, "int %s_Arity_Table[] = {\n", The_Kind);
for (count = 0; count < last; count++)
{
/* Print the names table. */
- fprintf(output, "char *%s_Name_Table[] = {\n", The_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[count])->Scheme_Name));
}
- fprintf(output, " %s\n", ((Result_Buffer[last])->Scheme_Name));
+ fprintf(output, " \"%s\"\n", ((Result_Buffer[last])->Scheme_Name));
fprintf(output, "};\n\n");
return;
if (Built_in_p)
{
fprintf(output, " %s();\n\n", &(Inexistent_Entry.C_Name)[0]);
-
- fprintf(output,
- "static char %s[] = %s;\n\n",
- Inexistent_Entry.Scheme_Name,
- Inexistent_Real_Name);
print_procedure(&Inexistent_Entry, &Inexistent_Error_String[0]);
}
else
+ {
fprintf(output, " %s();\n", &(Data_Buffer[end].C_Name)[0]);
-
+ }
}
fprintf(output, "\f\n");
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fixnum.c,v 9.24 1987/05/14 13:48:41 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fixnum.c,v 9.25 1987/11/17 08:11:05 jinx Rel $
Copyright (c) 1987 Massachusetts Institute of Technology
/* Predicates */
Built_In_Primitive (Prim_Zero_Fixnum, 1, "ZERO-FIXNUM?", 0x46)
+Define_Primitive (Prim_Zero_Fixnum, 1, "ZERO-FIXNUM?")
{
FIXNUM_PRIMITIVE_1 (x);
BOOLEAN_RESULT ((Get_Integer (Arg1)) == 0);
}
Built_In_Primitive (Prim_Negative_Fixnum, 1, "NEGATIVE-FIXNUM?", 0x7F)
+Define_Primitive (Prim_Negative_Fixnum, 1, "NEGATIVE-FIXNUM?")
{
FIXNUM_PRIMITIVE_1 (x);
BOOLEAN_RESULT (x < 0);
}
Built_In_Primitive (Prim_Positive_Fixnum, 1, "POSITIVE-FIXNUM?", 0x41)
+Define_Primitive (Prim_Positive_Fixnum, 1, "POSITIVE-FIXNUM?")
{
FIXNUM_PRIMITIVE_1 (x);
BOOLEAN_RESULT (x > 0);
}
Built_In_Primitive (Prim_Equal_Fixnum, 2, "EQUAL-FIXNUM?", 0x3F)
+Define_Primitive (Prim_Equal_Fixnum, 2, "EQUAL-FIXNUM?")
{
FIXNUM_PRIMITIVE_2 (x, y);
BOOLEAN_RESULT (x == y);
}
Built_In_Primitive (Prim_Less_Fixnum, 2, "LESS-THAN-FIXNUM?", 0x40)
+Define_Primitive (Prim_Less_Fixnum, 2, "LESS-THAN-FIXNUM?")
{
FIXNUM_PRIMITIVE_2 (x, y);
BOOLEAN_RESULT (x < y);
}
Built_In_Primitive (Prim_Greater_Fixnum, 2, "GREATER-THAN-FIXNUM?", 0x81)
+Define_Primitive (Prim_Greater_Fixnum, 2, "GREATER-THAN-FIXNUM?")
{
FIXNUM_PRIMITIVE_2 (x, y);
BOOLEAN_RESULT (x > y);
/* Operators */
Built_In_Primitive (Prim_One_Plus_Fixnum, 1, "ONE-PLUS-FIXNUM", 0x42)
+Define_Primitive (Prim_One_Plus_Fixnum, 1, "ONE-PLUS-FIXNUM")
{
fast long result;
FIXNUM_PRIMITIVE_1 (x);
}
Built_In_Primitive (Prim_M_1_Plus_Fixnum, 1, "MINUS-ONE-PLUS-FIXNUM", 0x43)
+Define_Primitive (Prim_M_1_Plus_Fixnum, 1, "MINUS-ONE-PLUS-FIXNUM")
{
fast long result;
FIXNUM_PRIMITIVE_1 (x);
}
Built_In_Primitive (Prim_Plus_Fixnum, 2, "PLUS-FIXNUM", 0x3B)
+Define_Primitive (Prim_Plus_Fixnum, 2, "PLUS-FIXNUM")
{
fast long result;
FIXNUM_PRIMITIVE_2 (x, y);
}
Built_In_Primitive (Prim_Minus_Fixnum, 2, "MINUS-FIXNUM", 0x3C)
+Define_Primitive (Prim_Minus_Fixnum, 2, "MINUS-FIXNUM")
{
fast long result;
FIXNUM_PRIMITIVE_2 (x, y);
}
\f
Built_In_Primitive (Prim_Multiply_Fixnum, 2, "MULTIPLY-FIXNUM", 0x3D)
+Define_Primitive (Prim_Multiply_Fixnum, 2, "MULTIPLY-FIXNUM")
{
/* Mul, which does the multiplication with overflow handling, is
customized for some machines. Therefore, it is in os.c */
}
Built_In_Primitive (Prim_Divide_Fixnum, 2, "DIVIDE-FIXNUM", 0x3E)
+Define_Primitive (Prim_Divide_Fixnum, 2, "DIVIDE-FIXNUM")
{
/* Returns the CONS of quotient and remainder */
fast long quotient;
}
Built_In_Primitive (Prim_Gcd_Fixnum, 2, "GCD-FIXNUM", 0x66)
+Define_Primitive (Prim_Gcd_Fixnum, 2, "GCD-FIXNUM")
{
fast long z;
FIXNUM_PRIMITIVE_2 (x, y);
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/flonum.c,v 9.23 1987/07/27 16:55:48 jinx Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/flonum.c,v 9.24 1987/11/17 08:11:14 jinx Rel $
*
* This file contains support for floating point arithmetic. Most
* of these primitives have been superceded by generic arithmetic.
*/
Built_In_Primitive(Prim_Plus_Flonum, 2, "PLUS-FLONUM", 0x69)
+Define_Primitive(Prim_Plus_Flonum, 2, "PLUS-FLONUM")
{
Primitive_2_Args();
}
Built_In_Primitive(Prim_Minus_Flonum, 2, "MINUS-FLONUM", 0x6A)
+Define_Primitive(Prim_Minus_Flonum, 2, "MINUS-FLONUM")
{
Primitive_2_Args();
}
Built_In_Primitive(Prim_Multiply_Flonum, 2, "MULTIPLY-FLONUM", 0x6B)
+Define_Primitive(Prim_Multiply_Flonum, 2, "MULTIPLY-FLONUM")
{
Primitive_2_Args();
}
Built_In_Primitive(Prim_Divide_Flonum, 2, "DIVIDE-FLONUM", 0x6C)
+Define_Primitive(Prim_Divide_Flonum, 2, "DIVIDE-FLONUM")
{
Primitive_2_Args();
*/
Built_In_Primitive(Prim_Equal_Flonum, 2, "EQUAL-FLONUM?", 0x6D)
+Define_Primitive(Prim_Equal_Flonum, 2, "EQUAL-FLONUM?")
{
Primitive_2_Args();
}
Built_In_Primitive(Prim_Greater_Flonum, 2, "GREATER-THAN-FLONUM?", 0xAA)
+Define_Primitive(Prim_Greater_Flonum, 2, "GREATER-THAN-FLONUM?")
{
Primitive_2_Args();
}
Built_In_Primitive(Prim_Less_Flonum, 2, "LESS-THAN-FLONUM?", 0x6E)
+Define_Primitive(Prim_Less_Flonum, 2, "LESS-THAN-FLONUM?")
{
Primitive_2_Args();
*/
Built_In_Primitive(Prim_Sine_Flonum, 1, "SINE-FLONUM", 0x73)
+Define_Primitive(Prim_Sine_Flonum, 1, "SINE-FLONUM")
{
extern double sin();
Primitive_1_Arg();
}
Built_In_Primitive(Prim_Cosine_Flonum, 1, "COSINE-FLONUM", 0x74)
+Define_Primitive(Prim_Cosine_Flonum, 1, "COSINE-FLONUM")
{
extern double cos();
Primitive_1_Arg();
}
Built_In_Primitive(Prim_Arctan_Flonum, 1, "ARCTAN-FLONUM", 0x75)
+Define_Primitive(Prim_Arctan_Flonum, 1, "ARCTAN-FLONUM")
{
extern double atan();
Primitive_1_Arg();
}
\f
Built_In_Primitive(Prim_Exp_Flonum, 1, "EXP-FLONUM", 0x76)
+Define_Primitive(Prim_Exp_Flonum, 1, "EXP-FLONUM")
{
extern double exp();
Primitive_1_Arg();
}
Built_In_Primitive(Prim_Ln_Flonum, 1, "LN-FLONUM", 0x77)
+Define_Primitive(Prim_Ln_Flonum, 1, "LN-FLONUM")
{
extern double log();
Primitive_1_Arg();
}
Built_In_Primitive(Prim_Sqrt_Flonum, 1, "SQRT-FLONUM", 0x78)
+Define_Primitive(Prim_Sqrt_Flonum, 1, "SQRT-FLONUM")
{
extern double sqrt();
double Arg;
}
\f
Built_In_Primitive(Prim_Zero_Flonum, 1, "ZERO-FLONUM?", 0xA7)
+Define_Primitive(Prim_Zero_Flonum, 1, "ZERO-FLONUM?")
{
Primitive_1_Arg();
}
Built_In_Primitive(Prim_Positive_Flonum, 1, "POSITIVE-FLONUM?", 0xA8)
+Define_Primitive(Prim_Positive_Flonum, 1, "POSITIVE-FLONUM?")
{
Primitive_1_Arg();
}
Built_In_Primitive(Prim_Negative_Flonum, 1, "NEGATIVE-FLONUM?", 0xA9)
+Define_Primitive(Prim_Negative_Flonum, 1, "NEGATIVE-FLONUM?")
{
Primitive_1_Arg();
the correct type, FIXNUM-OR-BIGNUM is returned unchanged.
*/
Built_In_Primitive(Prim_Int_To_Float, 1, "COERCE-INTEGER-TO-FLONUM", 0x72)
+Define_Primitive(Prim_Int_To_Float, 1, "COERCE-INTEGER-TO-FLONUM")
{
Primitive_1_Arg();
Returns NIL if FLONUM isn't a floating point number
*/
Built_In_Primitive(Prim_Truncate_Flonum, 1, "TRUNCATE-FLONUM", 0x70)
+Define_Primitive(Prim_Truncate_Flonum, 1, "TRUNCATE-FLONUM")
{
fast double A;
long Answer; /* Faulty VAX/UNIX C optimizer */
FLONUM is a floating point number. Otherwise returns FLONUM.
*/
Built_In_Primitive(Prim_Round_Flonum, 1, "ROUND-FLONUM", 0x71)
+Define_Primitive(Prim_Round_Flonum, 1, "ROUND-FLONUM")
{
fast double A;
long Answer; /* Faulty VAX/UNIX C optimizer */
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/future.c,v 9.24 1987/10/09 16:10:27 jinx Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/future.c,v 9.25 1987/11/17 08:11:25 jinx Rel $
Support code for futures
*/
{
return NIL;
}
- while ((IntEnb & IntCode) == 0)
+ while (!(INTERRUPT_PENDING_P(INT_Mask)))
{
if (Swap_Pointers(Nth_Vector_Loc(Arg1, FUTURE_LOCK),
TRUTH) == NIL)
#endif /* USE_STACKLETS */
- Free[CONTINUATION_EXPRESSION] = Make_Non_Pointer(TC_FIXNUM, IntEnb);
+ Free[CONTINUATION_EXPRESSION] = MAKE_SIGNED_FIXNUM(FETCH_INTERRUPT_MASK());
Free[CONTINUATION_RETURN_CODE] =
Make_Non_Pointer(TC_RETURN_CODE, RC_RESTORE_INT_MASK);
Free += CONTINUATION_SIZE;
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.23 1987/10/09 16:10:46 jinx Rel $
+/* $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 $
*
* Garbage collection related macros of sufficient utility to be
* included in all compilations.
\f
/* Overflow detection, various cases */
-#define GC_Check(Amount) (((Amount+Free) >= MemTop) && \
- ((IntEnb & INT_GC) != 0))
+#define GC_ENABLED_P() (INTERRUPT_ENABLED_P(INT_GC))
-#define Space_Before_GC() (((IntEnb & INT_GC) != 0) ? \
+#define GC_Check(Amount) (((Amount + Free) >= MemTop) && \
+ (GC_ENABLED_P()))
+
+#define Space_Before_GC() ((GC_ENABLED_P()) ? \
(MemTop - Free) : \
(Heap_Top - Free))
-#define Request_Interrupt(code) \
-{ \
- IntCode |= (code); \
- New_Compiler_MemTop(); \
+#define Request_GC(Amount) \
+{ \
+ REQUEST_INTERRUPT(INT_GC); \
+ GC_Space_Needed = Amount; \
}
-#define Request_GC(Amount) \
-{ \
- Request_Interrupt( INT_GC); \
- GC_Space_Needed = Amount; \
+#define SET_MEMTOP(Addr) \
+{ \
+ MemTop = Addr; \
+ COMPILER_SET_MEMTOP(); \
}
-#define Set_Mem_Top(Addr) \
- MemTop = Addr; New_Compiler_MemTop()
-
-#define Set_Stack_Guard(Addr) Stack_Guard = Addr
-
-#define New_Compiler_MemTop() \
- Regs[REGBLOCK_MEMTOP] = \
- ((IntCode & IntEnb)==0) ? ((Pointer) MemTop) : ((Pointer) -1)
+#define Set_Stack_Guard(Addr) \
+{ \
+ Stack_Guard = Addr; \
+}
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/gccode.h,v 9.30 1987/10/09 16:10:56 jinx Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/gccode.h,v 9.31 1987/11/17 08:11:46 jinx Rel $
*
* This file contains the macros for use in code which does GC-like
* loops over memory. It is only included in a few files, unlike
#define case_simple_Non_Pointer \
case TC_NULL: \
case TC_TRUE: \
- case TC_THE_ENVIRONMENT: \
case TC_RETURN_CODE: \
- case TC_PRIMITIVE: \
- case TC_PCOMB0
+ case TC_THE_ENVIRONMENT
#define case_Fasload_Non_Pointer \
case TC_FIXNUM: \
case_simple_Non_Pointer
#define case_Non_Pointer \
- case TC_PRIMITIVE_EXTERNAL: \
+ case TC_PRIMITIVE: \
+ case TC_PCOMB0: \
case TC_STACK_ENVIRONMENT: \
case_Fasload_Non_Pointer
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/gctype.c,v 9.25 1987/10/09 16:11:06 jinx Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/gctype.c,v 9.26 1987/11/17 08:11:56 jinx Rel $
*
* This file contains the table which maps between Types and
* GC Types.
GC_Pair, /* TC_COMPILED_PROCEDURE */
GC_Vector, /* TC_BIG_FIXNUM */
GC_Pair, /* TC_PROCEDURE */
- GC_Non_Pointer, /* TC_PRIMITIVE_EXTERNAL */
+ GC_Undefined, /* 0x10 */
GC_Pair, /* TC_DELAY */
GC_Vector, /* TC_ENVIRONMENT */
GC_Pair, /* TC_DELAYED */
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/generic.c,v 9.24 1987/07/27 17:47:20 jinx Rel $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/generic.c,v 9.25 1987/11/17 08:12:07 jinx Rel $ */
#include "scheme.h"
#include "primitive.h"
#include "zones.h"
\f
Built_In_Primitive(Prim_Zero, 1, "ZERO?", 0xE6)
+Define_Primitive(Prim_Zero, 1, "ZERO?")
{
Primitive_1_Arg();
Built_In_Primitive(Prim_Positive, 1, "POSITIVE?", 0xE7)
+Define_Primitive(Prim_Positive, 1, "POSITIVE?")
{
Sign_Check(>, POS_BIGNUM);
/*NOTREACHED*/
}
Built_In_Primitive(Prim_Negative, 1, "NEGATIVE?", 0xE8)
+Define_Primitive(Prim_Negative, 1, "NEGATIVE?")
{
Sign_Check(<, NEG_BIGNUM);
/*NOTREACHED*/
}
Built_In_Primitive(Prim_One_Plus, 1, "1+", 0xF1)
+Define_Primitive(Prim_One_Plus, 1, "1+")
{
Inc_Dec(+, plus_signed_bignum);
/*NOTREACHED*/
}
Built_In_Primitive(Prim_M_1_Plus, 1, "-1+", 0xF2)
+Define_Primitive(Prim_M_1_Plus, 1, "-1+")
{
Inc_Dec(-, minus_signed_bignum);
/*NOTREACHED*/
}
Built_In_Primitive(Prim_Equal_Number, 2, "&=", 0xE9)
+Define_Primitive(Prim_Equal_Number, 2, "&=")
{
Two_Op_Comparator(==, EQUAL);
/*NOTREACHED*/
}
Built_In_Primitive(Prim_Less, 2, "&<", 0xEA)
+Define_Primitive(Prim_Less, 2, "&<")
{
Two_Op_Comparator(<, TWO_BIGGER);
/*NOTREACHED*/
}
Built_In_Primitive(Prim_Greater, 2, "&>", 0xEB)
+Define_Primitive(Prim_Greater, 2, "&>")
{
Two_Op_Comparator(>, ONE_BIGGER);
/*NOTREACHED*/
}
Built_In_Primitive(Prim_Plus, 2, "&+", 0xEC)
+Define_Primitive(Prim_Plus, 2, "&+")
{
Two_Op_Operator(+, plus_signed_bignum);
/*NOTREACHED*/
}
Built_In_Primitive(Prim_Minus, 2, "&-", 0xED)
+Define_Primitive(Prim_Minus, 2, "&-")
{
Two_Op_Operator(-, minus_signed_bignum);
/*NOTREACHED*/
}
\f
Built_In_Primitive(Prim_Multiply, 2, "&*", 0xEE)
+Define_Primitive(Prim_Multiply, 2, "&*")
{
/* Mul is machine dependent and lives in os.c */
extern Pointer Mul();
}
\f
Built_In_Primitive(Prim_Divide, 2, "&/", 0xEF)
+Define_Primitive(Prim_Divide, 2, "&/")
{
Primitive_2_Args();
}
\f
Built_In_Primitive(Prim_Integer_Divide, 2, "INTEGER-DIVIDE", 0xF0)
+Define_Primitive(Prim_Integer_Divide, 2, "INTEGER-DIVIDE")
{
Primitive_2_Args();
Generic_Restriction(Scheme_Ln, log, <=)
Built_In_Primitive(Prim_Sqrt, 1, "SQRT", 0xF7)
+Define_Primitive(Prim_Sqrt, 1, "SQRT")
{
Generic_Function(Scheme_Sqrt);
/*NOTREACHED*/
}
Built_In_Primitive(Prim_Exp, 1, "EXP", 0xF8)
+Define_Primitive(Prim_Exp, 1, "EXP")
{
Generic_Function(exp);
/*NOTREACHED*/
}
Built_In_Primitive(Prim_Ln, 1, "LOG", 0xF9)
+Define_Primitive(Prim_Ln, 1, "LOG")
{
Generic_Function(Scheme_Ln);
/*NOTREACHED*/
}
Built_In_Primitive(Prim_Sine, 1, "SIN", 0xFA)
+Define_Primitive(Prim_Sine, 1, "SIN")
{
Generic_Function(sin);
/*NOTREACHED*/
}
Built_In_Primitive(Prim_Cosine, 1, "COS", 0xFB)
+Define_Primitive(Prim_Cosine, 1, "COS")
{
Generic_Function(cos);
/*NOTREACHED*/
}
Built_In_Primitive(Prim_Arctan, 1, "&ATAN", 0xFC)
+Define_Primitive(Prim_Arctan, 1, "&ATAN")
{
Generic_Function(atan);
/*NOTREACHED*/
}
Built_In_Primitive(Prim_Truncate, 1, "TRUNCATE", 0xF3)
+Define_Primitive(Prim_Truncate, 1, "TRUNCATE")
{
Flonum_To_Integer(Truncate_Mapping);
/*NOTREACHED*/
}
Built_In_Primitive(Prim_Round, 1, "ROUND", 0xF4)
+Define_Primitive(Prim_Round, 1, "ROUND")
{
Flonum_To_Integer(Round_Mapping);
/*NOTREACHED*/
}
Built_In_Primitive(Prim_Floor, 1, "FLOOR", 0xF5)
+Define_Primitive(Prim_Floor, 1, "FLOOR")
{
Flonum_To_Integer(Floor_Mapping);
/*NOTREACHED*/
}
Built_In_Primitive(Prim_Ceiling, 1, "CEILING", 0xF6)
+Define_Primitive(Prim_Ceiling, 1, "CEILING")
{
Flonum_To_Integer(Ceiling_Mapping);
/*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/hooks.c,v 9.26 1987/10/09 16:11:27 jinx Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/hooks.c,v 9.27 1987/11/17 08:12:25 jinx Exp $
*
* This file contains various hooks and handles which connect the
* primitives with the main interpreter.
procedure, or control point. */
Built_In_Primitive(Prim_Apply, 2, "APPLY", 0x5)
+Define_Primitive(Prim_Apply, 2, "APPLY")
{
fast Pointer scan_list, *scan_stack;
fast long number_of_args, i;
*/ \
Will_Push(CONTINUATION_SIZE + HISTORY_SIZE); \
Save_History(Return_Code); \
- Store_Expression(Make_Non_Pointer(TC_FIXNUM, IntEnb)); \
+ Store_Expression(MAKE_SIGNED_FIXNUM(FETCH_INTERRUPT_MASK())); \
Store_Return(RC_RESTORE_INT_MASK); \
Save_Cont(); \
Pushed(); \
*/
Built_In_Primitive(Prim_Catch, 1, "CALL-WITH-CURRENT-CONTINUATION", 0x3)
+Define_Primitive(Prim_Catch, 1, "CALL-WITH-CURRENT-CONTINUATION")
{
Pointer Control_Point;
Primitive_1_Arg();
Built_In_Primitive(Prim_Non_Reentrant_Catch, 1,
"NON-REENTRANT-CALL-WITH-CURRENT-CONTINUATION", 0x9)
+Define_Primitive(Prim_Non_Reentrant_Catch, 1,
+ "NON-REENTRANT-CALL-WITH-CURRENT-CONTINUATION")
{
Pointer Control_Point;
Primitive_1_Arg();
See MASK_INTERRUPT_ENABLES for more information on interrupts.
*/
Built_In_Primitive(Prim_Enable_Interrupts, 1, "ENABLE-INTERRUPTS!", 0x1E)
+Define_Primitive(Prim_Enable_Interrupts, 1, "ENABLE-INTERRUPTS!")
{
- Pointer Result;
+ long previous;
Primitive_1_Arg();
Arg_1_Type(TC_FIXNUM);
- Result = Make_Non_Pointer(TC_FIXNUM, IntEnb);
- IntEnb = (Get_Integer(Arg1) | INT_Mask);
- New_Compiler_MemTop();
- PRIMITIVE_RETURN( Result);
+ previous = FETCH_INTERRUPT_MASK();
+ SET_INTERRUPT_MASK((Get_Integer(Arg1) & INT_Mask) | previous);
+ PRIMITIVE_RETURN( MAKE_SIGNED_FIXNUM(previous));
}
/* (ERROR-PROCEDURE arg1 arg2 arg3)
after turning off history, etc.
*/
Built_In_Primitive(Prim_Error_Procedure, 3, "ERROR-PROCEDURE", 0x18E)
+Define_Primitive(Prim_Error_Procedure, 3, "ERROR-PROCEDURE")
{
Primitive_3_Args();
*/
Built_In_Primitive(Prim_Get_Fixed_Objects_Vector, 0,
"GET-FIXED-OBJECTS-VECTOR", 0x7A)
+Define_Primitive(Prim_Get_Fixed_Objects_Vector, 0,
+ "GET-FIXED-OBJECTS-VECTOR")
{
Primitive_0_Args();
use.
*/
Built_In_Primitive(Prim_Force, 1, "FORCE", 0xAF)
+Define_Primitive(Prim_Force, 1, "FORCE")
{
Primitive_1_Arg();
/*NOTREACHED*/
}
\f
-/* (EXECUTE-AT-NEW-POINT SPACE BEFORE DURING AFTER)
+/* (EXECUTE-AT-NEW-STATE-POINT SPACE BEFORE DURING AFTER)
Create a new state point in the specified state SPACE. To enter
the new point you must execute the BEFORE thunk. On the way out,
the AFTER thunk is executed. If SPACE is NIL, then the microcode
variable Current_State_Point is used to find the current state
point and no state space is side-effected as the code runs.
*/
-Built_In_Primitive(Prim_Execute_At_New_Point, 4, "EXECUTE-AT-NEW-POINT", 0xE2)
+Built_In_Primitive(Prim_Execute_At_New_Point, 4,
+ "EXECUTE-AT-NEW-STATE-POINT", 0xE2)
+Define_Primitive(Prim_Execute_At_New_Point, 4,
+ "EXECUTE-AT-NEW-STATE-POINT")
{
Pointer New_Point, Old_Point;
Primitive_4_Args();
the microcode will track motions in this space.
*/
Built_In_Primitive(Prim_Make_State_Space, 1, "MAKE-STATE-SPACE", 0xE1)
+Define_Primitive(Prim_Make_State_Space, 1, "MAKE-STATE-SPACE")
{
Pointer New_Point;
Primitive_1_Arg();
}
\f
Built_In_Primitive(Prim_Current_Dynamic_State, 1, "CURRENT-DYNAMIC-STATE", 0xA)
+Define_Primitive(Prim_Current_Dynamic_State, 1, "CURRENT-DYNAMIC-STATE")
{
Primitive_1_Arg();
}
Built_In_Primitive(Prim_Set_Dynamic_State, 1, "SET-CURRENT-DYNAMIC-STATE!", 0xB)
+Define_Primitive(Prim_Set_Dynamic_State, 1, "SET-CURRENT-DYNAMIC-STATE!")
{
Pointer State_Space, Result;
Primitive_1_Arg();
to be syntaxed into SCode rather than just a list.
*/
Built_In_Primitive(Prim_Scode_Eval, 2, "SCODE-EVAL", 0x4)
+Define_Primitive(Prim_Scode_Eval, 2, "SCODE-EVAL")
{
Primitive_2_Args();
information on interrupts.
*/
Built_In_Primitive(Prim_Set_Interrupt_Enables, 1, "SET-INTERRUPT-ENABLES!", 0x6)
+Define_Primitive(Prim_Set_Interrupt_Enables, 1, "SET-INTERRUPT-ENABLES!")
{
- Pointer Result;
+ long previous;
Primitive_1_Arg();
Arg_1_Type(TC_FIXNUM);
- Result = Make_Unsigned_Fixnum(IntEnb);
- IntEnb = (Get_Integer(Arg1) & INT_Mask);
- New_Compiler_MemTop();
- PRIMITIVE_RETURN( Result);
+ previous = FETCH_INTERRUPT_MASK();
+ SET_INTERRUPT_MASK(Get_Integer(Arg1) & INT_Mask);
+ PRIMITIVE_RETURN( MAKE_SIGNED_FIXNUM(previous));
}
\f
/* (SET-CURRENT-HISTORY! TRIPLE)
The longjmp forces the interpreter to recache.
*/
Built_In_Primitive(Prim_Set_Current_History, 1, "SET-CURRENT-HISTORY!", 0x2F)
+Define_Primitive(Prim_Set_Current_History, 1, "SET-CURRENT-HISTORY!")
{
Primitive_1_Arg();
*/
Built_In_Primitive(Prim_Set_Fixed_Objects_Vector, 1,
"SET-FIXED-OBJECTS-VECTOR!", 0x7B)
+Define_Primitive(Prim_Set_Fixed_Objects_Vector, 1,
+ "SET-FIXED-OBJECTS-VECTOR!")
{
Pointer Result;
Primitive_1_Arg();
*/
Built_In_Primitive(Prim_Translate_To_Point, 1,
"TRANSLATE-TO-STATE-POINT", 0xE3)
+Define_Primitive(Prim_Translate_To_Point, 1,
+ "TRANSLATE-TO-STATE-POINT")
{
Primitive_1_Arg();
*/
Built_In_Primitive(Prim_With_History_Disabled, 1,
"WITH-HISTORY-DISABLED", 0x9C)
+Define_Primitive(Prim_With_History_Disabled, 1,
+ "WITH-HISTORY-DISABLED")
{
Pointer *First_Rib, *Rib, *Second_Rib;
Primitive_1_Arg();
Built_In_Primitive(Prim_With_Interrupt_Mask, 2,
"WITH-INTERRUPT-MASK", 0x137)
+Define_Primitive(Prim_With_Interrupt_Mask, 2,
+ "WITH-INTERRUPT-MASK")
{
+ Pointer mask;
Primitive_2_Args();
Arg_1_Type(TC_FIXNUM);
Pop_Primitive_Frame(2);
+ mask = MAKE_SIGNED_FIXNUM(FETCH_INTERRUPT_MASK());
Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+2));
Store_Return(RC_RESTORE_INT_MASK);
- Store_Expression(Make_Unsigned_Fixnum(IntEnb));
+ Store_Expression(mask);
Save_Cont();
- Push(Make_Unsigned_Fixnum(IntEnb)); /* Current interrupt mask */
- Push(Arg2); /* Function to call */
+
+ Push(mask); /* Current interrupt mask */
+ Push(Arg2); /* Function to call */
Push(STACK_FRAME_HEADER+1);
Pushed();
- IntEnb = (INT_Mask & Get_Integer(Arg1));
+ SET_INTERRUPT_MASK(INT_Mask & Get_Integer(Arg1));
PRIMITIVE_ABORT( PRIM_APPLY);
/*NOTREACHED*/
}
Built_In_Primitive(Prim_With_Interrupts_Reduced, 2,
"WITH-INTERRUPTS-REDUCED", 0xC9)
+Define_Primitive(Prim_With_Interrupts_Reduced, 2,
+ "WITH-INTERRUPTS-REDUCED")
{
- long new_interrupt_mask;
+ Pointer mask;
+ long new_interrupt_mask, old_interrupt_mask;
Primitive_2_Args();
Arg_1_Type(TC_FIXNUM);
Pop_Primitive_Frame(2);
+ mask = MAKE_SIGNED_FIXNUM(FETCH_INTERRUPT_MASK());
+
Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+2));
Store_Return(RC_RESTORE_INT_MASK);
- Store_Expression(Make_Unsigned_Fixnum(IntEnb));
+ Store_Expression(mask);
Save_Cont();
- Push(Make_Unsigned_Fixnum(IntEnb)); /* Current interrupt mask */
- Push(Arg2); /* Function to call */
+
+ Push(mask); /* Current interrupt mask */
+ Push(Arg2); /* Function to call */
Push(STACK_FRAME_HEADER+1);
Pushed();
new_interrupt_mask = (INT_Mask & Get_Integer( Arg1));
- if (new_interrupt_mask > IntEnb)
- IntEnb = new_interrupt_mask;
+ old_interrupt_mask = FETCH_INTERRUPT_MASK();
+ if (new_interrupt_mask > old_interrupt_mask)
+ {
+ SET_INTERRUPT_MASK(new_interrupt_mask);
+ }
else
- IntEnb = (new_interrupt_mask & IntEnb);
+ {
+ SET_INTERRUPT_MASK(new_interrupt_mask & old_interrupt_mask);
+ }
PRIMITIVE_ABORT( PRIM_APPLY);
/*NOTREACHED*/
}
*/
Built_In_Primitive(Prim_Within_Control_Point, 2,
"WITHIN-CONTROL-POINT", 0xBF)
+Define_Primitive(Prim_Within_Control_Point, 2,
+ "WITHIN-CONTROL-POINT")
{
Primitive_2_Args();
*/
Built_In_Primitive(Prim_With_Threaded_Stack, 2,
"WITH-THREADED-CONTINUATION", 0xBE)
+Define_Primitive(Prim_With_Threaded_Stack, 2,
+ "WITH-THREADED-CONTINUATION")
{
Primitive_2_Args();
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/hunk.c,v 9.23 1987/10/09 16:11:45 jinx Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/hunk.c,v 9.24 1987/11/17 08:12:44 jinx Rel $
*
* Support for Hunk3s (triples)
*/
Returns a triple consisting of the specified values.
*/
Built_In_Primitive(Prim_Hunk3_Cons, 3, "HUNK3-CONS", 0x28)
+Define_Primitive(Prim_Hunk3_Cons, 3, "HUNK3-CONS")
{
Primitive_3_Args();
Returns the Nth item from the TRIPLE. N must be 0, 1, or 2.
*/
Built_In_Primitive(Prim_Hunk3_Cxr, 2, "HUNK3-CXR", 0x29)
+Define_Primitive(Prim_Hunk3_Cxr, 2, "HUNK3-CXR")
{
long Offset;
Primitive_2_Args();
Returns the previous contents.
*/
Built_In_Primitive(Prim_Hunk3_Set_Cxr, 3, "HUNK3-SET-CXR!", 0x2A)
+Define_Primitive(Prim_Hunk3_Set_Cxr, 3, "HUNK3-SET-CXR!")
{
long Offset;
Primitive_3_Args();
a COMBINATION_2_OPERAND SCode item.
*/
Built_In_Primitive(Prim_Sys_H3_0, 1, "SYSTEM-HUNK3-CXR0", 0x8E)
+Define_Primitive(Prim_Sys_H3_0, 1, "SYSTEM-HUNK3-CXR0")
{
Primitive_1_Arg();
slot of a COMBINATION_2_OPERAND SCode item.
*/
Built_In_Primitive(Prim_Sys_H3_1, 1, "SYSTEM-HUNK3-CXR1", 0x91)
+Define_Primitive(Prim_Sys_H3_1, 1, "SYSTEM-HUNK3-CXR1")
{
Primitive_1_Arg();
slot of a COMBINATION_2_OPERAND SCode item.
*/
Built_In_Primitive(Prim_Sys_H3_2, 1, "SYSTEM-HUNK3-CXR2", 0x94)
+Define_Primitive(Prim_Sys_H3_2, 1, "SYSTEM-HUNK3-CXR2")
{
Primitive_1_Arg();
the previous contents.
*/
Built_In_Primitive(Prim_SH3_Set_0, 2, "SYSTEM-HUNK3-SET-CXR0!", 0x8F)
+Define_Primitive(Prim_SH3_Set_0, 2, "SYSTEM-HUNK3-SET-CXR0!")
{
Primitive_2_Args();
Arg_1_GC_Type(GC_Triple);
Returns the previous contents.
*/
Built_In_Primitive(Prim_SH3_Set_1, 2, "SYSTEM-HUNK3-SET-CXR1!", 0x92)
+Define_Primitive(Prim_SH3_Set_1, 2, "SYSTEM-HUNK3-SET-CXR1!")
{
Primitive_2_Args();
Arg_1_GC_Type(GC_Triple);
Returns the previous contents.
*/
Built_In_Primitive(Prim_SH3_Set_2, 2, "SYSTEM-HUNK3-SET-CXR2!", 0x95)
+Define_Primitive(Prim_SH3_Set_2, 2, "SYSTEM-HUNK3-SET-CXR2!")
{
Primitive_2_Args();
Arg_1_GC_Type(GC_Triple);
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/intern.c,v 9.42 1987/08/01 06:56:48 jinx Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/intern.c,v 9.43 1987/11/17 08:12:53 jinx Exp $
Utilities for manipulating symbols.
*/
if (Address(String1) == Address(String2))
return true;
- Length1 = Get_Integer(Fast_Vector_Ref(String1, STRING_LENGTH));
- Length2 = Get_Integer(Fast_Vector_Ref(String2, STRING_LENGTH));
+ Length1 = ((long) (Fast_Vector_Ref(String1, STRING_LENGTH)));
+ Length2 = ((long) (Fast_Vector_Ref(String2, STRING_LENGTH)));
if (Length1 != Length2)
+ {
return false;
+ }
S1 = ((char *) Nth_Vector_Loc(String1, STRING_CHARS));
S2 = ((char *) Nth_Vector_Loc(String2, STRING_CHARS));
for (i = 0; i < Length1; i++)
+ {
if (*S1++ != *S2++)
- return false;
- return true;
+ {
+ return (false);
+ }
+ }
+ return (true);
}
\f
/* Interning involves hashing the input string and either returning
instead of a list of ascii values as argument.
*/
Built_In_Primitive(Prim_String_To_Symbol, 1, "STRING->SYMBOL", 0x7)
+Define_Primitive(Prim_String_To_Symbol, 1, "STRING->SYMBOL")
{
Primitive_1_Arg();
Built_In_Primitive(Prim_Intern_Character_List, 1,
"INTERN-CHARACTER-LIST", 0xAB)
+Define_Primitive(Prim_Intern_Character_List, 1,
+ "INTERN-CHARACTER-LIST")
{
extern Pointer list_to_string();
Primitive_1_Arg();
the reader in creating interned symbols.
*/
Built_In_Primitive(Prim_String_Hash, 1, "STRING-HASH", 0x83)
+Define_Primitive(Prim_String_Hash, 1, "STRING-HASH")
{
Primitive_1_Arg();
}
Built_In_Primitive (Prim_string_hash_mod, 2, "STRING-HASH-MOD", 0x8A)
+Define_Primitive (Prim_string_hash_mod, 2, "STRING-HASH-MOD")
{
Primitive_2_Args ();
CHECK_ARG (1, STRING_P);
*/
Built_In_Primitive(Prim_Character_List_Hash, 1,
"CHARACTER-LIST-HASH", 0x65)
+Define_Primitive(Prim_Character_List_Hash, 1,
+ "CHARACTER-LIST-HASH")
{
long Length;
Pointer This_Char;
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.34 1987/11/04 20:02:10 cph Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/interp.c,v 9.35 1987/11/17 08:13:04 jinx Exp $
*
* This file contains the heart of the Scheme Scode
* interpreter
#define Immediate_GC(N) \
{ \
Request_GC(N); \
- Interrupt(IntCode & IntEnb); \
+ Interrupt(PENDING_INTERRUPTS()); \
}
#define Prepare_Eval_Repeat() \
Orig_Arg = *Arg; \
\
if (Type_Code(*Arg) != TC_FUTURE) \
+ { \
Pop_Return_Error(Err_No); \
+ } \
\
while ((Type_Code(*Arg) == TC_FUTURE) && (Future_Has_Value(*Arg))) \
{ \
- if (Future_Is_Keep_Slot(*Arg)) Log_Touch_Of_Future(*Arg); \
+ if (Future_Is_Keep_Slot(*Arg)) \
+ { \
+ Log_Touch_Of_Future(*Arg); \
+ } \
*Arg = Future_Value(*Arg); \
} \
if (Type_Code(*Arg) != TC_FUTURE) \
- goto Prim_No_Trap_Apply; \
+ { \
+ goto Apply_Non_Trapping; \
+ } \
\
Save_Cont(); \
Will_Push(STACK_ENV_EXTRA_SLOTS+2); \
\f
Repeat_Dispatch:
switch (Which_Way)
- { case PRIM_APPLY: goto Internal_Apply;
- case PRIM_NO_TRAP_APPLY: goto Apply_Non_Trapping;
- case PRIM_DO_EXPRESSION: Reduces_To(Fetch_Expression());
- case PRIM_NO_TRAP_EVAL: New_Reduction(Fetch_Expression(),Fetch_Env());
- goto Eval_Non_Trapping;
- case 0: if (!dumped_p) break; /* Else fall through */
- case PRIM_POP_RETURN: goto Pop_Return;
- default: Pop_Return_Error(Which_Way);
+ { case PRIM_APPLY:
+ goto Internal_Apply;
+
+ case PRIM_NO_TRAP_APPLY:
+ goto Apply_Non_Trapping;
+
+ case PRIM_DO_EXPRESSION:
+ Reduces_To(Fetch_Expression());
+
+ case PRIM_NO_TRAP_EVAL:
+ New_Reduction(Fetch_Expression(),Fetch_Env());
+ goto Eval_Non_Trapping;
+
+ case 0:
+ if (!dumped_p)
+ {
+ break;
+ }
+ /* Else fall through */
+
+ case PRIM_POP_RETURN:
+ goto Pop_Return;
+
+ default:
+ Pop_Return_Error(Which_Way);
+
case PRIM_INTERRUPT:
- { Save_Cont();
- Interrupt(IntCode & IntEnb);
+ {
+ Save_Cont();
+ Interrupt(PENDING_INTERRUPTS());
}
- case 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);
- case ERR_ARG_3_WRONG_TYPE: Arg_Type_Error(3, ERR_ARG_3_WRONG_TYPE);
+
+ case 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);
+
+ case ERR_ARG_3_WRONG_TYPE:
+ Arg_Type_Error(3, ERR_ARG_3_WRONG_TYPE);
}
\f
Do_Expression:
case TC_NON_MARKED_VECTOR:
case TC_NULL:
case TC_PRIMITIVE:
- case TC_PRIMITIVE_EXTERNAL:
case TC_PROCEDURE:
case TC_QUAD:
case TC_UNINTERNED_SYMBOL:
/* In case we back out */
Reserve_Stack_Space(); /* CONTINUATION_SIZE */
Finished_Eventual_Pushing(); /* of this primitive */
+ Store_Expression(Make_New_Pointer(TC_PRIMITIVE, Fetch_Expression()));
+ goto Primitive_Internal_Apply;
-Primitive_Internal_Apply:
- if (Microcode_Does_Stepping && Trapping &&
- (Fetch_Apply_Trapper() != NIL))
- {Will_Push(3);
- Push(Fetch_Expression());
- Push(Fetch_Apply_Trapper());
- Push(STACK_FRAME_HEADER + 1 +
- N_Args_Primitive(Get_Integer(Fetch_Expression())));
- Pushed();
- Stop_Trapping();
- goto Apply_Non_Trapping;
- }
-Prim_No_Trap_Apply:
- {
- fast long primitive_code;
-
- primitive_code = Get_Integer(Fetch_Expression());
-
- Export_Regs_Before_Primitive();
- Metering_Apply_Primitive(Val, primitive_code);
- Import_Regs_After_Primitive();
- Pop_Primitive_Frame(N_Args_Primitive(primitive_code));
- if (Must_Report_References())
- { Store_Expression(Val);
- Store_Return(RC_RESTORE_VALUE);
- Save_Cont();
- Call_Future_Logging();
- }
- break;
- }
-\f
case TC_PCOMB1:
Reserve_Stack_Space(); /* 1+CONTINUATION_SIZE */
Do_Nth_Then(RC_PCOMB1_APPLY, PCOMB1_ARG_SLOT, {});
if (temp == PRIM_INTERRUPT)
{
Prepare_Eval_Repeat();
- Interrupt(IntCode & IntEnb);
+ Interrupt(PENDING_INTERRUPTS());
}
Eval_Error(temp);
Pop_Return_Error(Result);
}
Prepare_Pop_Return_Interrupt(RC_EXECUTE_ACCESS_FINISH, value);
- Interrupt(IntCode & IntEnb);
+ Interrupt(PENDING_INTERRUPTS());
}
Val = value;
Pop_Return_Error(ERR_BAD_FRAME);
Prepare_Pop_Return_Interrupt(RC_EXECUTE_ASSIGNMENT_FINISH,
value);
- Interrupt(IntCode & IntEnb);
+ Interrupt(PENDING_INTERRUPTS());
}
/* Interpret() continues on the next page */
{
Prepare_Pop_Return_Interrupt(RC_EXECUTE_DEFINITION_FINISH,
value);
- Interrupt(IntCode & IntEnb);
+ Interrupt(PENDING_INTERRUPTS());
}
Val = value;
Pop_Return_Error(result);
Apply_Non_Trapping:
- if ((IntCode & IntEnb) != 0)
+ if ((PENDING_INTERRUPTS()) != 0)
{
long Interrupts;
- Interrupts = (IntCode & IntEnb);
+ Interrupts = (PENDING_INTERRUPTS());
Store_Expression(NIL);
Val = NIL;
Prepare_Apply_Interrupt();
/*
After checking the number of arguments, remove the
frame header since primitives do not expect it.
+
+ NOTE: This code must match the application code which
+ follows Primitive_Internal_Apply.
*/
case TC_PRIMITIVE:
{
- if (Get_Integer(Stack_Ref(STACK_ENV_HEADER)) !=
- STACK_ENV_FIRST_ARG + N_Args_Primitive(Get_Integer(Function)) - 1)
+ long nargs;
+ fast long primitive_code;
+
+ primitive_code = OBJECT_DATUM(Function);
+ if (primitive_code > MAX_PRIMITIVE)
{
- Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
+ Apply_Error(ERR_UNIMPLEMENTED_PRIMITIVE);
}
- Stack_Pointer = Simulate_Popping(STACK_ENV_FIRST_ARG);
- Store_Expression(Function);
- goto Prim_No_Trap_Apply;
- }
- case TC_PRIMITIVE_EXTERNAL:
- {
- fast long NArgs, Proc;
-
- Proc = Datum(Function);
- if (Proc > MAX_EXTERNAL_PRIMITIVE)
+ /* Note that the 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))
{
- Apply_Error(ERR_UNDEFINED_PRIMITIVE);
+ if (PRIMITIVE_ARITY(primitive_code) != LEXPR_PRIMITIVE_ARITY)
+ {
+ Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
+ }
+ Regs[REGBLOCK_LEXPR_ACTUALS] = ((Pointer) nargs);
}
- NArgs = N_Args_External(Proc);
- if (Get_Integer(Stack_Ref(STACK_ENV_HEADER)) !=
- (NArgs + (STACK_ENV_FIRST_ARG - 1)))
- {
- Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
- }
Stack_Pointer = Simulate_Popping(STACK_ENV_FIRST_ARG);
Store_Expression(Function);
-Repeat_External_Primitive:
- /* Reinitialize Proc in case we "goto Repeat_External..." */
- Proc = Get_Integer(Fetch_Expression());
-
Export_Regs_Before_Primitive();
- Val = Apply_External(Proc);
- Set_Time_Zone(Zone_Working);
+ Metering_Apply_Primitive(Val, primitive_code);
Import_Regs_After_Primitive();
- Pop_Primitive_Frame(N_Args_External(Proc));
+ Pop_Primitive_Frame(nargs);
+ if (Must_Report_References())
+ {
+ Store_Expression(Val);
+ Store_Return(RC_RESTORE_VALUE);
+ Save_Cont();
+ Call_Future_Logging();
+ }
goto Pop_Return;
}
}
case PRIM_INTERRUPT:
- { compiled_error_backout();
+ {
+ compiled_error_backout();
Save_Cont();
- Interrupt( (IntCode & IntEnb));
+ Interrupt(PENDING_INTERRUPTS());
}
\f
case ERR_WRONG_NUMBER_OF_ARGUMENTS:
- { apply_compiled_backout();
+ {
+ apply_compiled_backout();
Apply_Error( Which_Way);
}
+ case ERR_UNIMPLEMENTED_PRIMITIVE:
+ {
+ /* 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;
+ }
+\f
case ERR_EXECUTE_MANIFEST_VECTOR:
{ /* This error code means that enter_compiled_expression
was called in a system without compiler support.
Push(Val); /* Argument value */
Finished_Eventual_Pushing();
Store_Expression(Fast_Vector_Ref(Fetch_Expression(), PCOMB1_FN_SLOT));
- goto Primitive_Internal_Apply;
+Primitive_Internal_Apply:
+ if (Microcode_Does_Stepping && Trapping &&
+ (Fetch_Apply_Trapper() != NIL))
+ {
+ /* Does this work in the stacklet case?
+ We may have a non-contiguous frame. -- Jinx
+ */
+ Will_Push(3);
+ Push(Fetch_Expression());
+ Push(Fetch_Apply_Trapper());
+ Push(STACK_FRAME_HEADER + 1 +
+ PRIMITIVE_N_PARAMETERS(OBJECT_DATUM(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.
+ */
+ {
+ 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);
+ }
+
+ Export_Regs_Before_Primitive();
+ Metering_Apply_Primitive(Val, primitive_code);
+ Import_Regs_After_Primitive();
+
+ Pop_Primitive_Frame(PRIMITIVE_ARITY(primitive_code));
+ if (Must_Report_References())
+ {
+ Store_Expression(Val);
+ Store_Return(RC_RESTORE_VALUE);
+ Save_Cont();
+ Call_Future_Logging();
+ }
+ break;
+ }
+\f
case RC_PCOMB2_APPLY:
End_Subproblem();
Push(Val); /* Value of arg. 1 */
Restore_Cont();
goto Repeat_Dispatch;
- case RC_REPEAT_PRIMITIVE:
- if (Type_Code(Fetch_Expression()) == TC_PRIMITIVE_EXTERNAL)
- goto Repeat_External_Primitive;
- else goto Primitive_Internal_Apply;
-
/* Interpret() continues on the next page */
\f
/* Interpret(), continued */
*/
case RC_RESTORE_DONT_COPY_HISTORY:
- { Pointer Stacklet;
+ {
+ Pointer Stacklet;
+
Prev_Restore_History_Offset = Get_Integer(Pop());
Stacklet = Pop();
History = Get_Pointer(Fetch_Expression());
if (Prev_Restore_History_Offset == 0)
+ {
Prev_Restore_History_Stacklet = NULL;
+ }
else if (Stacklet == NIL)
+ {
Prev_Restore_History_Stacklet = NULL;
+ }
else
+ {
Prev_Restore_History_Stacklet = Get_Pointer(Stacklet);
+ }
break;
}
case RC_RESTORE_FLUIDS:
Fluid_Bindings = Fetch_Expression();
- New_Compiler_MemTop();
+ /* Why is this here? -- Jinx */
+ COMPILER_SETUP_INTERRUPT();
break;
case RC_RESTORE_INT_MASK:
- IntEnb = Get_Integer(Fetch_Expression());
- New_Compiler_MemTop();
+ SET_INTERRUPT_MASK(Get_Integer(Fetch_Expression()));
break;
/* Interpret() continues on the next page */
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.25 1987/10/09 16:12:22 jinx Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/interp.h,v 9.26 1987/11/17 08:13:39 jinx Exp $
*
* Macros used by the interpreter and some utilities.
*
\f
/* Primitive utility macros */
+/* The first two are only valid for implemented primitives. */
+
#define Internal_Apply_Primitive(primitive_code) \
((*(Primitive_Procedure_Table[primitive_code]))())
-#define N_Args_Primitive(primitive_code) \
+#define PRIMITIVE_ARITY(primitive_code) \
(Primitive_Arity_Table[primitive_code])
-#define Internal_Apply_External(external_code) \
- ((*(External_Procedure_Table[external_code]))())
+extern long primitive_to_arity();
+
+#define PRIMITIVE_N_PARAMETERS(primitive_code) \
+ (primitive_to_arity(primitive_code))
+
+/* This is only valid during a primitive call. */
-#define N_Args_External(external_code) \
- (External_Arity_Table[external_code])
+extern long primitive_to_arguments();
-#define Apply_External(N) \
- Internal_Apply_External(N)
+#define PRIMITIVE_N_ARGUMENTS(primitive_code) \
+ (primitive_to_arguments(primitive_code))
#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/list.c,v 9.24 1987/10/09 16:12:36 jinx Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/list.c,v 9.25 1987/11/17 08:13:49 jinx Rel $
*
* List creation and manipulation primitives.
*/
RIGHT.
*/
Built_In_Primitive(Prim_Cons, 2, "CONS", 0x20)
+Define_Primitive(Prim_Cons, 2, "CONS")
{
Primitive_2_Args();
Returns the second element in the pair.
*/
Built_In_Primitive(Prim_Cdr, 1, "CDR", 0x22)
+Define_Primitive(Prim_Cdr, 1, "CDR")
{
Primitive_1_Arg();
Returns the first element in the pair.
*/
Built_In_Primitive(Prim_Car, 1, "CAR", 0x21)
+Define_Primitive(Prim_Car, 1, "CAR")
{
Primitive_1_Arg();
100 = CDDR ...
*/
Built_In_Primitive(Prim_General_Car_Cdr, 2, "GENERAL-CAR-CDR", 0x27)
+Define_Primitive(Prim_General_Car_Cdr, 2, "GENERAL-CAR-CDR")
{
fast long CAR_CDR_Pattern;
Primitive_2_Args();
of the list whose CAAR is ITEM.
*/
Built_In_Primitive(Prim_Assq, 2, "ASSQ", 0x5E)
+Define_Primitive(Prim_Assq, 2, "ASSQ")
{
Pointer This_Assoc_Pair, Key;
Primitive_2_Args();
LENGTH will loop forever if given a circular structure.
*/
Built_In_Primitive(Prim_Length, 1, "LENGTH", 0x5D)
+Define_Primitive(Prim_Length, 1, "LENGTH")
{
fast long i;
Primitive_1_Arg();
is not found, or the sublist of LIST whose CAR is ITEM.
*/
Built_In_Primitive(Prim_Memq, 2, "MEMQ", 0x1C)
+Define_Primitive(Prim_Memq, 2, "MEMQ")
{
fast Pointer Key;
Primitive_2_Args();
Stores VALUE in the CAR of PAIR. Returns the previous CAR of PAIR.
*/
Built_In_Primitive(Prim_Set_Car, 2, "SET-CAR!", 0x23)
+Define_Primitive(Prim_Set_Car, 2, "SET-CAR!")
{
Primitive_2_Args();
Stores VALUE in the CDR of PAIR. Returns the previous CDR of PAIR.
*/
Built_In_Primitive(Prim_Set_Cdr, 2, "SET-CDR!", 0x24)
+Define_Primitive(Prim_Set_Cdr, 2, "SET-CDR!")
{
Primitive_2_Args();
created by CONS). Returns NIL otherwise.
*/
Built_In_Primitive(Prim_Pair, 1, "PAIR?", 0x7E)
+Define_Primitive(Prim_Pair, 1, "PAIR?")
{
Primitive_1_Arg();
Returns #!TRUE if the garbage collector type of OBJECT is PAIR.
*/
Built_In_Primitive(Prim_Sys_Pair, 1, "SYSTEM-PAIR?", 0x85)
+Define_Primitive(Prim_Sys_Pair, 1, "SYSTEM-PAIR?")
{
Primitive_1_Arg();
Same as CAR, but for anything of GC type PAIR.
*/
Built_In_Primitive(Prim_Sys_Pair_Car, 1, "SYSTEM-PAIR-CAR", 0x86)
+Define_Primitive(Prim_Sys_Pair_Car, 1, "SYSTEM-PAIR-CAR")
{
Primitive_1_Arg();
Same as CDR, but for anything of GC type PAIR.
*/
Built_In_Primitive(Prim_Sys_Pair_Cdr, 1, "SYSTEM-PAIR-CDR", 0x87)
+Define_Primitive(Prim_Sys_Pair_Cdr, 1, "SYSTEM-PAIR-CDR")
{
Primitive_1_Arg();
(not limited to type code LIST).
*/
Built_In_Primitive(Prim_Sys_Pair_Cons, 3, "SYSTEM-PAIR-CONS", 0x84)
+Define_Primitive(Prim_Sys_Pair_Cons, 3, "SYSTEM-PAIR-CONS")
{
long Type;
Primitive_3_Args();
Same as SET-CAR!, but for anything of GC type PAIR.
*/
Built_In_Primitive(Prim_Sys_Set_Car, 2, "SYSTEM-PAIR-SET-CAR!", 0x88)
+Define_Primitive(Prim_Sys_Set_Car, 2, "SYSTEM-PAIR-SET-CAR!")
{
Primitive_2_Args();
Same as SET-CDR!, but for anything of GC type PAIR.
*/
Built_In_Primitive(Prim_Sys_Set_Cdr, 2, "SYSTEM-PAIR-SET-CDR!", 0x89)
+Define_Primitive(Prim_Sys_Set_Cdr, 2, "SYSTEM-PAIR-SET-CDR!")
{
Primitive_2_Args();
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/load.c,v 9.23 1987/06/05 04:15:09 jinx Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/load.c,v 9.24 1987/11/17 08:14:00 jinx Rel $
*
* This file contains common code for reading internal
* format binary files.
\f
#include "fasl.h"
+#ifndef BYTE_INVERSION
+
+#define NORMALIZE_HEADER(header, size, base, count)
+#define NORMALIZE_REGION(region, size)
+
+#else
+
+void Byte_Invert_Region(), Byte_Invert_Header();
+
+#define NORMALIZE_HEADER Byte_Invert_Header
+#define NORMALIZE_REGION Byte_Invert_Region
+
+#endif
+
/* Static storage for some shared variables */
-long Heap_Count, Const_Count,
- Version, Sub_Version, Machine_Type, Ext_Prim_Count,
- Heap_Base, Const_Base, Dumped_Object,
- Dumped_Heap_Top, Dumped_Constant_Top, Dumped_Stack_Top;
-Pointer Ext_Prim_Vector;
-Boolean Found_Ext_Prims, Byte_Invert_Fasl_Files;
+static long
+ Version, Sub_Version, Machine_Type,
+ Dumped_Object,
+ Heap_Base, Heap_Count,
+ Const_Base, Const_Count,
+ Dumped_Heap_Top, Dumped_Constant_Top,
+ Dumped_Stack_Top,
+ Primitive_Table_Size, Primitive_Table_Length;
+static Pointer Ext_Prim_Vector;
+\f
Boolean
Read_Header()
{
Pointer Buffer[FASL_HEADER_LENGTH];
Pointer Pointer_Heap_Base, Pointer_Const_Base;
- if (Load_Data(FASL_OLD_LENGTH, ((char *) Buffer)) !=
- FASL_OLD_LENGTH)
- return false;
+ if (Load_Data(FASL_HEADER_LENGTH, ((char *) Buffer)) !=
+ FASL_HEADER_LENGTH)
+ {
+ return (false);
+ }
if (Buffer[FASL_Offset_Marker] != FASL_FILE_MARKER)
- return false;
-#ifdef BYTE_INVERSION
- Byte_Invert_Header(Buffer,
- (sizeof(Buffer) / sizeof(Pointer)),
- Buffer[FASL_Offset_Heap_Base],
- Buffer[FASL_Offset_Heap_Count]);
-#endif
+ {
+ return (false);
+ }
+ NORMALIZE_HEADER(Buffer,
+ (sizeof(Buffer) / sizeof(Pointer)),
+ Buffer[FASL_Offset_Heap_Base],
+ Buffer[FASL_Offset_Heap_Count]);
Heap_Count = Get_Integer(Buffer[FASL_Offset_Heap_Count]);
Pointer_Heap_Base = Buffer[FASL_Offset_Heap_Base];
Heap_Base = Datum(Pointer_Heap_Base);
C_To_Scheme(Nth_Vector_Loc(Pointer_Heap_Base, Heap_Count));
Dumped_Constant_Top =
C_To_Scheme(Nth_Vector_Loc(Pointer_Const_Base, Const_Count));
- if (Load_Data((FASL_HEADER_LENGTH - FASL_OLD_LENGTH),
- ((char *) &(Buffer[FASL_OLD_LENGTH]))) !=
- (FASL_HEADER_LENGTH - FASL_OLD_LENGTH))
- return false;
-#ifdef BYTE_INVERSION
- Byte_Invert_Region(((char *) &(Buffer[FASL_OLD_LENGTH])),
- (FASL_HEADER_LENGTH - FASL_OLD_LENGTH));
-#endif
- Ext_Prim_Vector =
- Make_Non_Pointer(TC_CELL, Datum(Buffer[FASL_Offset_Ext_Loc]));
+\f
+ if (Sub_Version < FASL_MERGED_PRIMITIVES)
+ {
+ Primitive_Table_Length = 0;
+ Primitive_Table_Size = 0;
+ Ext_Prim_Vector =
+ Make_Non_Pointer(TC_CELL, Datum(Buffer[FASL_Offset_Ext_Loc]));
+ }
+ else
+ {
+ Primitive_Table_Length = Get_Integer(Buffer[FASL_Offset_Prim_Length]);
+ Primitive_Table_Size = Get_Integer(Buffer[FASL_Offset_Prim_Size]);
+ Ext_Prim_Vector = NIL;
+ }
if (Reloc_or_Load_Debug)
{
printf("\nHeap_Count = %d; Heap_Base = %x; Dumped_Heap_Top = %x\n",
printf("Dumped_S_Top = %x, Ext_Prim_Vector = 0x%08x\n",
Dumped_Stack_Top, Ext_Prim_Vector);
printf("Dumped Object (as read from file) = %x\n", Dumped_Object);
+ printf("Length of primitive table = %d\n", Primitive_Table_Length);
}
- return true;
-}
+#ifndef INHIBIT_FASL_VERSION_CHECK
+#ifdef BYTE_INVERSION
+ if ((Version != FASL_READ_VERSION) ||
+ (Sub_Version != FASL_READ_SUBVERSION))
+#else
+ if ((Version != FASL_READ_VERSION) ||
+ (Sub_Version != FASL_READ_SUBVERSION) ||
+ (Machine_Type != FASL_INTERNAL_FORMAT))
+#endif
+ {
+ fprintf(stderr,
+ "\nread_file: FASL File Version %4d Subversion %4d Machine Type %4d.\n",
+ Version, Sub_Version , Machine_Type);
+ fprintf(stderr,
+ " Expected: Version %4d Subversion %4d Machine Type %4d.\n",
+ FASL_READ_VERSION, FASL_READ_SUBVERSION, FASL_INTERNAL_FORMAT);
+
+ return (false);
+ }
+#endif
+
+ return (true);
+}
+\f
#ifdef BYTE_INVERSION
+static Boolean Byte_Invert_Fasl_Files;
+
+void
Byte_Invert_Header(Header, Headsize, Test1, Test2)
long *Header, Headsize, Test1, Test2;
{
Byte_Invert_Fasl_Files = true;
Byte_Invert_Region(Header, Headsize);
}
+ return;
}
+void
Byte_Invert_Region(Region, Size)
long *Region, Size;
{
register long word, size;
if (Byte_Invert_Fasl_Files)
+ {
for (size = Size; size > 0; size--, Region++)
{
word = (*Region);
*Region = (((word>>24)&0xff) | ((word>>8)&0xff00) |
((word<<8)&0xff0000) | ((word<<24)&0xff000000));
}
+ }
+ return;
}
#endif
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/lookup.c,v 9.37 1987/11/04 20:01:34 cph Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/lookup.c,v 9.38 1987/11/17 08:14:11 jinx Rel $
*
* This file contains symbol lookup and modification routines. See
* Hal Abelson for a paper describing and justifying the algorithm.
(set! <symbol> <value>) in <environment>.
*/
Built_In_Primitive(Prim_Lexical_Assignment, 3, "LEXICAL-ASSIGNMENT", 0x0)
+Define_Primitive(Prim_Lexical_Assignment, 3, "LEXICAL-ASSIGNMENT")
{
Primitive_3_Args();
Indistinguishable from evaluating <symbol> in <environment>.
*/
Built_In_Primitive(Prim_Lexical_Reference, 2, "LEXICAL-REFERENCE", 0x12)
+Define_Primitive(Prim_Lexical_Reference, 2, "LEXICAL-REFERENCE")
{
Primitive_2_Args();
Identical to LEXICAL_REFERENCE, here for histerical reasons.
*/
Built_In_Primitive(Prim_Local_Reference, 2, "LOCAL-REFERENCE", 0x1)
+Define_Primitive(Prim_Local_Reference, 2, "LOCAL-REFERENCE")
{
Primitive_2_Args();
(define <symbol> <value>) in <environment>.
*/
Built_In_Primitive(Prim_Local_Assignment, 3, "LOCAL-ASSIGNMENT", 0x2)
+Define_Primitive(Prim_Local_Assignment, 3, "LOCAL-ASSIGNMENT")
{
Primitive_3_Args();
The special form (unassigned? <symbol>) is built on top of this.
*/
Built_In_Primitive(Prim_Unassigned_Test, 2, "LEXICAL-UNASSIGNED?", 0x18)
+Define_Primitive(Prim_Unassigned_Test, 2, "LEXICAL-UNASSIGNED?")
{
Primitive_2_Args();
The special form (unbound? <symbol>) is built on top of this.
*/
Built_In_Primitive(Prim_Unbound_Test, 2, "LEXICAL-UNBOUND?", 0x33)
+Define_Primitive(Prim_Unbound_Test, 2, "LEXICAL-UNBOUND?")
{
Primitive_2_Args();
*/
Built_In_Primitive(Prim_Unreferenceable_Test, 2,
"LEXICAL-UNREFERENCEABLE?", 0x13)
+Define_Primitive(Prim_Unreferenceable_Test, 2,
+ "LEXICAL-UNREFERENCEABLE?")
{
long Result;
Primitive_2_Args();
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.31 1987/10/09 16:12:45 jinx Rel $ */
+/* $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 $ */
/* Memory management top level.
Heap_Top = (Heap_Bottom + Our_Heap_Size);
Local_Heap_Base = Heap_Bottom;
Unused_Heap_Top = (Heap_Bottom + (2 * Our_Heap_Size));
- Set_Mem_Top (Heap_Top - GC_Reserve);
+ SET_MEMTOP(Heap_Top - GC_Reserve);
Free = Heap_Bottom;
Constant_Top = (Constant_Space + Our_Constant_Size);
Free_Constant = Constant_Space;
Unused_Heap_Top = Heap_Top;
Heap_Top = Temp;
Free = Heap_Bottom;
- Set_Mem_Top(Heap_Top - GC_Reserve);
+ SET_MEMTOP(Heap_Top - GC_Reserve);
Weak_Chain = NIL;
return;
}
*/
\f
void GC()
-{ Pointer *Root, *Result, *Check_Value,
- The_Precious_Objects, *Root2;
+{
+ Pointer
+ *Root, *Result, *Check_Value,
+ The_Precious_Objects, *Root2;
/* Save the microcode registers so that they can be relocated */
+
Terminate_Old_Stacklet();
Terminate_Constant_Space(Check_Value);
*Free++ = Fixed_Objects;
*Free++ = Make_Pointer(UNMARKED_HISTORY_TYPE, History);
- *Free++ = Undefined_Externals;
+ *Free++ = Undefined_Primitives;
+ *Free++ = Undefined_Primitives_Arity;
*Free++ = Get_Current_Stacklet();
*Free++ = ((Prev_Restore_History_Stacklet == NULL) ?
NIL :
*Free++ = Fluid_Bindings;
/* The 4 step GC */
+
Result = GCLoop(Constant_Space, &Free);
if (Result != Check_Value)
{
fprintf(stderr, "\nGC: Constant Scan ended too early.\n");
Microcode_Termination(TERM_BROKEN_HEART);
}
+
Result = GCLoop(Root, &Free);
if (Free != Result)
{
fprintf(stderr, "\nGC-1: Heap Scan ended too early.\n");
Microcode_Termination(TERM_BROKEN_HEART);
}
+\f
Root2 = Free;
*Free++ = The_Precious_Objects;
Result = GCLoop(Root2, &Free);
fprintf(stderr, "\nGC-2: Heap Scan ended too early.\n");
Microcode_Termination(TERM_BROKEN_HEART);
}
+
Fix_Weak_Chain();
/* Make the microcode registers point to the copies in new-space. */
+
Fixed_Objects = *Root++;
Set_Fixed_Obj_Slot(Precious_Objects, *Root2);
Set_Fixed_Obj_Slot(Lost_Objects_Base, Make_Pointer(TC_ADDRESS, Root2));
History = Get_Pointer(*Root++);
- Undefined_Externals = *Root++;
+ Undefined_Primitives = *Root++;
+ Undefined_Primitives_Arity = *Root++;
+
+ /* Set_Current_Stacklet is sometimes a No-Op! */
Set_Current_Stacklet(*Root);
- Root += 1; /* Set_Current_Stacklet is sometimes a No-Op! */
+ Root += 1;
if (*Root == NIL)
{
Prev_Restore_History_Stacklet = NULL;
Root += 1;
}
else
+ {
Prev_Restore_History_Stacklet = Get_Pointer(*Root++);
+ }
Current_State_Point = *Root++;
Fluid_Bindings = *Root++;
Free_Stacklets = NULL;
*/
Built_In_Primitive(Prim_Garbage_Collect, 1, "GARBAGE-COLLECT", 0x3A)
+Define_Primitive(Prim_Garbage_Collect, 1, "GARBAGE-COLLECT")
{
Pointer GC_Daemon_Proc;
Primitive_1_Arg();
GC_Reserve = Get_Integer(Arg1);
GCFlip();
GC();
- IntCode &= ~INT_GC;
+ CLEAR_INTERRUPT(INT_GC);
Pop_Primitive_Frame(1);
GC_Daemon_Proc = Get_Fixed_Obj_Slot(GC_Daemon);
if (GC_Daemon_Proc == 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/Attic/ppband.c,v 9.28 1987/10/09 16:08:24 jinx Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/ppband.c,v 9.29 1987/11/17 08:04:37 jinx Rel $
*
* Dumps Scheme FASL in user-readable form .
*/
-\f
-#include "scheme.h"
+#include <stdio.h>
+#include "config.h"
+#include "types.h"
+#include "const.h"
+#include "object.h"
+#include "sdata.h"
+
+#define fast register
+\f
/* These are needed by load.c */
static Pointer *Memory_Base;
\f
#define Reloc_or_Load_Debug true
+#include "fasl.h"
#include "load.c"
-#include "gctype.c"
#ifdef Heap_In_Low_Memory
#ifdef spectrum
#define Relocate(P) \
(((long) (P) < Const_Base) ? \
File_To_Pointer(((long) (P)) - Heap_Base) : \
- (Heap_Count+File_To_Pointer(((long) (P)) - Const_Base)))
+ (Heap_Count + File_To_Pointer(((long) (P)) - Const_Base)))
#else
#define Relocate_Into(What, P)
if (((long) (P)) < Const_Base)
fast long i, Count;
fast char *Chars;
- Chars = (char *) &Data[From+STRING_CHARS];
+ Chars = ((char *) &Data[From + STRING_CHARS]);
if (Chars < ((char *) end_of_memory))
- { Count = Get_Integer(Data[From+STRING_LENGTH]);
+ {
+ Count = ((long) (Data[From + STRING_LENGTH]));
if (&Chars[Count] < ((char *) end_of_memory))
- { putchar(Quoted ? '\"' : '\'');
- for (i=0; i < Count; i++) printf("%c", *Chars++);
- if (Quoted) putchar('\"');
+ {
+ if (Quoted)
+ {
+ putchar('\"');
+ }
+ for (i = 0; i < Count; i++)
+ {
+ printf("%c", *Chars++);
+ }
+ if (Quoted)
+ {
+ putchar('\"');
+ }
putchar('\n');
- return true;
+ return (true);
}
}
if (Quoted)
- printf("String not in memory; datum = %x\n", From);
- return false;
+ {
+ printf("String not in memory; datum = %lx\n", From);
+ }
+ return (false);
}
#define via(File_Address) Relocate(OBJECT_DATUM(Data[File_Address]))
symbol = &Data[From+SYMBOL_NAME];
if ((symbol >= end_of_memory) ||
- !scheme_string(via(From+SYMBOL_NAME), false))
- printf("symbol not in memory; datum = %x\n", From);
+ (!(scheme_string(via(From + SYMBOL_NAME), false))))
+ {
+ printf("symbol not in memory; datum = %lx\n", From);
+ }
return;
}
\f
+static char string_buffer[10];
+
+#define PRINT_OBJECT(type, datum) \
+{ \
+ printf("[%s %lx]", type, datum); \
+}
+
+#define NON_POINTER(string) \
+{ \
+ the_string = string; \
+ Points_To = The_Datum; \
+ break; \
+}
+
+#define POINTER(string) \
+{ \
+ the_string = string; \
+ break; \
+}
+
void
Display(Location, Type, The_Datum)
long Location, Type, The_Datum;
{
+ char *the_string;
long Points_To;
- printf("%5x: %2x|%6x ", Location, Type, The_Datum);
- if (GC_Type_Map[Type] != GC_Non_Pointer)
- Points_To = Relocate((Pointer *) The_Datum);
- else
- Points_To = The_Datum;
+ printf("%5lx: %2lx|%6lx ", Location, Type, The_Datum);
+ Points_To = Relocate((Pointer *) The_Datum);
+
switch (Type)
{ /* "Strange" cases */
- case TC_NULL: if (The_Datum == 0)
- { printf("NIL\n");
- return;
- }
- else printf("[NULL ");
- break;
- case TC_TRUE: if (The_Datum == 0)
- { printf("TRUE\n");
- return;
- }
- else printf("[TRUE ");
- break;
- case TC_BROKEN_HEART: printf("[BROKEN-HEART ");
- if (The_Datum == 0)
- Points_To = 0;
- break;
- case TC_MANIFEST_SPECIAL_NM_VECTOR: printf("[MANIFEST-SPECIAL-NM ");
- Points_To = The_Datum;
- break;
- case TC_MANIFEST_NM_VECTOR: printf("[MANIFEST-NM-VECTOR ");
- Points_To = The_Datum;
- break;
- case TC_INTERNED_SYMBOL: scheme_symbol(Points_To);
- return;
+ case TC_NULL:
+ if (The_Datum == 0)
+ {
+ printf("NIL\n");
+ return;
+ }
+ NON_POINTER("NULL");
+
+ case TC_TRUE:
+ if (The_Datum == 0)
+ {
+ printf("TRUE\n");
+ return;
+ }
+ NON_POINTER("TRUE");
+
+ case TC_MANIFEST_SPECIAL_NM_VECTOR:
+ NON_POINTER("MANIFEST-SPECIAL-NM");
+
+ case TC_MANIFEST_NM_VECTOR:
+ NON_POINTER("MANIFEST-NM-VECTOR");
+\f
+ case TC_BROKEN_HEART:
+ if (The_Datum == 0)
+ {
+ Points_To = 0;
+ }
+ POINTER("BROKEN-HEART");
+
+ case TC_INTERNED_SYMBOL:
+ PRINT_OBJECT("INTERNED-SYMBOL", Points_To);
+ printf(" = ");
+ scheme_symbol(Points_To);
+ return;
+
case TC_UNINTERNED_SYMBOL:
- printf("uninterned ");
+ PRINT_OBJECT("UNINTERNED-SYMBOL", Points_To);
+ printf(" = ");
scheme_symbol(Points_To);
return;
- case TC_CHARACTER_STRING: scheme_string(Points_To, true);
- return;
- case TC_FIXNUM: printf("%d\n", Points_To);
- return;
-
- /* Default cases */
- case TC_LIST: printf("[LIST "); break;
- case TC_CHARACTER: printf("[CHARACTER "); break;
- case TC_SCODE_QUOTE: printf("[SCODE-QUOTE "); break;
- case TC_PCOMB2: printf("[PCOMB2 "); break;
- case TC_BIG_FLONUM: printf("[BIG-FLONUM "); break;
- case TC_COMBINATION_1: printf("[COMBINATION-1 "); break;
- case TC_EXTENDED_PROCEDURE: printf("[EXTENDED-PROCEDURE "); break;
- case TC_VECTOR: printf("[VECTOR "); break;
- case TC_RETURN_CODE: printf("[RETURN-CODE "); break;
- case TC_COMBINATION_2: printf("[COMBINATION-2 "); break;
- case TC_COMPILED_PROCEDURE: printf("[COMPILED-PROCEDURE "); break;
- case TC_BIG_FIXNUM: printf("[BIG-FIXNUM "); break;
- case TC_PROCEDURE: printf("[PROCEDURE "); break;
- case TC_PRIMITIVE_EXTERNAL: printf("[PRIMITIVE-EXTERNAL "); break;
- case TC_DELAY: printf("[DELAY "); break;
- case TC_ENVIRONMENT: printf("[ENVIRONMENT "); break;
- case TC_DELAYED: printf("[DELAYED "); break;
- case TC_EXTENDED_LAMBDA: printf("[EXTENDED-LAMBDA "); break;
- case TC_COMMENT: printf("[COMMENT "); break;
- case TC_NON_MARKED_VECTOR: printf("[NON-MARKED-VECTOR "); break;
- case TC_LAMBDA: printf("[LAMBDA "); break;
- case TC_PRIMITIVE: printf("[PRIMITIVE "); break;
- case TC_SEQUENCE_2: printf("[SEQUENCE-2 "); break;
- case TC_PCOMB1: printf("[PCOMB1 "); break;
- case TC_CONTROL_POINT: printf("[CONTROL-POINT "); break;
- case TC_ACCESS: printf("[ACCESS "); break;
- case TC_DEFINITION: printf("[DEFINITION "); break;
- case TC_ASSIGNMENT: printf("[ASSIGNMENT "); break;
- case TC_HUNK3_A: printf("[HUNK3_A "); break;
- case TC_HUNK3_B: printf("[HUNK3_B "); break;
- case TC_IN_PACKAGE: printf("[IN-PACKAGE "); break;
- case TC_COMBINATION: printf("[COMBINATION "); break;
- case TC_COMPILED_EXPRESSION: printf("[COMPILED-EXPRESSION "); break;
- case TC_LEXPR: printf("[LEXPR "); break;
- case TC_PCOMB3: printf("[PCOMB3 "); break;
-
- case TC_VARIABLE: printf("[VARIABLE "); break;
- case TC_THE_ENVIRONMENT: printf("[THE-ENVIRONMENT "); break;
- case TC_FUTURE: printf("[FUTURE "); break;
- case TC_VECTOR_1B: printf("[VECTOR-1B "); break;
- case TC_PCOMB0: printf("[PCOMB0 "); break;
- case TC_VECTOR_16B: printf("[VECTOR-16B "); break;
- case TC_SEQUENCE_3: printf("[SEQUENCE-3 "); break;
- case TC_CONDITIONAL: printf("[CONDITIONAL "); break;
- case TC_DISJUNCTION: printf("[DISJUNCTION "); break;
- case TC_CELL: printf("[CELL "); break;
- case TC_WEAK_CONS: printf("[WEAK-CONS "); break;
- case TC_REFERENCE_TRAP: printf("[REFERENCE-TRAP "); break;
- case TC_RETURN_ADDRESS: printf("[RETURN-ADDRESS "); break;
- case TC_COMPILER_LINK: printf("[COMPILER-LINK "); break;
- case TC_STACK_ENVIRONMENT: printf("[STACK-ENVIRONMENT "); break;
- case TC_COMPLEX: printf("[COMPLEX "); break;
- case TC_QUAD: printf("[QUAD "); break;
-
- default: printf("[0x%02x ", Type); break;
+
+ case TC_CHARACTER_STRING:
+ PRINT_OBJECT("CHARACTER-STRING", Points_To);
+ printf(" = ");
+ scheme_string(Points_To, true);
+ return;
+
+ case TC_FIXNUM:
+ PRINT_OBJECT("FIXNUM", The_Datum);
+ Sign_Extend(The_Datum, Points_To);
+ printf(" = %ld\n", Points_To);
+ return;
+
+ case TC_REFERENCE_TRAP:
+ if (The_Datum <= TRAP_MAX_IMMEDIATE)
+ {
+ NON_POINTER("REFERENCE-TRAP");
+ }
+ else
+ {
+ POINTER("REFERENCE-TRAP");
+ }
+
+ case TC_CHARACTER: NON_POINTER("CHARACTER");
+ case TC_RETURN_CODE: NON_POINTER("RETURN-CODE");
+ case TC_PRIMITIVE: NON_POINTER("PRIMITIVE");
+ case TC_THE_ENVIRONMENT: NON_POINTER("THE-ENVIRONMENT");
+ case TC_PCOMB0: NON_POINTER("PCOMB0");
+ case TC_LIST: POINTER("LIST");
+ case TC_SCODE_QUOTE: POINTER("SCODE-QUOTE");
+ case TC_PCOMB2: POINTER("PCOMB2");
+ case TC_BIG_FLONUM: POINTER("FLONUM");
+\f
+ case TC_COMBINATION_1: POINTER("COMBINATION-1");
+ case TC_EXTENDED_PROCEDURE: POINTER("EXTENDED-PROCEDURE");
+ case TC_VECTOR: POINTER("VECTOR");
+ case TC_COMBINATION_2: POINTER("COMBINATION-2");
+ case TC_COMPILED_PROCEDURE: POINTER("COMPILED-PROCEDURE");
+ case TC_BIG_FIXNUM: POINTER("BIG-FIXNUM");
+ case TC_PROCEDURE: POINTER("PROCEDURE");
+ case TC_DELAY: POINTER("DELAY");
+ case TC_ENVIRONMENT: POINTER("ENVIRONMENT");
+ case TC_DELAYED: POINTER("DELAYED");
+ case TC_EXTENDED_LAMBDA: POINTER("EXTENDED-LAMBDA");
+ case TC_COMMENT: POINTER("COMMENT");
+ case TC_NON_MARKED_VECTOR: POINTER("NON-MARKED-VECTOR");
+ case TC_LAMBDA: POINTER("LAMBDA");
+ case TC_SEQUENCE_2: POINTER("SEQUENCE-2");
+ case TC_PCOMB1: POINTER("PCOMB1");
+ case TC_CONTROL_POINT: POINTER("CONTROL-POINT");
+ case TC_ACCESS: POINTER("ACCESS");
+ case TC_DEFINITION: POINTER("DEFINITION");
+ case TC_ASSIGNMENT: POINTER("ASSIGNMENT");
+ case TC_HUNK3_A: POINTER("HUNK3_A");
+ case TC_HUNK3_B: POINTER("HUNK3-B");
+ case TC_IN_PACKAGE: POINTER("IN-PACKAGE");
+ case TC_COMBINATION: POINTER("COMBINATION");
+ case TC_COMPILED_EXPRESSION: POINTER("COMPILED-EXPRESSION");
+ case TC_LEXPR: POINTER("LEXPR");
+ case TC_PCOMB3: POINTER("PCOMB3");
+ case TC_VARIABLE: POINTER("VARIABLE");
+ case TC_FUTURE: POINTER("FUTURE");
+ case TC_VECTOR_1B: POINTER("VECTOR-1B");
+ case TC_VECTOR_16B: POINTER("VECTOR-16B");
+ case TC_SEQUENCE_3: POINTER("SEQUENCE-3");
+ case TC_CONDITIONAL: POINTER("CONDITIONAL");
+ case TC_DISJUNCTION: POINTER("DISJUNCTION");
+ case TC_CELL: POINTER("CELL");
+ case TC_WEAK_CONS: POINTER("WEAK-CONS");
+ case TC_RETURN_ADDRESS: POINTER("RETURN-ADDRESS");
+ case TC_COMPILER_LINK: POINTER("COMPILER_LINK");
+ case TC_STACK_ENVIRONMENT: POINTER("STACK-ENVIRONMENT");
+ case TC_COMPLEX: POINTER("COMPLEX");
+ case TC_QUAD: POINTER("QUAD");
+ case TC_COMPILED_CODE_BLOCK: POINTER("COMPILED-CODE-BLOCK");
+
+ default:
+ sprintf(&the_string[0], "0x%02lx ", Type);
+ POINTER(&the_string[0]);
}
- printf("%x]\n", Points_To);
+ PRINT_OBJECT(the_string, Points_To);
+ putchar('\n');
+ return;
}
+\f
+Pointer *
+show_area(area, size, name)
+ fast Pointer *area;
+ fast long size;
+ char *name;
+{
+ fast long i;
+ printf("\n%s contents:\n\n", name);
+ for (i = 0; i < size; area++, i++)
+ {
+ if (OBJECT_TYPE(*area) == TC_MANIFEST_NM_VECTOR)
+ {
+ fast long j, count;
+
+ count = Get_Integer(*area);
+ Display(i, OBJECT_TYPE(*area), OBJECT_DATUM(*area));
+ area += 1;
+ for (j = 0; j < count ; j++, area++)
+ {
+ printf(" %02lx%06lx\n",
+ OBJECT_TYPE(*area), OBJECT_DATUM(*area));
+ }
+ i += count;
+ area -= 1;
+ }
+ else
+ {
+ Display(i, OBJECT_TYPE(*area), OBJECT_DATUM(*area));
+ }
+ }
+ return (area);
+}
+\f
main(argc, argv)
int argc;
char **argv;
{
- Pointer *Next;
- long i, total_length;
+ fast Pointer *Next;
+ long total_length, load_length;
if (argc == 1)
{
if (!Read_Header())
- { fprintf(stderr, "Input does not appear to be in FASL format.\n");
+ {
+ fprintf(stderr,
+ "%s: Input does not appear to be in correct FASL format.\n",
+ argv[0]);
exit(1);
}
- printf("Dumped object at 0x%x\n", Relocate(Dumped_Object));
- if (Sub_Version >= FASL_LONG_HEADER)
- printf("External primitives at 0x%x\n\n", Relocate(Ext_Prim_Vector));
+ printf("Dumped object at 0x%lx\n", Relocate(Dumped_Object));
}
else
{
Const_Count = 0;
+ Primitive_Table_Size = 0;
sscanf(argv[1], "%x", &Heap_Base);
sscanf(argv[2], "%x", &Const_Base);
sscanf(argv[3], "%d", &Heap_Count);
- printf("Heap Base = 0x%08x; Constant Base = 0x%08x; Heap Count = %d\n",
+ printf("Heap Base = 0x%08lx; Constant Base = 0x%08lx; Heap Count = %ld\n",
Heap_Base, Const_Base, Heap_Count);
}
- Data = ((Pointer *) malloc(sizeof(Pointer) * (Heap_Count + Const_Count)));
+\f
+ load_length = (Heap_Count + Const_Count + Primitive_Table_Size);
+ Data = ((Pointer *) malloc(sizeof(Pointer) * (load_length + 4)));
if (Data == NULL)
{
- fprintf(stderr, "Allocation of %d words failed.\n", (Heap_Count + Const_Count));
+ fprintf(stderr, "Allocation of %ld words failed.\n", (load_length + 4));
exit(1);
}
- end_of_memory = &Data[Heap_Count + Const_Count];
- total_length = Load_Data(Heap_Count + Const_Count, Data);
- if (total_length != (Heap_Count + Const_Count))
+ total_length = Load_Data(load_length, Data);
+ end_of_memory = &Data[total_length];
+ if (total_length != load_length)
{
printf("The FASL file does not have the right length.\n");
- printf("Expected %d objects. Obtained %d objects.\n\n",
- (Heap_Count + Const_Count), total_length);
+ printf("Expected %d objects. Obtained %ld objects.\n\n",
+ load_length, total_length);
if (total_length < Heap_Count)
{
Heap_Count = total_length;
{
Const_Count = total_length;
}
- }
- printf("Heap contents:\n\n");
- for (Next = Data, i = 0; i < Heap_Count; Next++, i++)
- {
- if (OBJECT_TYPE(*Next) == TC_MANIFEST_NM_VECTOR)
+ total_length -= Const_Count;
+ if (total_length < Primitive_Table_Size)
{
- long j, count;
-
- count = Get_Integer(*Next);
- Display(i, OBJECT_TYPE(*Next), OBJECT_DATUM(*Next));
- Next += 1;
- for (j = 0; j < count ; j++, Next++)
- {
- printf(" %02x%06x\n",
- OBJECT_TYPE(*Next), OBJECT_DATUM(*Next));
- }
- i += count;
- Next -= 1;
- }
- else
- {
- Display(i, OBJECT_TYPE(*Next), OBJECT_DATUM(*Next));
+ Primitive_Table_Size = total_length;
}
}
- printf("\n\nConstant space:\n\n");
- for (; i < Heap_Count + Const_Count; Next++, i++)
+\f
+ if (Heap_Count > 0)
{
- if (OBJECT_TYPE(*Next) == TC_MANIFEST_NM_VECTOR)
- {
- long j, count;
+ Next = show_area(Data, Heap_Count, "Heap");
+ }
+ if (Const_Count > 0)
+ {
+ Next = show_area(Next, Const_Count, "Constant Space");
+ }
+ if ((Primitive_Table_Size > 0) && (Next < end_of_memory))
+ {
+ long arity, size;
+ fast long entries, count;
- count = Get_Integer(*Next);
- Display(i, OBJECT_TYPE(*Next), OBJECT_DATUM(*Next));
- Next += 1;
- for (j = 0; j < count ; j++, Next++)
- {
- printf(" %02x%06x\n",
- OBJECT_TYPE(*Next), OBJECT_DATUM(*Next));
- }
- i += count;
- Next -= 1;
- }
- else
+ /* This is done in case the file is short. */
+ end_of_memory[0] = ((Pointer) 0);
+ end_of_memory[1] = ((Pointer) 0);
+ end_of_memory[2] = ((Pointer) 0);
+ end_of_memory[3] = ((Pointer) 0);
+
+ entries = Primitive_Table_Length;
+ printf("\nPrimitive table: number of entries = %ld\n\n", entries);
+
+ for (count = 0;
+ ((count < entries) && (Next < end_of_memory));
+ count += 1)
{
- Display(i, OBJECT_TYPE(*Next), OBJECT_DATUM(*Next));
+ Sign_Extend(*Next++, arity);
+ size = Get_Integer(*Next);
+ printf("Number = %3lx; Arity = %2ld; Name = ", count, arity);
+ scheme_string((Next - Data), true);
+ Next += (1 + size);
}
+ printf("\n");
}
+ exit(0);
}
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/prim.c,v 9.27 1987/10/28 18:31:11 jinx Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/prim.c,v 9.28 1987/11/17 08:14:49 jinx Rel $
*
* The leftovers ... primitives that don't seem to belong elsewhere.
*
the primitive known as NOT, NIL?, and NULL? in Scheme.
*/
Built_In_Primitive(Prim_Null, 1, "NULL?", 0xC)
+Define_Primitive(Prim_Null, 1, "NULL?")
{
Primitive_1_Arg();
and datum. Returns NIL otherwise.
*/
Built_In_Primitive(Prim_Eq, 2, "EQ?", 0xD)
+Define_Primitive(Prim_Eq, 2, "EQ?")
{
Primitive_2_Args();
*/
Built_In_Primitive(Prim_Make_Non_Pointer, 1,
"MAKE-NON-POINTER-OBJECT", 0xB1)
+Define_Primitive(Prim_Make_Non_Pointer, 1,
+ "MAKE-NON-POINTER-OBJECT")
{
Primitive_1_Arg();
Returns the datum part of OBJECT.
*/
Built_In_Primitive(Prim_Primitive_Datum, 1, "PRIMITIVE-DATUM", 0xB0)
+Define_Primitive(Prim_Primitive_Datum, 1, "PRIMITIVE-DATUM")
{
Primitive_1_Arg();
Note: THE OBJECT IS TOUCHED FIRST.
*/
Built_In_Primitive(Prim_Prim_Type, 1, "PRIMITIVE-TYPE", 0x10)
+Define_Primitive(Prim_Prim_Type, 1, "PRIMITIVE-TYPE")
{
Primitive_1_Arg();
*/
Built_In_Primitive(Prim_Gc_Type, 1, "PRIMITIVE-GC-TYPE", 0xBC)
+Define_Primitive(Prim_Gc_Type, 1, "PRIMITIVE-GC-TYPE")
{
Primitive_1_Arg();
Note: THE OBJECT IS TOUCHED FIRST.
*/
Built_In_Primitive(Prim_Prim_Type_QM, 2, "PRIMITIVE-TYPE?", 0xF)
+Define_Primitive(Prim_Prim_Type_QM, 2, "PRIMITIVE-TYPE?")
{
Primitive_2_Args();
*/
Built_In_Primitive(Prim_Primitive_Set_Type, 2, "PRIMITIVE-SET-TYPE", 0x11)
+Define_Primitive(Prim_Primitive_Set_Type, 2, "PRIMITIVE-SET-TYPE")
{
long New_GC_Type, New_Type;
Primitive_2_Args();
*/
Built_In_Primitive(Prim_And_Make_Object, 2, "&MAKE-OBJECT", 0x8D)
+Define_Primitive(Prim_And_Make_Object, 2, "&MAKE-OBJECT")
{
long New_Type;
Primitive_2_Args();
*/
Built_In_Primitive(Prim_System_Memory_Ref, 2, "SYSTEM-MEMORY-REF", 0x195)
+Define_Primitive(Prim_System_Memory_Ref, 2, "SYSTEM-MEMORY-REF")
{
Primitive_2_Args();
*/
Built_In_Primitive(Prim_System_Memory_Set, 3, "SYSTEM-MEMORY-SET!", 0x196)
+Define_Primitive(Prim_System_Memory_Set, 3, "SYSTEM-MEMORY-SET!")
{
long index;
Primitive_3_Args();
Creates a cell with contents CONTENTS.
*/
Built_In_Primitive(Prim_Make_Cell, 1, "MAKE-CELL", 0x61)
+Define_Primitive(Prim_Make_Cell, 1, "MAKE-CELL")
{
Primitive_1_Arg();
Returns the contents of the cell CELL.
*/
Built_In_Primitive(Prim_Cell_Contents, 1, "CELL-CONTENTS", 0x62)
+Define_Primitive(Prim_Cell_Contents, 1, "CELL-CONTENTS")
{
Primitive_1_Arg();
NIL.
*/
Built_In_Primitive(Prim_Cell, 1, "CELL?", 0x63)
+Define_Primitive(Prim_Cell, 1, "CELL?")
{
Primitive_1_Arg();
Stores VALUE as contents of CELL. Returns the previous contents of CELL.
*/
Built_In_Primitive(Prim_Set_Cell_Contents, 2, "SET-CELL-CONTENTS!", 0x8C)
+Define_Primitive(Prim_Set_Cell_Contents, 2, "SET-CELL-CONTENTS!")
{
Primitive_2_Args();
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.37 1987/10/28 21:57:38 jinx Rel $ */
+/* $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 $ */
\f
/*
Primitive declarations.
extern char *Primitive_Name_Table[];
extern long MAX_PRIMITIVE;
-extern Pointer (*(External_Procedure_Table[]))();
-extern int External_Arity_Table[];
-extern char *External_Name_Table[];
-extern long MAX_EXTERNAL_PRIMITIVE;
+#define CHUNK_SIZE 20 /* Grow undefined vector by this much */
-extern Pointer Undefined_Externals;
+extern Pointer Undefined_Primitives;
+extern Pointer Undefined_Primitives_Arity;
/* Utility macros */
-#define NUndefined() \
-((Undefined_Externals == NIL) ? \
- 0 : \
- Get_Integer(User_Vector_Ref(Undefined_Externals, 0)))
+#define NUMBER_OF_DEFINED_PRIMITIVES() (MAX_PRIMITIVE + 1)
-#define CHUNK_SIZE 20 /* Grow undefined vector by this much */
+#define NUMBER_OF_UNDEFINED_PRIMITIVES() \
+((Undefined_Primitives == NIL) ? \
+ 0 : \
+ Get_Integer(User_Vector_Ref(Undefined_Primitives, 0)))
+#define NUMBER_OF_PRIMITIVES() \
+(NUMBER_OF_UNDEFINED_PRIMITIVES() + \
+ NUMBER_OF_DEFINED_PRIMITIVES())
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.28 1987/07/23 21:50:25 cph Rel $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/prims.h,v 9.29 1987/11/17 08:15:06 jinx Exp $ */
/* This file contains some macros for defining primitives,
for argument type or value checking, and for accessing
extern Pointer C_Name(); \
Pointer C_Name()
-#define Built_In_Primitive(C_Name, Number_of_args, Scheme_Name, index) \
-extern Pointer C_Name(); \
-Pointer C_Name()
+/* This is a NOP.
+ Any primitive declared this way must also be declared
+ with Define_Primitive.
+ */
+
+#define Built_In_Primitive(C_Name, Number_of_args, Scheme_Name, index)
#ifdef ENABLE_PRIMITIVE_PROFILING
#define primitive_entry_hook() record_primitive_entry (Fetch_Expression ())
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.40 1987/04/16 14:34:28 jinx Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/primutl.c,v 9.41 1987/11/17 08:15:15 jinx Exp $
*
* This file contains the support routines for mapping primitive names
- * to numbers within the microcode. This mechanism is only used by
- * the runtime system on "external" primitives. "Built-in" primitives
- * must match their position in utabmd.scm. Eventually both
- * mechanisms will be merged. External primitives are written in C
+ * to numbers within the microcode. Primitives are written in C
* and available in Scheme, but not always present in all versions of
* the interpreter. Thus, these objects are always referenced
* externally by name and converted to numeric references only for the
#include "scheme.h"
#include "primitive.h"
\f
+Pointer Undefined_Primitives = NIL;
+Pointer Undefined_Primitives_Arity = NIL;
+
/* Common utilities. */
-/* In the following two procedures, size is really 1 less than size.
- It is really the index of the last valid entry.
+/*
+ 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.
*/
+#if false
+
+/* This version performs an expensive linear search. */
+
long
primitive_name_to_code(name, table, size)
char *name;
char *table[];
- long size;
+ int size;
{
- fast long i;
+ fast int i;
for (i = size; i >= 0; i -= 1)
{
s2 = table[i];
while (*s1++ == *s2)
+ {
if (*s2++ == '\0')
- return i;
-
+ {
+ return ((long) i);
+ }
+ }
}
- return -1;
+ return ((long) (-1));
}
+#else /* false */
+\f
+/* This version performs a log (base 2) search.
+ The table is assumed to be ordered alphabetically.
+ */
+
+long
+primitive_name_to_code(name, table, size)
+ char *name;
+ fast char *table[];
+ int size;
+{
+ extern int strcmp();
+ fast int low, high, middle, result;
+
+ low = 0;
+ high = size;
+
+ while(low < high)
+ {
+ middle = ((low + high) / 2);
+ result = strcmp(name, table[middle]);
+ if (result < 0)
+ {
+ high = (middle - 1);
+ }
+ else if (result > 0)
+ {
+ low = (middle + 1);
+ }
+ else
+ {
+ return ((long) middle);
+ }
+ }
+
+ /* This takes care of the fact that division rounds down.
+ If division were to round up, we would have to use high.
+ */
+
+ if (strcmp(name, table[low]) == 0)
+ {
+ return ((long) low);
+ }
+ return ((long) -1);
+}
+
+#endif /* false */
+\f
char *
primitive_code_to_name(code, table, size)
- long code;
+ int code;
char *table[];
- long size;
+ int size;
{
if ((code > size) || (code < 0))
+ {
return ((char *) NULL);
+ }
else
+ {
return table[code];
+ }
}
-int
+long
primitive_code_to_arity(code, table, size)
- long code;
+ int code;
int table[];
- long size;
+ int size;
{
if ((code > size) || (code < 0))
- return -1;
+ {
+ return ((long) -1);
+ }
else
- return table[code];
+ {
+ return ((long) table[code]);
+ }
}
-\f
-/* Utilities exclusively for built-in primitives. */
+
+/* Externally visible utilities */
extern Pointer make_primitive();
make_primitive(name)
char *name;
{
- long code;
-
- code = primitive_name_to_code(name,
- &Primitive_Name_Table[0],
- MAX_PRIMITIVE);
- if (code == -1)
- return NIL;
- return
- Make_Non_Pointer(TC_PRIMITIVE, code);
+ long i;
+
+ i = primitive_name_to_code(name,
+ &Primitive_Name_Table[0],
+ MAX_PRIMITIVE);
+ return ((i == ((long) -1)) ?
+ NIL :
+ Make_Non_Pointer(TC_PRIMITIVE, i));
}
-
+\f
extern long primitive_to_arity();
long
primitive_to_arity(code)
int code;
{
- return
- primitive_code_to_arity(code,
- &Primitive_Arity_Table[0],
- MAX_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);
+ }
}
+extern long primitive_to_arguments();
+
+/*
+ This is only valid during the invocation of a primitive.
+ It is used by various utilities to back out of code.
+ */
+
+long
+primitive_to_arguments(code)
+ long code;
+{
+ long arity;
+
+ arity = primitive_to_arity(code);
+
+ if (arity == ((long) LEXPR_PRIMITIVE_ARITY))
+ {
+ arity = ((long) Regs[REGBLOCK_LEXPR_ACTUALS]);
+ }
+ return (arity);
+}
+\f
extern char *primitive_to_name();
char *
primitive_to_name(code)
int code;
{
- return
- primitive_code_to_name(code,
- &Primitive_Name_Table[0],
- MAX_PRIMITIVE);
+ char *string;
+
+ if (code <= MAX_PRIMITIVE)
+ {
+ string = Primitive_Name_Table[code];
+ }
+ else
+ {
+ /* NOTE:
+ This is invoked by cons_primitive_table which is invoked by
+ fasdump before the "fixups" are undone. This means that the scheme
+ string may actually have a broken heart as its first word, but
+ this code will still work because the characters will still be there.
+ */
+
+ Pointer scheme_string;
+
+ scheme_string = User_Vector_Ref(Undefined_Primitives,
+ (code - MAX_PRIMITIVE));
+ string = Scheme_String_To_C_String(scheme_string);
+ }
+ return (string);
}
-\f
-/* Utilities exclusively for external primitives. */
-Pointer Undefined_Externals = NIL;
+/* this avoids some consing. */
Pointer
-external_primitive_name(code)
- long code;
+primitive_name(code)
+ int code;
{
+ Pointer scheme_string;
extern Pointer string_to_symbol();
- return
- string_to_symbol(C_String_To_Scheme_String(External_Name_Table[code]));
+ if (code <= MAX_PRIMITIVE)
+ {
+ scheme_string = C_String_To_Scheme_String(Primitive_Name_Table[code]);
+ }
+ else
+ {
+ scheme_string = User_Vector_Ref(Undefined_Primitives,
+ (code - MAX_PRIMITIVE));
+ }
+ return (string_to_symbol(scheme_string));
}
+\f
+extern Pointer find_primitiveo();
-extern long make_external_primitive();
-
-long
-make_external_primitive(Symbol, Intern_It)
- Pointer Symbol, Intern_It;
+Pointer
+find_primitive(Name, intern_p, arity, check_p)
+ Pointer Name;
+ Boolean intern_p, check_p;
+ int arity;
{
extern Boolean string_equal();
- Pointer *Next, Name;
- long i, Max;
-
- Name = Fast_Vector_Ref(Symbol, SYMBOL_NAME);
+ long i, Max, old_arity;
+ Pointer *Next;
i = primitive_name_to_code(Scheme_String_To_C_String(Name),
- &External_Name_Table[0],
- MAX_EXTERNAL_PRIMITIVE);
+ &Primitive_Name_Table[0],
+ MAX_PRIMITIVE);
if (i != -1)
- return Make_Non_Pointer(TC_PRIMITIVE_EXTERNAL, i);
- else if (Intern_It == NIL)
- return NIL;
+ {
+ old_arity = Primitive_Arity_Table[i];
+ if ((!check_p) || (arity == old_arity) ||
+ (arity == UNKNOWN_PRIMITIVE_ARITY))
+ {
+ return (Make_Non_Pointer(TC_PRIMITIVE, i));
+ }
+ else
+ {
+ return (MAKE_SIGNED_FIXNUM(old_arity));
+ }
+ }
+ else if (intern_p == NIL)
+ {
+ return (NIL);
+ }
+\f
+ /* The vector should be sorted for faster comparison. */
- Max = NUndefined();
+ Max = NUMBER_OF_UNDEFINED_PRIMITIVES();
if (Max > 0)
- Next = Nth_Vector_Loc(Undefined_Externals, 2);
-
- for (i = 1; i <= Max; i++)
{
- if (string_equal(Name, Fast_Vector_Ref(*Next++, SYMBOL_NAME)))
- return Make_Non_Pointer(TC_PRIMITIVE_EXTERNAL,
- (MAX_EXTERNAL_PRIMITIVE + i));
+ Next = Nth_Vector_Loc(Undefined_Primitives, 2);
+
+ for (i = 1; i <= Max; i++)
+ {
+ Pointer temp;
+
+ if (string_equal(Name, *Next++))
+ {
+ if (check_p)
+ {
+ temp = User_Vector_Ref(Undefined_Primitives_Arity, i);
+ if ((temp == NIL) && (arity != UNKNOWN_PRIMITIVE_ARITY))
+ {
+ User_Vector_Set(Undefined_Primitives_Arity,
+ i,
+ MAKE_SIGNED_FIXNUM(arity));
+ }
+ else
+ {
+ Sign_Extend(temp, old_arity);
+ if ((arity != UNKNOWN_PRIMITIVE_ARITY) && (arity != old_arity))
+ {
+ return (temp);
+ }
+ }
+ }
+ return (Make_Non_Pointer(TC_PRIMITIVE, (MAX_PRIMITIVE + i)));
+ }
+ }
}
- if (Intern_It != TRUTH)
- return NIL;
\f
- /* Intern the primitive name by adding it to the vector of
- undefined primitives */
+ /*
+ Intern the primitive name by adding it to the vector of
+ undefined primitives.
+ */
if ((Max % CHUNK_SIZE) == 0)
{
- Primitive_GC_If_Needed(Max + CHUNK_SIZE + 2);
- if (Max > 0) Next =
- Nth_Vector_Loc(Undefined_Externals, 2);
- Undefined_Externals = Make_Pointer(TC_VECTOR, Free);
+ Primitive_GC_If_Needed(2 * (Max + CHUNK_SIZE + 2));
+ if (Max > 0)
+ {
+ Next = Nth_Vector_Loc(Undefined_Primitives, 2);
+ }
+ Undefined_Primitives = Make_Pointer(TC_VECTOR, Free);
*Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, (Max + CHUNK_SIZE + 1));
*Free++ = Make_Unsigned_Fixnum(Max + 1);
for (i = 0; i < Max; i++)
+ {
+ *Free++ = Fetch(*Next++);
+ }
+ *Free++ = Name;
+ for (i = 1; i < CHUNK_SIZE; i++)
+ {
+ *Free++ = NIL;
+ }
+ if (Max > 0)
+ {
+ Next = Nth_Vector_Loc(Undefined_Primitives_Arity, 2);
+ }
+ Undefined_Primitives_Arity = Make_Pointer(TC_VECTOR, Free);
+ *Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, (Max + CHUNK_SIZE + 1));
+ *Free++ = NIL;
+ for (i = 0; i < Max; i++)
+ {
*Free++ = Fetch(*Next++);
- *Free++ = Symbol;
+ }
+ *Free++ = ((check_p && (arity != UNKNOWN_PRIMITIVE_ARITY)) ?
+ (MAKE_SIGNED_FIXNUM(arity)) :
+ NIL);
for (i = 1; i < CHUNK_SIZE; i++)
+ {
*Free++ = NIL;
+ }
+ Max += 1;
}
else
{
- User_Vector_Set(Undefined_Externals, (Max + 1), Symbol);
- User_Vector_Set(Undefined_Externals, 0, Make_Unsigned_Fixnum(Max + 1));
+ Max += 1;
+ User_Vector_Set(Undefined_Primitives, Max, Name);
+ if (check_p && (arity != UNKNOWN_PRIMITIVE_ARITY))
+ {
+ User_Vector_Set(Undefined_Primitives_Arity,
+ Max,
+ MAKE_SIGNED_FIXNUM(arity));
+ }
+ User_Vector_Set(Undefined_Primitives, 0, (MAKE_UNSIGNED_FIXNUM(Max)));
}
- return
- Make_Non_Pointer(TC_PRIMITIVE_EXTERNAL,
- (MAX_EXTERNAL_PRIMITIVE + Max + 1));
+ return (Make_Non_Pointer(TC_PRIMITIVE, (MAX_PRIMITIVE + Max)));
}
\f
-extern long external_primitive_to_arity();
+/* Dumping and loading primitive object references. */
+
+extern Pointer
+ *load_renumber_table,
+ dump_renumber_primitive(),
+ *initialize_primitive_table(),
+ *cons_primitive_table(),
+ *cons_whole_primitive_table();
+
+extern void install_primitive_table();
+
+Pointer *load_renumber_table;
+static Pointer *internal_renumber_table;
+static Pointer *external_renumber_table;
+static long next_primitive_renumber;
+
+Pointer *
+initialize_primitive_table(where, end)
+ fast Pointer *where;
+ Pointer *end;
+{
+ Pointer *top;
+ fast long number_of_primitives;
-long
-external_primitive_to_arity(code)
- int code;
+ number_of_primitives = NUMBER_OF_PRIMITIVES();
+ top = &where[2 * number_of_primitives];
+ if (top < end)
+ {
+ internal_renumber_table = where;
+ external_renumber_table = &where[number_of_primitives];
+ next_primitive_renumber = 0;
+
+ while (--number_of_primitives >= 0)
+ {
+ *where++ = NIL;
+ }
+ }
+ return (top);
+}
+\f
+Pointer
+dump_renumber_primitive(primitive)
+ fast Pointer primitive;
+{
+ fast Pointer result;
+
+ result = internal_renumber_table[OBJECT_DATUM(primitive)];
+ if (result == NIL)
+ {
+ result = Make_Non_Pointer(OBJECT_TYPE(primitive),
+ next_primitive_renumber);
+ internal_renumber_table[OBJECT_DATUM(primitive)] = result;
+ external_renumber_table[next_primitive_renumber] = primitive;
+ next_primitive_renumber += 1;
+ return (result);
+ }
+ else
+ {
+ return (Make_New_Pointer(OBJECT_TYPE(primitive), result));
+ }
+}
+
+Pointer *
+copy_primitive_information(code, start, end)
+ long code;
+ fast Pointer *start, *end;
{
+ extern Pointer *copy_c_string_to_scheme_string();
+
+ if (start < end)
+ {
+ *start++ = MAKE_SIGNED_FIXNUM(primitive_to_arity(((int) code)));
+ }
return
- primitive_code_to_arity(code,
- &External_Arity_Table[0],
- MAX_EXTERNAL_PRIMITIVE);
+ copy_c_string_to_scheme_string(primitive_to_name(((int) code)),
+ start,
+ end);
}
\f
-extern Pointer Make_Prim_Exts();
+Pointer *
+cons_primitive_table(start, end, length)
+ Pointer *start, *end;
+ long *length;
+{
+ Pointer *saved;
+ long count, code;
-/*
- Used to create a vector with symbols for each of the external
- primitives known to the system.
-*/
+ saved = start;
+ *length = next_primitive_renumber;
+
+ for (count = 0;
+ ((count < next_primitive_renumber) && (start < end));
+ count += 1)
+ {
+ code = (OBJECT_DATUM(external_renumber_table[count]));
+ start = copy_primitive_information(code, start, end);
+ }
+ return (start);
+}
+
+Pointer *
+cons_whole_primitive_table(start, end, length)
+ Pointer *start, *end;
+ long *length;
+{
+ Pointer *saved;
+ long count, number_of_primitives;
+
+ number_of_primitives = NUMBER_OF_PRIMITIVES();
+ *length = number_of_primitives;
+ saved = start;
-Pointer
-Make_Prim_Exts()
+ for (count = 0;
+ ((count < number_of_primitives) && (start < end));
+ count += 1)
+ {
+ start = copy_primitive_information(count, start, end);
+ }
+ return (start);
+}
+\f
+void
+install_primitive_table(table, length, flush_p)
+ fast Pointer *table;
+ fast long length;
+ Boolean flush_p;
{
- fast Pointer Result, *scan;
- fast long i, Max, Count;
-
- Max = NUndefined();
- Count = (MAX_EXTERNAL_PRIMITIVE + Max + 1);
- Primitive_GC_If_Needed(Count + 1);
- Result = Make_Pointer(TC_VECTOR, Free);
- scan = Free;
- Free += Count + 1;
-
- *scan++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, Count);
- for (i = 0; i <= MAX_EXTERNAL_PRIMITIVE; i++)
+ fast Pointer *translation_table;
+ Pointer result;
+ long arity;
+
+ if (flush_p)
{
- *scan++ = external_primitive_name(i);
+ Undefined_Primitives = NIL;
+ Undefined_Primitives_Arity = NIL;
}
- for (i = 1; i <= Max; i++)
+
+ translation_table = load_renumber_table;
+ while (--length >= 0)
{
- *scan++ = User_Vector_Ref(Undefined_Externals, i);
+ Sign_Extend(*table, arity);
+ table += 1;
+ result =
+ find_primitive(Make_Pointer(TC_CHARACTER_STRING, table),
+ true, arity, true);
+ if (OBJECT_TYPE(result) != TC_PRIMITIVE)
+ {
+ Primitive_Error(ERR_WRONG_ARITY_PRIMITIVES);
+ }
+ *translation_table++ = result;
+ table += (1 + OBJECT_DATUM(*table));
}
- return Result;
+ 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/psbmap.h,v 9.22 1987/08/07 15:36:46 jinx Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/psbmap.h,v 9.23 1987/11/17 08:18:32 jinx Exp $
*
* This file contains macros and declarations for Bintopsb.c
* and Psbtobin.c
#include "object.h"
#include "bignum.h"
#include "bitstr.h"
-#include "gc.h"
#include "types.h"
#include "sdata.h"
#include "const.h"
#include "missing.c"
#endif
-#define PORTABLE_VERSION 2
+#define PORTABLE_VERSION 3
/* Number of objects which, when traced recursively, point at all other
- objects dumped. Currently the dumped object and the external
- primitives vector.
+ objects dumped. Currently only the dumped object.
*/
-#define NROOTS 2
+#define NROOTS 1
/* Types to recognize external object references. Any occurrence of these
(which are external types and thus handled separately) means a reference
to an external object.
*/
-#define CONSTANT_CODE TC_BIG_FIXNUM
-#define HEAP_CODE TC_FIXNUM
+#define CONSTANT_CODE TC_FIXNUM
+#define HEAP_CODE TC_CHARACTER
#define fixnum_to_bits FIXNUM_LENGTH
#define bignum_to_bits(len) ((len) * SHIFT)
Boolean *ptr;
};
-Boolean strequal(s1, s2)
-fast char *s1, *s2;
-{ while (*s1 != '\0')
- if (*s1++ != *s2++) return false;
+Boolean
+strequal(s1, s2)
+ fast char *s1, *s2;
+{
+ while (*s1 != '\0')
+ {
+ if (*s1++ != *s2++)
+ {
+ return false;
+ }
+ }
return (*s2 == '\0');
}
-char *Find_Options(argc, argv, Noptions, Options)
-int argc;
-char **argv;
-int Noptions;
-struct Option_Struct Options[];
-{ for ( ; --argc >= 0; argv++)
- { char *this = *argv;
+char *
+Find_Options(argc, argv, Noptions, Options)
+ int argc;
+ char **argv;
+ int Noptions;
+ struct Option_Struct Options[];
+{
+ for ( ; --argc >= 0; argv++)
+ {
+ char *this;
int n;
+
+ this = *argv;
for (n = 0;
((n < Noptions) && (!strequal(this, Options[n].name)));
- n++) ;
- if (n >= Noptions) return this;
+ n++)
+ {};
+ if (n >= Noptions)
+ {
+ return (this);
+ }
*(Options[n].ptr) = Options[n].value;
}
- return NULL;
+ return (NULL);
}
\f
/* Usage information */
+void
Print_Options(n, options, where)
-int n;
-struct Option_Struct *options;
-FILE *where;
-{ if (--n < 0) return;
+ int n;
+ struct Option_Struct *options;
+ FILE *where;
+{
+ if (--n < 0)
+ {
+ return;
+ }
fprintf(where, "[%s]", options->name);
options += 1;
for (; --n >= 0; options += 1)
+ {
fprintf(where, " [%s]", options->name);
+ }
return;
}
+void
Print_Usage_and_Exit(noptions, options, io_options)
-int noptions;
-struct Option_Struct *options;
-char *io_options;
-{ fprintf(stderr, "usage: %s%s%s",
+ int noptions;
+ struct Option_Struct *options;
+ char *io_options;
+{
+ fprintf(stderr, "usage: %s%s%s",
Program_Name,
(((io_options == NULL) ||
(io_options[0] == '\0')) ? "" : " "),
io_options);
if (noptions != 0)
- { putc(' ', stderr);
+ {
+ putc(' ', stderr);
Print_Options(noptions, options, stderr);
}
putc('\n', stderr);
/* On unix use io redirection */
+void
Setup_Program(argc, argv, Noptions, Options)
-int argc;
-char *argv[];
-int Noptions;
-struct Option_Struct *Options;
-{ extern do_it();
+ int argc;
+ char *argv[];
+ int Noptions;
+ struct Option_Struct *Options;
+{
Program_Name = argv[0];
Input_File = stdin;
Output_File = stdout;
if (((argc - 1) > Noptions) ||
(Find_Options((argc - 1), &argv[1], Noptions, Options) != NULL))
+ {
Print_Usage_and_Exit(Noptions, Options, "");
- do_it();
+ }
return;
}
-#else
+#define quit exit
+\f
+#else /* not unix */
/* Otherwise use command line arguments */
+void
Setup_Program(argc, argv, Noptions, Options)
-int argc;
-char *argv[];
-int Noptions;
-struct Option_Struct *Options;
-{ extern do_it();
+ int argc;
+ char *argv[];
+ int Noptions;
+ struct Option_Struct *Options;
+{
Program_Name = argv[0];
if ((argc < 3) ||
((argc - 3) > Noptions) ||
(Find_Options((argc - 3), &argv[3], Noptions, Options) != NULL))
+ {
Print_Usage_and_Exit(Noptions, Options, "input_file output_file");
+ }
Input_File = ((strequal(argv[1], "-")) ?
stdin :
fopen(argv[1], "r"));
if (Input_File == NULL)
- { perror("Open failed.");
+ {
+ perror("Open failed.");
exit(1);
}
Output_File = ((strequal(argv[2], "-")) ?
stdout :
fopen(argv[2], "w"));
if (Output_File == NULL)
- { perror("Open failed.");
+ {
+ perror("Open failed.");
fclose(Input_File);
exit(1);
}
fprintf(stderr, "%s: Reading from %s, writing to %s.\n",
Program_Name, argv[1], argv[2]);
- do_it();
+ return;
+}
+\f
+void
+quit(code)
+ int code;
+{
fclose(Input_File);
fclose(Output_File);
+ /* VMS brain dammage */
+ if (code != 0)
+ {
+ exit(code);
+ }
return;
}
-#endif
+#endif /* unix */
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/psbtobin.c,v 9.27 1987/09/21 21:55:06 jinx Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/psbtobin.c,v 9.28 1987/11/17 08:05:02 jinx Exp $
*
* This File contains the code to translate portable format binary
* files to internal format.
#include "translate.h"
-static long Dumped_Object_Addr, Dumped_Ext_Prim_Addr;
+static long Dumped_Object_Addr;
static long Dumped_Heap_Base, Heap_Objects, Heap_Count;
static long Dumped_Constant_Base, Constant_Objects, Constant_Count;
static long Dumped_Pure_Base, Pure_Objects, Pure_Count;
+static long Primitive_Table_Length;
+
static Pointer *Heap;
static Pointer *Heap_Base, *Heap_Table, *Heap_Object_Base, *Free;
static Pointer *Constant_Base, *Constant_Table,
*Constant_Object_Base, *Free_Constant;
static Pointer *Pure_Base, *Pure_Table, *Pure_Object_Base, *Free_Pure;
+static Pointer *primitive_table, *primitive_table_end;
static Pointer *Stack_Top;
long
return (fwrite(((char *) From_Where), sizeof(Pointer), Count, Internal_File));
}
+#include "fasl.h"
#include "dump.c"
\f
+void
inconsistency()
{
/* Provide some context (2 lines). */
fgets(&yow[0], 100, Portable_File);
fprintf(stderr, "%s\n", &yow[0]);
- exit(1);
+ quit(1);
+ /*NOTREACHED*/
}
\f
#define OUT(c) return ((long) ((c) & MAX_CHAR))
C = getc(Portable_File);
if (C != '\\')
+ {
OUT(C);
+ }
C = getc(Portable_File);
switch(C)
{
default : OUT(C);
}
}
-
+\f
Pointer *
-read_a_string(To, Slot)
- Pointer *To, *Slot;
+read_a_string_internal(To, maxlen)
+ Pointer *To;
+ long maxlen;
{
- long maxlen, len, Pointer_Count;
+ long ilen, Pointer_Count;
fast char *string;
+ fast long len;
string = ((char *) (&To[STRING_CHARS]));
- *Slot = Make_Pointer(TC_CHARACTER_STRING, To);
- fscanf(Portable_File, "%ld %ld", &maxlen, &len);
+ fscanf(Portable_File, "%ld", &ilen);
+ len = ilen;
+
+ if (maxlen == -1)
+ {
+ maxlen = len;
+ }
/* Null terminated */
+
maxlen += 1;
+
Pointer_Count = STRING_CHARS + char_to_pointer(maxlen);
To[STRING_HEADER] =
Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, (Pointer_Count - 1));
- To[STRING_LENGTH] = Make_Non_Pointer(TC_FIXNUM, len);
+ To[STRING_LENGTH] = ((Pointer) len);
/* Space */
+
getc(Portable_File);
while (--len >= 0)
+ {
*string++ = ((char) read_a_char());
+ }
*string = '\0';
return (To + Pointer_Count);
}
+
+Pointer *
+read_a_string(To, Slot)
+ Pointer *To, *Slot;
+{
+ long maxlen;
+
+ *Slot = Make_Pointer(TC_CHARACTER_STRING, To);
+ fscanf(Portable_File, "%ld", &maxlen);
+ return (read_a_string_internal(To, maxlen));
+}
\f
/*
The following two lines appears by courtesy of your friendly
long digit;
int c;
- while ((c = fgetc(Portable_File)) == ' ') ;
+ while ((c = fgetc(Portable_File)) == ' ')
+ {};
digit = ((c >= 'a') ? (c - 'a' + 10)
: ((c >= 'A') ? (c - 'A' + 10)
: ((c >= '0') ? (c - '0')
: fprintf(stderr, "Losing big: %d\n", c))));
- return digit;
+ return (digit);
}
#endif
}
}
if (negative)
+ {
Value = -Value;
- *Slot = Make_Non_Pointer(TC_FIXNUM, Value);
- return To;
+ }
+ *Slot = MAKE_SIGNED_FIXNUM(Value);
+ return (To);
}
else if (size_in_bits == 0)
{
long Length;
if ((The_Type == TC_FIXNUM) && (!Compact_P))
+ {
fprintf(stderr,
"%s: Fixnum too large, coercing to bignum.\n",
Program_Name);
+ }
size = bits_to_bigdigit(size_in_bits);
ndigits = hex_digits(size_in_bits);
Length = Align(size);
}
}
if (bits_accumulated != 0)
+ {
*(inc_bit_string_ptr(scan)) = accumulator;
+ }
}
*Slot = the_bit_string;
- return To;
+ return (To);
}
\f
/* Underflow and Overflow */
for (expt = MAX_FLONUM_EXPONENT;
expt != 0;
expt >>= 1)
+ {
Result += ldexp(1.0, expt);
+ }
the_max = Result;
return Result;
}
VMS_BUG(size_in_bits = 0);
fscanf(Portable_File, "%ld %ld", &exponent, &size_in_bits);
if (size_in_bits == 0)
+ {
Result = 0.0;
+ }
else if ((exponent > MAX_FLONUM_EXPONENT) ||
(exponent < -MAX_FLONUM_EXPONENT))
{
/* Skip over mantissa */
- while (getc(Portable_File) != '\n') { };
+ while (getc(Portable_File) != '\n')
+ {};
fprintf(stderr,
"%s: Floating point exponent too %s!\n",
Program_Name,
long digit;
if (size_in_bits > FLONUM_MANTISSA_BITS)
+ {
fprintf(stderr,
"%s: Some precision may be lost.",
Program_Name);
+ }
getc(Portable_File); /* Space */
for (ndigits = hex_digits(size_in_bits),
Result = 0.0,
Result = ldexp(Result, ((int) exponent));
}
if (negative)
+ {
Result = -Result;
- return Result;
+ }
+ return (Result);
}
\f
Pointer *
int The_Type;
while (Table < Until)
+ {
+ fscanf(Portable_File, "%2x", &The_Type);
+ switch(The_Type)
{
- fscanf(Portable_File, "%2x", &The_Type);
- switch(The_Type)
- {
- case TC_CHARACTER_STRING:
- To = read_a_string(To, Table++);
- continue;
+ case TC_CHARACTER_STRING:
+ To = read_a_string(To, Table++);
+ continue;
- case TC_BIT_STRING:
- To = read_a_bit_string(To, Table++);
- continue;
+ case TC_BIT_STRING:
+ To = read_a_bit_string(To, Table++);
+ continue;
- case TC_FIXNUM:
- case TC_BIG_FIXNUM:
- To = read_an_integer(The_Type, To, Table++);
- continue;
+ case TC_FIXNUM:
+ case TC_BIG_FIXNUM:
+ To = read_an_integer(The_Type, To, Table++);
+ continue;
- case TC_CHARACTER:
- {
- long the_char_code;
+ case TC_CHARACTER:
+ {
+ long the_char_code;
- getc(Portable_File); /* Space */
- VMS_BUG(the_char_code = 0);
- fscanf( Portable_File, "%3lx", &the_char_code);
- *Table++ = Make_Non_Pointer( TC_CHARACTER, the_char_code);
- continue;
- }
+ getc(Portable_File); /* Space */
+ VMS_BUG(the_char_code = 0);
+ fscanf( Portable_File, "%3lx", &the_char_code);
+ *Table++ = Make_Non_Pointer( TC_CHARACTER, the_char_code);
+ continue;
+ }
\f
- case TC_BIG_FLONUM:
- {
- double The_Flonum = read_a_flonum();
-
- Align_Float(To);
- *Table++ = Make_Pointer(TC_BIG_FLONUM, To);
- *To++ = Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, (float_to_pointer));
- *((double *) To) = The_Flonum;
- To += float_to_pointer;
- continue;
- }
- default:
- fprintf(stderr,
- "%s: Unknown external object found; Type = 0x%02x\n",
- Program_Name, The_Type);
- inconsistency();
- /*NOTREACHED*/
- }
+ case TC_BIG_FLONUM:
+ {
+ double The_Flonum = read_a_flonum();
+
+ Align_Float(To);
+ *Table++ = Make_Pointer(TC_BIG_FLONUM, To);
+ *To++ = Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, (float_to_pointer));
+ *((double *) To) = The_Flonum;
+ To += float_to_pointer;
+ continue;
+ }
+
+ default:
+ fprintf(stderr,
+ "%s: Unknown external object found; Type = 0x%02x\n",
+ Program_Name, The_Type);
+ inconsistency();
+ /*NOTREACHED*/
+ }
}
- return To;
+ return (To);
}
\f
#if false
+void
Move_Memory(From, N, To)
fast Pointer *From, *To;
long N;
Until = &From[N];
while (From < Until)
+ {
*To++ = *From++;
+ }
return;
}
#endif
+void
Relocate_Objects(From, N, disp)
fast Pointer *From;
long N;
inconsistency();
}
}
+ return;
}
\f
-#define Relocate_Into(Where, Addr) \
-if ((Addr) < Dumped_Pure_Base) \
- (Where) = &Heap_Object_Base[(Addr) - Dumped_Heap_Base]; \
-else if ((Addr) < Dumped_Constant_Base) \
- (Where) = &Pure_Base[(Addr) - Dumped_Pure_Base]; \
-else \
- (Where) = &Constant_Base[(Addr) - Dumped_Constant_Base]
+#define Relocate_Into(Where, Addr) \
+{ \
+ if ((Addr) < Dumped_Pure_Base) \
+ { \
+ (Where) = &Heap_Object_Base[(Addr) - Dumped_Heap_Base]; \
+ } \
+ else if ((Addr) < Dumped_Constant_Base) \
+ { \
+ (Where) = &Pure_Base[(Addr) - Dumped_Pure_Base]; \
+ } \
+ else \
+ { \
+ (Where) = &Constant_Base[(Addr) - Dumped_Constant_Base]; \
+ } \
+}
#ifndef Conditional_Bug
-#define Relocate(Addr) \
-(((Addr) < Dumped_Pure_Base) ? \
- &Heap_Object_Base[(Addr) - Dumped_Heap_Base] : \
- (((Addr) < Dumped_Constant_Base) ? \
- &Pure_Base[(Addr) - Dumped_Pure_Base] : \
+#define Relocate(Addr) \
+(((Addr) < Dumped_Pure_Base) ? \
+ &Heap_Object_Base[(Addr) - Dumped_Heap_Base] : \
+ (((Addr) < Dumped_Constant_Base) ? \
+ &Pure_Base[(Addr) - Dumped_Pure_Base] : \
&Constant_Base[(Addr) - Dumped_Constant_Base]))
#else
static Pointer *Relocate_Temp;
-#define Relocate(Addr) \
+#define Relocate(Addr) \
(Relocate_Into(Relocate_Temp, Addr), Relocate_Temp)
#endif
int The_Type;
long The_Datum;
- /* Align_Float(To); */
+#if false
+ Align_Float(To);
+#endif
+
while (--N >= 0)
{
VMS_BUG(The_Type = 0);
continue;
case TC_MANIFEST_NM_VECTOR:
- if (!(Null_NMV)) /* Unknown object! */
+ if (!(Null_NMV))
+ {
+ /* Unknown object! */
fprintf(stderr,
"%s: File is not portable: NMH found\n",
Program_Name);
+ }
*To++ = Make_Non_Pointer(The_Type, The_Datum);
{
fast long count;
fprintf(stderr, "%s: Broken Heart Found\n", Program_Name);
inconsistency();
}
- /* Fall Through */
- case TC_PRIMITIVE_EXTERNAL:
+ /* fall through */
+
+ case TC_PCOMB0:
+ case TC_PRIMITIVE:
case TC_MANIFEST_SPECIAL_NM_VECTOR:
case_simple_Non_Pointer:
*To++ = Make_Non_Pointer(The_Type, The_Datum);
continue;
}
/* It is a pointer, fall through. */
+
default:
/* Should be stricter */
*To++ = Make_Pointer(The_Type, Relocate(The_Datum));
continue;
}
}
- /* Align_Float(To); */
- return To;
+#if false
+ Align_Float(To);
+#endif
+ return (To);
+}
+\f
+static Boolean primitive_warn = false;
+
+Pointer *
+read_primitives(how_many, where)
+ fast long how_many;
+ fast Pointer *where;
+{
+ long arity;
+
+ while (--how_many >= 0)
+ {
+ fscanf(Portable_File, "%ld", &arity);
+ if (arity == ((long) UNKNOWN_PRIMITIVE_ARITY))
+ {
+ primitive_warn = true;
+ }
+ *where++ = MAKE_SIGNED_FIXNUM(arity);
+ where = read_a_string_internal(where, ((long) -1));
+ }
+ return (where);
}
\f
#ifdef DEBUG
-Print_External_Objects(area_name, Table, N)
+void
+print_external_objects(area_name, Table, N)
char *area_name;
fast Pointer *Table;
fast long N;
fprintf(stderr, "Table = 0x%x; N = %d\n", Table, N);
for( ; Table < Table_End; Table++)
+ {
switch (Type_Code(*Table))
{
case TC_FIXNUM:
(N - (Table_End - Table)),
*Table);
break;
- }
+ }
+ }
+ return;
+}
+
+#define DEBUGGING(action) action
+
+#define WHEN(condition, message) when(condition, message)
+
+void
+when(what, message)
+ Boolean what;
+ char *message;
+{
+ if (what)
+ {
+ fprintf(stderr, "%s: Inconsistency: %s!\n",
+ Program_Name, (message));
+ quit(1);
+ }
+ return;
+}
+
+#define READ_HEADER(string, format, value) \
+{ \
+ fscanf(Input_File, format, value); \
+ fprintf(stderr, "%s: ", (string)); \
+ fprintf(stderr, (format), (*(value))); \
+ fprintf(stderr, "\n"); \
}
-#endif
+\f
+#else /* not DEBUG */
+
+#define DEBUGGING(action)
+
+#define WHEN(what, message)
+
+#define READ_HEADER(string, format, value) \
+{ \
+ fscanf(Input_File, format, value); \
+}
+
+#endif /* DEBUG */
\f
long
Read_Header_and_Allocate()
{
long Portable_Version, Flags, Version, Sub_Version;
- long NFlonums, NIntegers, NBits, NBitstrs, NBBits, NStrings, NChars;
+ long NFlonums, NIntegers, NBits, NBitstrs, NBBits, NStrings, NChars, NPChars;
long Size;
/* Read Header */
- fscanf(Input_File, "%ld %ld %ld %ld",
- &Portable_Version, &Flags, &Version, &Sub_Version);
-
- fscanf(Input_File, "%ld %ld %ld",
- &Heap_Count, &Dumped_Heap_Base, &Heap_Objects);
-
- fscanf(Input_File, "%ld %ld %ld",
- &Constant_Count, &Dumped_Constant_Base, &Constant_Objects);
-
- fscanf(Input_File, "%ld %ld %ld",
- &Pure_Count, &Dumped_Pure_Base, &Pure_Objects);
-
- fscanf(Input_File, "%ld %ld",
- &Dumped_Object_Addr, &Dumped_Ext_Prim_Addr);
-
- fscanf(Input_File, "%ld %ld %ld %ld %ld %ld %ld",
- &NFlonums,
- &NIntegers, &NBits,
- &NBitstrs, &NBBits,
- &NStrings, &NChars);
+ READ_HEADER("Portable Version", "%ld", &Portable_Version);
+ READ_HEADER("Flags", "%ld", &Flags);
+ READ_HEADER("Version", "%ld", &Version);
+ READ_HEADER("Sub Version", "%ld", &Sub_Version);
if ((Portable_Version != PORTABLE_VERSION) ||
(Version != FASL_FORMAT_VERSION) ||
(Sub_Version != FASL_SUBVERSION))
{
fprintf(stderr,
- "FASL File Version %4d Subversion %4d Portable Version %4d\n",
+ "Portable File Version %4d Subversion %4d Portable Version %4d\n",
Version, Sub_Version, Portable_Version);
fprintf(stderr,
- "Expected: Version %4d Subversion %4d Portable Version %4d\n",
+ "Expected: Version %4d Subversion %4d Portable Version %4d\n",
FASL_FORMAT_VERSION, FASL_SUBVERSION, PORTABLE_VERSION);
- exit(1);
+ quit(1);
}
Read_Flags(Flags);
+ READ_HEADER("Heap Count", "%ld", &Heap_Count);
+ READ_HEADER("Dumped Heap Base", "%ld", &Dumped_Heap_Base);
+ READ_HEADER("Heap Objects", "%ld", &Heap_Objects);
+
+ READ_HEADER("Constant Count", "%ld", &Constant_Count);
+ READ_HEADER("Dumped Constant Base", "%ld", &Dumped_Constant_Base);
+ READ_HEADER("Constant Objects", "%ld", &Constant_Objects);
+
+ READ_HEADER("Pure Count", "%ld", &Pure_Count);
+ READ_HEADER("Dumped Pure Base", "%ld", &Dumped_Pure_Base);
+ READ_HEADER("Pure Objects", "%ld", &Pure_Objects);
+
+ READ_HEADER("& Dumped Object", "%ld", &Dumped_Object_Addr);
+
+ READ_HEADER("Number of flonums", "%ld", &NFlonums);
+ READ_HEADER("Number of integers", "%ld", &NIntegers);
+ READ_HEADER("Number of bits in integers", "%ld", &NBits);
+ READ_HEADER("Number of bit strings", "%ld", &NBitstrs);
+ READ_HEADER("Number of bits in bit strings", "%ld", &NBBits);
+ READ_HEADER("Number of character strings", "%ld", &NStrings);
+ READ_HEADER("Number of characters in strings", "%ld", &NChars);
+
+ READ_HEADER("Primitive Table Length", "%ld", &Primitive_Table_Length);
+ READ_HEADER("Number of characters in primitives", "%ld", &NPChars);
+
Size = (6 + /* SNMV */
HEAP_BUFFER_SPACE +
Heap_Count + Heap_Objects +
((NStrings * (1 + STRING_CHARS)) +
(char_to_pointer(NChars))) +
((NBitstrs * (1 + BIT_STRING_FIRST_WORD)) +
- (bits_to_pointers(NBBits))));
+ (bits_to_pointers(NBBits))) +
+ ((Primitive_Table_Length * (2 + STRING_CHARS)) +
+ (char_to_pointer(NPChars))));
Allocate_Heap_Space(Size);
if (Heap == NULL)
fprintf(stderr,
"%s: Memory Allocation Failed. Size = %ld Scheme Pointers\n",
Program_Name, Size);
- exit(1);
+ quit(1);
}
Heap += HEAP_BUFFER_SPACE;
Initial_Align_Float(Heap);
return (Size - HEAP_BUFFER_SPACE);
}
\f
+void
do_it()
{
+ Pointer *primitive_table_end;
Boolean result;
long Size;
Size = Read_Header_and_Allocate();
+
Stack_Top = &Heap[Size];
+
Heap_Table = &Heap[0];
Heap_Base = &Heap_Table[Heap_Objects];
Heap_Object_Base =
Read_External(Heap_Objects, Heap_Table, Heap_Base);
+ /* The various 2s below are for SNMV headers. */
+
Pure_Table = &Heap_Object_Base[Heap_Count];
- Pure_Base = &Pure_Table[Pure_Objects + 2]; /* SNMV */
+ Pure_Base = &Pure_Table[Pure_Objects + 2];
Pure_Object_Base =
Read_External(Pure_Objects, Pure_Table, Pure_Base);
Constant_Table = &Heap[Size - Constant_Objects];
- Constant_Base = &Pure_Object_Base[Pure_Count + 2]; /* SNMV */
+ Constant_Base = &Pure_Object_Base[Pure_Count + 2];
Constant_Object_Base =
Read_External(Constant_Objects, Constant_Table, Constant_Base);
-#ifdef DEBUG
- Print_External_Objects("Heap", Heap_Table, Heap_Objects);
- Print_External_Objects("Pure", Pure_Table, Pure_Objects);
- Print_External_Objects("Constant", Constant_Table, Constant_Objects);
-#endif
+ primitive_table = &Constant_Object_Base[Constant_Count + 2];
+
+ WHEN((primitive_table > Constant_Table),
+ "primitive_table overran Constant_Table");
+
+ DEBUGGING(print_external_objects("Heap", Heap_Table, Heap_Objects));
+ DEBUGGING(print_external_objects("Pure", Pure_Table, Pure_Objects));
+ DEBUGGING(print_external_objects("Constant",
+ Constant_Table,
+ Constant_Objects));
\f
/* Read the normal objects */
Free =
Read_Pointers_and_Relocate(Heap_Count, Heap_Object_Base);
+
+ WHEN((Free > Pure_Table),
+ "Free overran Pure_Table");
+ WHEN((Free < Pure_Table),
+ "Free did not reach Pure_Table");
+
Free_Pure =
Read_Pointers_and_Relocate(Pure_Count, Pure_Object_Base);
+
+ WHEN((Free_Pure > (Constant_Base - 2)),
+ "Free_Pure overran Constant_Base");
+ WHEN((Free_Pure < (Constant_Base - 2)),
+ "Free_Pure did not reach Constant_Base");
+
Free_Constant =
Read_Pointers_and_Relocate(Constant_Count, Constant_Object_Base);
+ WHEN((Free_Constant > (primitive_table - 2)),
+ "Free_Constant overran primitive_table");
+ WHEN((Free_Constant < (primitive_table - 2)),
+ "Free_Constant did not reach primitive_table");
+
+ primitive_table_end =
+ read_primitives(Primitive_Table_Length, primitive_table);
+
+ /*
+ primitive_table_end can be well below Constant_Table, since
+ the memory allocation is conservative (it rounds up), and all
+ the slack ends up between them.
+ */
+
+ WHEN((primitive_table_end > Constant_Table),
+ "primitive_table_end overran Constant_Table");
+
+ if (primitive_warn)
+ {
+ fprintf(stderr, "%s:\n", Program_Name);
+ fprintf(stderr,
+ "NOTE: The binary file contains primitives with unknown arity.\n");
+ }
+\f
/* Dump the objects */
{
- Pointer *Dumped_Object, *Dumped_Ext_Prim;
+ Pointer *Dumped_Object;
Relocate_Into(Dumped_Object, Dumped_Object_Addr);
- Relocate_Into(Dumped_Ext_Prim, Dumped_Ext_Prim_Addr);
-
-#ifdef DEBUG
- fprintf(stderr, "Dumping:\n");
- fprintf(stderr,
- "Heap = 0x%x; Heap Count = %d\n",
- Heap_Base, (Free - Heap_Base));
- fprintf(stderr,
- "Pure Space = 0x%x; Pure Count = %d\n",
- Pure_Base, (Free_Pure - Pure_Base));
- fprintf(stderr,
- "Constant Space = 0x%x; Constant Count = %d\n",
- Constant_Base, (Free_Constant - Constant_Base));
- fprintf(stderr,
- "& Dumped Object = 0x%x; Dumped Object = 0x%x\n",
- Dumped_Object, *Dumped_Object);
- fprintf(stderr,
- "& Dumped Ext Prim = 0x%x; Dumped Ext Prim = 0x%x\n",
- Dumped_Ext_Prim, *Dumped_Ext_Prim);
-#endif
+ DEBUGGING(fprintf(stderr, "Dumping:\n"));
+ DEBUGGING(fprintf(stderr,
+ "Heap = 0x%x; Heap Count = %d\n",
+ Heap_Base, (Free - Heap_Base)));
+ DEBUGGING(fprintf(stderr,
+ "Pure Space = 0x%x; Pure Count = %d\n",
+ Pure_Base, (Free_Pure - Pure_Base)));
+ DEBUGGING(fprintf(stderr,
+ "Constant Space = 0x%x; Constant Count = %d\n",
+ Constant_Base, (Free_Constant - Constant_Base)));
+ DEBUGGING(fprintf(stderr,
+ "& Dumped Object = 0x%x; Dumped Object = 0x%x\n",
+ Dumped_Object, *Dumped_Object));
+ DEBUGGING(fprintf(stderr, "Primitive_Table_Length = %ld; ",
+ Primitive_Table_Length));
+ DEBUGGING(fprintf(stderr, "Primitive_Table_Size = %ld\n",
+ (primitive_table_end - primitive_table)));
+\f
/* Is there a Pure/Constant block? */
if ((Constant_Objects == 0) && (Constant_Count == 0) &&
(Pure_Objects == 0) && (Pure_Count == 0))
- result = Write_File((Free - Heap_Base), Heap_Base, Dumped_Object,
- 0, &Heap[Size], Dumped_Ext_Prim);
+ {
+ result = Write_File(Dumped_Object,
+ (Free - Heap_Base), Heap_Base,
+ 0, Stack_Top,
+ primitive_table, Primitive_Table_Length,
+ ((long) (primitive_table_end - primitive_table)));
+ }
else
{
long Pure_Length, Total_Length;
Free_Constant[1] =
Make_Non_Pointer(END_OF_BLOCK, Total_Length);
- result = Write_File((Free - Heap_Base), Heap_Base, Dumped_Object,
- Total_Length, (Pure_Base - 2), Dumped_Ext_Prim);
+ result = Write_File(Dumped_Object,
+ (Free - Heap_Base), Heap_Base,
+ Total_Length, (Pure_Base - 2),
+ primitive_table, Primitive_Table_Length,
+ ((long) (primitive_table_end - primitive_table)));
}
}
if (!result)
{
- fprintf(stderr, "Error writing the output file.\n");
- exit(1);
+ fprintf(stderr, "%s: Error writing the output file.\n", Program_Name);
+ quit(1);
}
return;
}
/* Top level */
static int Noptions = 0;
+
/* C does not usually like empty initialized arrays, so ... */
+
static struct Option_Struct Options[] = {{"dummy", true, NULL}};
main(argc, argv)
char *argv[];
{
Setup_Program(argc, argv, Noptions, Options);
- return;
+ do_it();
+ quit(0);
}
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/purify.c,v 9.28 1987/06/05 17:29:07 cph Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/purify.c,v 9.29 1987/11/17 08:15:39 jinx Rel $
*
* This file contains the code that copies objects into pure
* and constant space.
*/
Built_In_Primitive(Prim_Primitive_Purify, 2, "PRIMITIVE-PURIFY", 0xB4)
+Define_Primitive(Prim_Primitive_Purify, 2, "PRIMITIVE-PURIFY")
{
long Saved_Zone;
Pointer Object, Lost_Objects, Purify_Result, Daemon;
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/purutl.c,v 9.31 1987/10/09 16:13:19 jinx Rel $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/purutl.c,v 9.32 1987/11/17 08:15:51 jinx Rel $ */
/* Pure/Constant space utilities. */
The object is placed in constant space instead.
*/
Built_In_Primitive(Prim_Impurify, 1, "PRIMITIVE-IMPURIFY", 0xBD)
+Define_Primitive(Prim_Impurify, 1, "PRIMITIVE-IMPURIFY")
{
Pointer Result;
Primitive_1_Arg();
other object, or it is in a pure section of the constant space).
*/
Built_In_Primitive(Prim_Pure_P, 1, "PURE?", 0xBB)
+Define_Primitive(Prim_Pure_P, 1, "PURE?")
{
Primitive_1_Arg();
pointer.
*/
Built_In_Primitive(Prim_Constant_P, 1, "CONSTANT?", 0xBA)
+Define_Primitive(Prim_Constant_P, 1, "CONSTANT?")
{
Primitive_1_Arg();
Returns the next free address in constant space.
*/
Built_In_Primitive(Prim_Get_Next_Constant, 0, "GET-NEXT-CONSTANT", 0xE4)
+Define_Primitive(Prim_Get_Next_Constant, 0, "GET-NEXT-CONSTANT")
{
Pointer *Next_Address;
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/rgxprim.c,v 1.3 1987/07/21 04:32:56 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/rgxprim.c,v 1.4 1987/11/17 08:16:12 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
} while (0)
\f
Built_In_Primitive (Prim_re_char_set_adjoin, 2, "RE-CHAR-SET-ADJOIN!", 0x190)
+Define_Primitive (Prim_re_char_set_adjoin, 2, "RE-CHAR-SET-ADJOIN!")
{
int ascii;
Primitive_2_Args ();
}
Built_In_Primitive (Prim_re_compile_fastmap, 4, "RE-COMPILE-FASTMAP", 0x191)
+Define_Primitive (Prim_re_compile_fastmap, 4, "RE-COMPILE-FASTMAP")
{
int can_be_null;
Primitive_4_Args ();
}
Built_In_Primitive (Prim_re_match_substring, 7, "RE-MATCH-SUBSTRING", 0x118)
+Define_Primitive (Prim_re_match_substring, 7, "RE-MATCH-SUBSTRING")
RE_SUBSTRING_PRIMITIVE (re_match)
Built_In_Primitive (Prim_re_search_substr_forward, 7,
"RE-SEARCH-SUBSTRING-FORWARD", 0x119)
+Define_Primitive (Prim_re_search_substr_forward, 7,
+ "RE-SEARCH-SUBSTRING-FORWARD")
RE_SUBSTRING_PRIMITIVE (re_search_forward)
Built_In_Primitive (Prim_re_search_substr_backward, 7,
"RE-SEARCH-SUBSTRING-BACKWARD", 0x11A)
+Define_Primitive (Prim_re_search_substr_backward, 7,
+ "RE-SEARCH-SUBSTRING-BACKWARD")
RE_SUBSTRING_PRIMITIVE (re_search_backward)
\f
#define RE_BUFFER_PRIMITIVE(procedure) \
}
Built_In_Primitive (Prim_re_match_buffer, 7, "RE-MATCH-BUFFER", 0x192)
+Define_Primitive (Prim_re_match_buffer, 7, "RE-MATCH-BUFFER")
RE_BUFFER_PRIMITIVE (re_match)
Built_In_Primitive (Prim_re_search_buffer_forward, 7,
"RE-SEARCH-BUFFER-FORWARD", 0x193)
+Define_Primitive (Prim_re_search_buffer_forward, 7,
+ "RE-SEARCH-BUFFER-FORWARD")
RE_BUFFER_PRIMITIVE (re_search_forward)
Built_In_Primitive (Prim_re_search_buffer_backward, 7,
"RE-SEARCH-BUFFER-BACKWARD", 0x194)
+Define_Primitive (Prim_re_search_buffer_backward, 7,
+ "RE-SEARCH-BUFFER-BACKWARD")
RE_BUFFER_PRIMITIVE (re_search_backward)
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/scheme.h,v 9.26 1987/10/09 16:13:39 jinx Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/scheme.h,v 9.27 1987/11/17 08:16:21 jinx Exp $
*
* General declarations for the SCode interpreter. This
* file is INCLUDED by others and contains declarations only.
#include "types.h" /* Type code numbers */
#include "const.h" /* Various named constants */
#include "object.h" /* Scheme object representation */
-#include "gc.h" /* Garbage collector related macros */
+#include "interrupt.h" /* Interrupt processing macros */
+#include "gc.h" /* Memory management related macros */
#include "scode.h" /* Scheme scode representation */
#include "sdata.h" /* Scheme user data representation */
#include "futures.h" /* Support macros, etc. for FUTURE */
#include "bkpt.h" /* Shadows some defaults */
#include "default.h" /* Defaults for various hooks. */
#include "extern.h" /* External declarations */
-#include "prim.h" /* Declarations for external primitives. */
+#include "prim.h" /* Declarations for primitives. */
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/sdata.h,v 9.26 1987/10/09 16:13:47 jinx Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/sdata.h,v 9.27 1987/11/17 08:16:29 jinx Rel $
*
* Description of the user data objects. This should parallel the
* file SDATA.SCM in the runtime system.
* APPLYed in the same way an object of type PROCEDURE can be.
*/
-/* PRIMITIVE_EXTERNAL
- * Functionally identical to PRIMITIVE. The distinctions are that a
- * PRIMITIVE is constrained to take no more than 3 arguments, PRIMITIVEs
- * can be formed into more efficient PRIMITIVE-COMBINATIONs by a
- * compiler, and that PRIMITIVE_EXTERNALs are user supplied.
- */
-
/* PROCEDURE (formerly CLOSURE)
* Consists of two parts: a LAMBDA expression and the environment
* in which the LAMBDA was evaluated to yield the PROCEDURE.
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/stack.h,v 9.23 1987/10/09 16:14:01 jinx Rel $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/stack.h,v 9.24 1987/11/17 08:16:42 jinx Exp $ */
/* This file contains macros for manipulating stacks and stacklets. */
\f
STACKLET_UNUSED_LENGTH))) + \
STACKLET_HEADER_SIZE); \
valid = ((len + 1) - invalid); \
- IntCode &= (~ INT_Stack_Overflow); \
+ CLEAR_INTERRUPT(INT_Stack_Overflow); \
To_Where = (Stack_Top - valid); \
From_Where = Nth_Vector_Loc (Control_Point, invalid); \
Stack_Check (To_Where); \
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.22 1987/04/16 02:29:36 jinx Rel $
+/* $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 $
*
* Support for the stepper
*/
*/
Built_In_Primitive(Prim_Eval_Step, 3, "PRIMITIVE-EVAL-STEP", 0xCA)
+Define_Primitive(Prim_Eval_Step, 3, "PRIMITIVE-EVAL-STEP")
{
Primitive_3_Args();
*/
Built_In_Primitive(Prim_Apply_Step, 3, "PRIMITIVE-APPLY-STEP", 0xCB)
+Define_Primitive(Prim_Apply_Step, 3, "PRIMITIVE-APPLY-STEP")
{
Pointer Next_From_Slot, *Next_To_Slot;
long Number_Of_Args, i;
*/
Built_In_Primitive(Prim_Return_Step, 2, "PRIMITIVE-RETURN-STEP", 0xCC)
+Define_Primitive(Prim_Return_Step, 2, "PRIMITIVE-RETURN-STEP")
{
Pointer Return_Hook;
Primitive_2_Args();
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.37 1987/10/09 16:14:23 jinx Rel $
+/* $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 $
This file defines the storage for global variables for
the Scheme Interpreter. */
*/
Swap_Temp; /* Used by Swap_Pointers in default.h */
\f
-long IntCode, /* Interrupts requesting */
- IntEnb, /* Interrupts enabled */
- Lookup_Offset, /* Slot lookup result return */
- GC_Reserve = 4500, /* Scheme pointer overflow space in heap */
- GC_Space_Needed = 0, /* Amount of space needed when GC triggered */
- /* Used to signal microcode errors from compiled code. */
- compiled_code_error_code;
+long
+ IntCode, /* Interrupts requesting */
+ IntEnb, /* Interrupts enabled */
+ temp_long, /* temporary for sign extension */
+ GC_Reserve = 4500, /* Scheme pointer overflow space in heap */
+ GC_Space_Needed = 0, /* Amount of space needed when GC triggered */
+ /* Used to signal microcode errors from compiled code. */
+ compiled_code_error_code;
Declare_Fixed_Objects();
Pointer *Highest_Allocated_Address;
#ifndef Heap_In_Low_Memory
+
Pointer *Memory_Base;
+
#endif
\f
/**********************/
/**********************/
#ifdef ENABLE_DEBUGGING_TOOLS
+
Boolean Eval_Debug = false;
Boolean Hex_Input_Debug = false;
Boolean File_Load_Debug = false;
int debug_nslots = 0;
int local_slotno = 0;
int local_nslots = 0;
-/* MHWU
+
+#if false /* MHWU */
int debug_circle[debug_maxslots];
int local_circle[debug_maxslots];
-*/
+#endif /* false */
+
int debug_circle[100];
int local_circle[100];
-#endif
+#endif /* ENABLE_DEBUGGING_TOOLS */
/****************************/
/* Debugging Macro Messages */
#if (MAX_RETURN_CODE != 0x5A)
/* Cause an error */
-#include "error: returns.h and storage.c are inconsistent -- Names Table"
+#include "Inconsistency: returns.h and storage.c (Return code table)"
#endif
long MAX_RETURN = MAX_RETURN_CODE;
+\f
+extern char *Error_Names[];
+
+char *Error_Names[] = {
+/* 0x00 */ "BAD-ERROR-CODE",
+/* 0x01 */ "UNBOUND-VARIABLE",
+/* 0x02 */ "UNASSIGNED-VARIABLE",
+/* 0x03 */ "INAPPLICABLE-OBJECT",
+/* 0x04 */ "OUT-OF-HASH-NUMBERS",
+/* 0x05 */ "ENVIRONMENT-CHAIN-TOO-DEEP",
+/* 0x06 */ "BAD-FRAME",
+/* 0x07 */ "BROKEN-COMPILED-VARIABLE",
+/* 0x08 */ "UNDEFINED-USER-TYPE",
+/* 0x09 */ "UNDEFINED-PRIMITIVE",
+/* 0x0A */ "EXTERNAL-RETURN",
+/* 0x0B */ "EXECUTE-MANIFEST-VECTOR",
+/* 0x0C */ "WRONG-NUMBER-OF-ARGUMENTS",
+/* 0x0D */ "ARG-1-WRONG-TYPE",
+/* 0x0E */ "ARG-2-WRONG-TYPE",
+/* 0x0F */ "ARG-3-WRONG-TYPE",
+/* 0x10 */ "ARG-1-BAD-RANGE",
+/* 0x11 */ "ARG-2-BAD-RANGE",
+/* 0x12 */ "ARG-3-BAD-RANGE",
+/* 0x13 */ "BAD-COMBINATION",
+/* 0x14 */ "FASDUMP-OVERFLOW",
+/* 0x15 */ "BAD-INTERRUPT-CODE",
+/* 0x16 */ "NO-ERRORS",
+/* 0x17 */ "FASL-FILE-TOO-BIG",
+/* 0x18 */ "FASL-FILE-BAD-DATA",
+/* 0x19 */ "IMPURIFY-OUT-OF-SPACE",
+/* 0x1A */ "WRITE-INTO-PURE-SPACE",
+/* 0x1B */ "LOSING-SPARE-HEAP",
+/* 0x1C */ "NO-HASH-TABLE",
+/* 0x1D */ "BAD-SET",
+/* 0x1E */ "ARG-1-FAILED-COERCION",
+/* 0x1F */ "ARG-2-FAILED-COERCION",
+/* 0x20 */ "OUT-OF-FILE-HANDLES",
+/* 0x21 */ "SHELL-DIED",
+/* 0x22 */ "ARG-4-BAD-RANGE",
+/* 0x23 */ "ARG-5-BAD-RANGE",
+/* 0x24 */ "ARG-6-BAD-RANGE",
+/* 0x25 */ "ARG-7-BAD-RANGE",
+/* 0x26 */ "ARG-8-BAD-RANGE",
+/* 0x27 */ "ARG-9-BAD-RANGE",
+/* 0x28 */ "ARG-10-BAD-RANGE",
+/* 0x29 */ "ARG-4-WRONG-TYPE",
+\f
+/* 0x2A */ "ARG-5-WRONG-TYPE",
+/* 0x2B */ "ARG-6-WRONG-TYPE",
+/* 0x2C */ "ARG-7-WRONG-TYPE",
+/* 0x2D */ "ARG-8-WRONG-TYPE",
+/* 0x2E */ "ARG-9-WRONG-TYPE",
+/* 0x2F */ "ARG-10-WRONG-TYPE",
+/* 0x30 */ "INAPPLICABLE-CONTINUATION",
+/* 0x31 */ "COMPILED-CODE-ERROR",
+/* 0x32 */ "FLOATING-OVERFLOW",
+/* 0x33 */ "UNIMPLEMENTED-PRIMITIVE",
+/* 0x34 */ "ILLEGAL-REFERENCE-TRAP",
+/* 0x35 */ "BROKEN-VARIABLE-CACHE",
+/* 0x36 */ "WRONG-ARITY-PRIMITIVES",
+/* 0x37 */ "IO-ERROR"
+};
+
+#if (MAX_ERROR != 0x37)
+/* Cause an error */
+#include "Inconsistency: errors.h and storage.c (Error code table)"
+#endif
+\f
+extern char *Term_Names[];
+
+char *Term_Names[] = {
+/* 0x00 */ "HALT",
+/* 0x01 */ "DISK-RESTORE",
+/* 0x02 */ "BROKEN-HEART",
+/* 0x03 */ "NON-POINTER-RELOCATION",
+/* 0x04 */ "BAD-ROOT",
+/* 0x05 */ "NON-EXISTENT-CONTINUATION",
+/* 0x06 */ "BAD-STACK",
+/* 0x07 */ "STACK-OVERFLOW",
+/* 0x08 */ "STACK-ALLOCATION-FAILED",
+/* 0x09 */ "NO-ERROR-HANDLER",
+/* 0x0A */ "NO-INTERRUPT-HANDLER",
+/* 0x0B */ "UNIMPLEMENTED-CONTINUATION",
+/* 0x0C */ "EXIT",
+/* 0x0D */ "BAD-PRIMITIVE-DURING-ERROR",
+/* 0x0E */ "EOF",
+/* 0x0F */ "BAD-PRIMITIVE",
+/* 0x10 */ "HANDLER",
+/* 0x11 */ "END-OF-COMPUTATION",
+/* 0x12 */ "INVALID-TYPE-CODE",
+/* 0x13 */ "COMPILER-DEATH",
+/* 0x14 */ "GC-OUT-OF-SPACE",
+/* 0x15 */ "NO-SPACE",
+/* 0x16 */ "SIGNAL"
+};
+
+/* If you change this table, change the Term_Messages table below as well. */
+
+#if (MAX_TERMINATION != 0x16)
+/* Cause an error */
+#include "Inconsistency: errors.h and storage.c (Termination code table)"
+#endif
+\f
+extern char *Term_Messages[];
+
+char *Term_Messages[] = {
+/* 0x00 */ "Moriturus te saluto",
+/* 0x01 */ "Unrecoverable error while loading a band",
+/* 0x02 */ "Broken heart encountered",
+/* 0x03 */ "Non pointer relocation",
+/* 0x04 */ "Cannot restore control state from band",
+/* 0x05 */ "Nonexistent return code",
+/* 0x06 */ "Control stack messed up",
+/* 0x07 */ "Stack overflow: Maximum recursion depth exceeded",
+/* 0x08 */ "Not enough space for stack!",
+/* 0x09 */ "No error handler",
+/* 0x0A */ "No interrupt handler",
+/* 0x0B */ "Unimplemented return code",
+/* 0x0C */ "Inconsistency detected",
+/* 0x0D */ "Error during unknown primitive",
+/* 0x0E */ "End of input stream reached",
+/* 0x0F */ "Bad primitive invoked",
+/* 0x10 */ "Termination handler returned",
+/* 0x11 */ "End of computation",
+/* 0x12 */ "Unknown type encountered",
+/* 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"
+};
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/string.c,v 9.27 1987/08/05 07:32:48 jinx Rel $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/string.c,v 9.28 1987/11/17 08:17:44 jinx Exp $ */
/* String primitives. */
field. They should be changed to have just longwords there. */
Built_In_Primitive (Prim_String_Allocate, 1, "STRING-ALLOCATE", 0x13E)
+Define_Primitive (Prim_String_Allocate, 1, "STRING-ALLOCATE")
{
PRIMITIVE_HEADER (1);
}
Built_In_Primitive (Prim_String_P, 1, "STRING?", 0x138)
+Define_Primitive (Prim_String_P, 1, "STRING?")
{
Primitive_1_Arg ();
}
\f
Built_In_Primitive (Prim_String_Length, 1, "STRING-LENGTH", 0x139)
+Define_Primitive (Prim_String_Length, 1, "STRING-LENGTH")
{
Primitive_1_Arg ();
Built_In_Primitive (Prim_String_Maximum_Length, 1,
"STRING-MAXIMUM-LENGTH", 0x13F)
+Define_Primitive (Prim_String_Maximum_Length, 1,
+ "STRING-MAXIMUM-LENGTH")
{
Primitive_1_Arg ();
}
Built_In_Primitive (Prim_Set_String_Length, 2, "SET-STRING-LENGTH!", 0x140)
+Define_Primitive (Prim_Set_String_Length, 2, "SET-STRING-LENGTH!")
{
long length, result;
Primitive_2_Args ();
}
Built_In_Primitive (Prim_String_Ref, 2, "STRING-REF", 0x13A)
+Define_Primitive (Prim_String_Ref, 2, "STRING-REF")
string_ref_body (c_char_to_scheme_char)
Built_In_Primitive (Prim_Vec_8b_Ref, 2, "VECTOR-8B-REF", 0xA5)
+Define_Primitive (Prim_Vec_8b_Ref, 2, "VECTOR-8B-REF")
string_ref_body (Make_Unsigned_Fixnum)
#define string_set_body(get_ascii, process_result) \
}
Built_In_Primitive (Prim_String_Set, 3, "STRING-SET!", 0x13B)
+Define_Primitive (Prim_String_Set, 3, "STRING-SET!")
string_set_body (arg_ascii_char, c_char_to_scheme_char)
Built_In_Primitive (Prim_Vec_8b_Set, 3, "VECTOR-8B-SET!", 0xA6)
+Define_Primitive (Prim_Vec_8b_Set, 3, "VECTOR-8B-SET!")
string_set_body (arg_ascii_integer, MAKE_UNSIGNED_FIXNUM)
\f
#define substring_move_prefix() \
Built_In_Primitive (Prim_Substring_Move_Right, 5,
"SUBSTRING-MOVE-RIGHT!", 0x13C)
+Define_Primitive (Prim_Substring_Move_Right, 5,
+ "SUBSTRING-MOVE-RIGHT!")
{
substring_move_prefix()
Built_In_Primitive (Prim_Substring_Move_Left, 5,
"SUBSTRING-MOVE-LEFT!", 0x13D)
+Define_Primitive (Prim_Substring_Move_Left, 5,
+ "SUBSTRING-MOVE-LEFT!")
{
substring_move_prefix()
error_bad_range_arg (2);
Built_In_Primitive (Prim_Vec_8b_Fill, 4, "VECTOR-8B-FILL!", 0x141)
+Define_Primitive (Prim_Vec_8b_Fill, 4, "VECTOR-8B-FILL!")
{
vector_8b_substring_prefix ();
Built_In_Primitive (Prim_Vec_8b_Find_Next_Char, 4,
"VECTOR-8B-FIND-NEXT-CHAR", 0x142)
+Define_Primitive (Prim_Vec_8b_Find_Next_Char, 4,
+ "VECTOR-8B-FIND-NEXT-CHAR")
{
vector_8b_substring_prefix ();
\f
Built_In_Primitive (Prim_Vec_8b_Find_Prev_Char, 4,
"VECTOR-8B-FIND-PREVIOUS-CHAR", 0x143)
+Define_Primitive (Prim_Vec_8b_Find_Prev_Char, 4,
+ "VECTOR-8B-FIND-PREVIOUS-CHAR")
{
vector_8b_substring_prefix ();
Built_In_Primitive(Prim_Vec_8b_Find_Next_Char_Ci, 4,
"VECTOR-8B-FIND-NEXT-CHAR-CI", 0x144)
+Define_Primitive(Prim_Vec_8b_Find_Next_Char_Ci, 4,
+ "VECTOR-8B-FIND-NEXT-CHAR-CI")
{
char char1;
vector_8b_substring_prefix ();
Built_In_Primitive(Prim_Vec_8b_Find_Prev_Char_Ci, 4,
"VECTOR-8B-FIND-PREVIOUS-CHAR-CI", 0x145)
+Define_Primitive(Prim_Vec_8b_Find_Prev_Char_Ci, 4,
+ "VECTOR-8B-FIND-PREVIOUS-CHAR-CI")
{
char char1;
vector_8b_substring_prefix ();
Built_In_Primitive(Prim_Find_Next_Char_In_Set, 4,
"SUBSTRING-FIND-NEXT-CHAR-IN-SET", 0x146)
+Define_Primitive(Prim_Find_Next_Char_In_Set, 4,
+ "SUBSTRING-FIND-NEXT-CHAR-IN-SET")
{
substr_find_char_in_set_prefix ();
Built_In_Primitive(Prim_Find_Prev_Char_In_Set, 4,
"SUBSTRING-FIND-PREVIOUS-CHAR-IN-SET", 0x147)
+Define_Primitive(Prim_Find_Prev_Char_In_Set, 4,
+ "SUBSTRING-FIND-PREVIOUS-CHAR-IN-SET")
{
substr_find_char_in_set_prefix ();
PRIMITIVE_RETURN (NIL);
Built_In_Primitive(Prim_Substring_Equal, 6, "SUBSTRING=?", 0x148)
+Define_Primitive(Prim_Substring_Equal, 6, "SUBSTRING=?")
{
substring_equal_prefix ();
}
Built_In_Primitive(Prim_Substring_Ci_Equal, 6, "SUBSTRING-CI=?", 0x149)
+Define_Primitive(Prim_Substring_Ci_Equal, 6, "SUBSTRING-CI=?")
{
substring_equal_prefix ();
}
\f
Built_In_Primitive (Prim_Substring_Less, 6, "SUBSTRING<?", 0x14A)
+Define_Primitive (Prim_Substring_Less, 6, "SUBSTRING<?")
{
long length, length1, length2;
substring_compare_prefix (start1, start2);
}
Built_In_Primitive(Prim_Substring_Upcase, 3, "SUBSTRING-UPCASE!", 0x14B)
+Define_Primitive(Prim_Substring_Upcase, 3, "SUBSTRING-UPCASE!")
SUBSTRING_MODIFIER (char_upcase)
Built_In_Primitive(Prim_Substring_Downcase, 3, "SUBSTRING-DOWNCASE!", 0x14C)
+Define_Primitive(Prim_Substring_Downcase, 3, "SUBSTRING-DOWNCASE!")
SUBSTRING_MODIFIER (char_downcase)
\f
#define substring_match_prefix(index1, index2) \
Built_In_Primitive (Prim_Match_Forward, 6,
"SUBSTRING-MATCH-FORWARD", 0x14D)
+Define_Primitive (Prim_Match_Forward, 6,
+ "SUBSTRING-MATCH-FORWARD")
{
substring_match_prefix (start1, start2);
Built_In_Primitive (Prim_Match_Forward_Ci, 6,
"SUBSTRING-MATCH-FORWARD-CI", 0x14F)
+Define_Primitive (Prim_Match_Forward_Ci, 6,
+ "SUBSTRING-MATCH-FORWARD-CI")
{
substring_match_prefix (start1, start2);
Built_In_Primitive (Prim_Match_Backward, 6,
"SUBSTRING-MATCH-BACKWARD", 0x14E)
+Define_Primitive (Prim_Match_Backward, 6,
+ "SUBSTRING-MATCH-BACKWARD")
{
substring_match_prefix (end1, end2);
Built_In_Primitive(Prim_Match_Backward_Ci, 6,
"SUBSTRING-MATCH-BACKWARD-CI", 0x150)
+Define_Primitive(Prim_Match_Backward_Ci, 6,
+ "SUBSTRING-MATCH-BACKWARD-CI")
{
substring_match_prefix (end1, end2);
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/syntax.c,v 1.5 1987/07/16 00:51:08 cph Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/syntax.c,v 1.6 1987/11/17 08:18:08 jinx Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
\f
Built_In_Primitive (Prim_String_To_Syntax_Entry, 1, "STRING->SYNTAX-ENTRY",
0x176)
+Define_Primitive (Prim_String_To_Syntax_Entry, 1, "STRING->SYNTAX-ENTRY")
{
long length, c, result;
char *scan;
}
Built_In_Primitive (Prim_Char_To_Syntax_Code, 2, "CHAR->SYNTAX-CODE", 0x17E)
+Define_Primitive (Prim_Char_To_Syntax_Code, 2, "CHAR->SYNTAX-CODE")
{
Primitive_2_Args ();
/* Quote Parsers */
Built_In_Primitive (Prim_Quoted_Char_P, 4, "QUOTED-CHAR?", 0x17F)
+Define_Primitive (Prim_Quoted_Char_P, 4, "QUOTED-CHAR?")
{
NORMAL_INITIALIZATION_BACKWARD (Primitive_4_Args);
Built_In_Primitive (Prim_Scan_Backward_Prefix_Chars, 4,
"SCAN-BACKWARD-PREFIX-CHARS", 0x17D)
+Define_Primitive (Prim_Scan_Backward_Prefix_Chars, 4,
+ "SCAN-BACKWARD-PREFIX-CHARS")
{
NORMAL_INITIALIZATION_BACKWARD (Primitive_4_Args);
Built_In_Primitive (Prim_Scan_Forward_To_Word, 4,
"SCAN-FORWARD-TO-WORD", 0x17C)
+Define_Primitive (Prim_Scan_Forward_To_Word, 4,
+ "SCAN-FORWARD-TO-WORD")
{
NORMAL_INITIALIZATION_FORWARD (Primitive_4_Args);
}
Built_In_Primitive (Prim_Scan_Word_Forward, 4, "SCAN-WORD-FORWARD", 0x177)
+Define_Primitive (Prim_Scan_Word_Forward, 4, "SCAN-WORD-FORWARD")
{
NORMAL_INITIALIZATION_FORWARD (Primitive_4_Args);
}
Built_In_Primitive (Prim_Scan_Word_Backward, 4, "SCAN-WORD-BACKWARD", 0x178)
+Define_Primitive (Prim_Scan_Word_Backward, 4, "SCAN-WORD-BACKWARD")
{
NORMAL_INITIALIZATION_BACKWARD (Primitive_4_Args);
/* S-Expression Parsers */
Built_In_Primitive (Prim_Scan_List_Forward, 7, "SCAN-LIST-FORWARD", 0x179)
+Define_Primitive (Prim_Scan_List_Forward, 7, "SCAN-LIST-FORWARD")
{
SCAN_LIST_INITIALIZATION (NORMAL_INITIALIZATION_FORWARD);
}
\f
Built_In_Primitive (Prim_Scan_List_Backward, 7, "SCAN-LIST-BACKWARD", 0x17A)
+Define_Primitive (Prim_Scan_List_Backward, 7, "SCAN-LIST-BACKWARD")
{
SCAN_LIST_INITIALIZATION (NORMAL_INITIALIZATION_BACKWARD);
} while (0)
Built_In_Primitive (Prim_Scan_Sexps_Forward, 7, "SCAN-SEXPS-FORWARD", 0x17B)
+Define_Primitive (Prim_Scan_Sexps_Forward, 7, "SCAN-SEXPS-FORWARD")
{
long target_depth;
Boolean stop_before;
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/sysprim.c,v 9.26 1987/11/09 21:35:13 cph Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/sysprim.c,v 9.27 1987/11/17 08:18:22 jinx Exp $
*
* Random system primitives. Most are implemented in terms of
* utilities in os.c
Built_In_Primitive(Prim_Chk_And_Cln_Input_Channel, 2,
"CHECK-AND-CLEAN-UP-INPUT-CHANNEL", 0x107)
+Define_Primitive(Prim_Chk_And_Cln_Input_Channel, 2,
+ "CHECK-AND-CLEAN-UP-INPUT-CHANNEL")
{
extern Boolean OS_Clean_Interrupt_Channel();
Primitive_2_Args();
Built_In_Primitive(Prim_Get_Next_Interrupt_Char, 0,
"GET-NEXT-INTERRUPT-CHARACTER", 0x106)
+Define_Primitive(Prim_Get_Next_Interrupt_Char, 0,
+ "GET-NEXT-INTERRUPT-CHARACTER")
{
int result;
extern int OS_Get_Next_Interrupt_Character();
Primitive_Error(ERR_EXTERNAL_RETURN);
/*NOTREACHED*/
}
- IntCode &= ~INT_Character;
+ CLEAR_INTERRUPT(INT_Character);
PRIMITIVE_RETURN(Make_Unsigned_Fixnum(result));
}
\f
/* Time primitives */
Built_In_Primitive(Prim_System_Clock, 0, "SYSTEM-CLOCK", 0x109)
+Define_Primitive(Prim_System_Clock, 0, "SYSTEM-CLOCK")
{
Primitive_0_Args();
Built_In_Primitive(Prim_Setup_Timer_Interrupt, 2,
"SETUP-TIMER-INTERRUPT", 0x153)
+Define_Primitive(Prim_Setup_Timer_Interrupt, 2,
+ "SETUP-TIMER-INTERRUPT")
{
extern void Clear_Int_Timer(), Set_Int_Timer();
Primitive_2_Args();
Sign_Extend(Arg2, Centi_Seconds);
Set_Int_Timer(Days, Centi_Seconds);
}
- IntCode &= ~INT_Timer;
- New_Compiler_MemTop ();
+ CLEAR_INTERRUPT(INT_Timer);
PRIMITIVE_RETURN(NIL);
}
\f
}
Built_In_Primitive(Prim_Current_Year, 0, "CURRENT-YEAR", 0x126)
+Define_Primitive(Prim_Current_Year, 0, "CURRENT-YEAR")
Date_Primitive(OS_Current_Year)
Built_In_Primitive(Prim_Current_Month, 0, "CURRENT-MONTH", 0x127)
+Define_Primitive(Prim_Current_Month, 0, "CURRENT-MONTH")
Date_Primitive(OS_Current_Month)
Built_In_Primitive(Prim_Current_Day, 0, "CURRENT-DAY", 0x128)
+Define_Primitive(Prim_Current_Day, 0, "CURRENT-DAY")
Date_Primitive(OS_Current_Day)
Built_In_Primitive(Prim_Current_Hour, 0, "CURRENT-HOUR", 0x129)
+Define_Primitive(Prim_Current_Hour, 0, "CURRENT-HOUR")
Date_Primitive(OS_Current_Hour)
Built_In_Primitive(Prim_Current_Minute, 0, "CURRENT-MINUTE", 0x12A)
+Define_Primitive(Prim_Current_Minute, 0, "CURRENT-MINUTE")
Date_Primitive(OS_Current_Minute)
Built_In_Primitive(Prim_Current_Second, 0, "CURRENT-SECOND", 0x12B)
+Define_Primitive(Prim_Current_Second, 0, "CURRENT-SECOND")
Date_Primitive(OS_Current_Second)
\f
/* Pretty random primitives */
*/
Built_In_Primitive(Prim_Non_Restartable_Exit, 0, "EXIT", 0x16)
+Define_Primitive(Prim_Non_Restartable_Exit, 0, "EXIT")
{
Primitive_0_Args();
Not all operating systems support this.
*/
Built_In_Primitive(Prim_Restartable_Exit, 0, "HALT", 0x1A)
+Define_Primitive(Prim_Restartable_Exit, 0, "HALT")
{
extern Boolean Restartable_Exit();
Primitive_0_Args();
*/
Built_In_Primitive(Prim_Set_Run_Light, 1, "SET-RUN-LIGHT!", 0xC0)
+Define_Primitive(Prim_Set_Run_Light, 1, "SET-RUN-LIGHT!")
{
Primitive_1_Arg();
}
Built_In_Primitive( Prim_under_emacs_p, 0, "UNDER-EMACS?", 0x1A1)
+Define_Primitive( Prim_under_emacs_p, 0, "UNDER-EMACS?")
{
extern Boolean OS_Under_Emacs();
Primitive_0_Args();
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/types.h,v 9.25 1987/10/09 16:14:39 jinx Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/types.h,v 9.26 1987/11/17 08:18:54 jinx Rel $
*
* Type code definitions, numerical order
*
#define TC_COMPILED_PROCEDURE 0x0D
#define TC_BIG_FIXNUM 0x0E
#define TC_PROCEDURE 0x0F
-#define TC_PRIMITIVE_EXTERNAL 0x10
+/* 0x10 used to be TC_PRIMITIVE_EXTERNAL */
+/* if it is reused, define PRIMITIVE_EXTERNAL_REUSED below. */
+/* Unused 0x10 */
#define TC_DELAY 0x11
#define TC_ENVIRONMENT 0x12
#define TC_DELAYED 0x13
/* If you add a new type, don't forget to update gccode.h and gctype.c */
+/* Remove #if false and #endif if type code 0x10 is reused. */
+
+#if false
+#define PRIMITIVE_EXTERNAL_REUSED
+#endif
+
/* Aliases */
#define TC_FALSE TC_NULL
;;;; Machine Dependent Type Tables
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utabmd.scm,v 9.38 1987/10/09 16:14:47 jinx Rel $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utabmd.scm,v 9.39 1987/11/17 08:19:44 jinx Exp $
(declare (usual-integrations))
;;; [] Fixed
;;; [] Types
;;; [] Returns
-;;; [] Primitives
-;;; [] External
;;; [] Errors
;;; [] Identification
\f
OBARRAY ;03
MICROCODE-TYPES-VECTOR ;04
MICROCODE-RETURNS-VECTOR ;05
- MICROCODE-PRIMITIVES-VECTOR ;06
+ #F ;06
MICROCODE-ERRORS-VECTOR ;07
MICROCODE-IDENTIFICATION-VECTOR ;08
#F ;09
#F ;0D
STEPPER-STATE ;0E
MICROCODE-FIXED-OBJECTS-SLOTS ;0F
- MICROCODE-EXTERNAL-PRIMITIVES ;10
+ #F ;10
STATE-SPACE-TAG ;11
STATE-POINT-TAG ;12
DUMMY-HISTORY ;13
COMPILED-PROCEDURE ;0D
(BIGNUM BIG-FIXNUM) ;0E
PROCEDURE ;0F
- PRIMITIVE-EXTERNAL ;10
+ #F ;10
DELAY ;11
ENVIRONMENT ;12
DELAYED ;13
COMPILER-CACHE-ASSIGNMENT-RESTART ;5A
))
\f
-;;; [] Primitives
-
-(vector-set! (get-fixed-objects-vector)
- 6 ;(fixed-objects-vector-slot 'MICROCODE-PRIMITIVES-VECTOR)
- #(LEXICAL-ASSIGNMENT ;$00
- LOCAL-REFERENCE ;$01
- LOCAL-ASSIGNMENT ;$02
- CALL-WITH-CURRENT-CONTINUATION ;$03
- SCODE-EVAL ;$04
- APPLY ;$05
- SET-INTERRUPT-ENABLES! ;$06
- STRING->SYMBOL ;$07
- GET-WORK ;$08
- NON-REENTRANT-CALL-WITH-CURRENT-CONTINUATION ;$09
- CURRENT-DYNAMIC-STATE ;$0A
- SET-CURRENT-DYNAMIC-STATE! ;$0B
- (NULL? NOT FALSE?) ;$0C
- EQ? ;$0D
- STRING-EQUAL? ;$0E
- PRIMITIVE-TYPE? ;$0F
- PRIMITIVE-TYPE ;$10
- PRIMITIVE-SET-TYPE ;$11
- LEXICAL-REFERENCE ;$12
- LEXICAL-UNREFERENCEABLE? ;$13
- MAKE-CHAR ;$14
- CHAR-BITS ;$15
- EXIT ;$16
- CHAR-CODE ;$17
- LEXICAL-UNASSIGNED? ;$18
- INSERT-NON-MARKED-VECTOR! ;$19
- HALT ;$1A
- CHAR->INTEGER ;$1B
- MEMQ ;$1C
- INSERT-STRING ;$1D
- ENABLE-INTERRUPTS! ;$1E
- MAKE-EMPTY-STRING ;$1F
- CONS ;$20
- (CAR FIRST) ;$21
- (CDR FIRST-TAIL) ;$22
- (SET-CAR! SET-FIRST!) ;$23
- (SET-CDR! SET-FIRST-TAIL!) ;$24
- GET-COMMAND-LINE ;$25
- TTY-GET-CURSOR ;$26
- GENERAL-CAR-CDR ;$27
- HUNK3-CONS ;$28
- HUNK3-CXR ;$29
- HUNK3-SET-CXR! ;$2A
- INSERT-STRING! ;$2B
- VECTOR-CONS ;$2C
- (VECTOR-LENGTH VECTOR-SIZE) ;$2D
- VECTOR-REF ;$2E
- SET-CURRENT-HISTORY! ;$2F
- VECTOR-SET! ;$30
- NON-MARKED-VECTOR-CONS ;$31
- #F ;$32
- LEXICAL-UNBOUND? ;$33
- INTEGER->CHAR ;$34
- CHAR-DOWNCASE ;$35
- CHAR-UPCASE ;$36
- ASCII->CHAR ;$37
- CHAR-ASCII? ;$38
- CHAR->ASCII ;$39
- GARBAGE-COLLECT ;$3A
- PLUS-FIXNUM ;$3B
- MINUS-FIXNUM ;$3C
- MULTIPLY-FIXNUM ;$3D
- DIVIDE-FIXNUM ;$3E
- EQUAL-FIXNUM? ;$3F
- LESS-THAN-FIXNUM? ;$40
- POSITIVE-FIXNUM? ;$41
- ONE-PLUS-FIXNUM ;$42
- MINUS-ONE-PLUS-FIXNUM ;$43
- TRUNCATE-STRING! ;$44
- SUBSTRING ;$45
- ZERO-FIXNUM? ;$46
- #F ;$47
- #F ;$48
- #F ;$49
- SUBSTRING->LIST ;$4A
- MAKE-FILLED-STRING ;$4B
- PLUS-BIGNUM ;$4C
- MINUS-BIGNUM ;$4D
- MULTIPLY-BIGNUM ;$4E
- DIVIDE-BIGNUM ;$4F
- LISTIFY-BIGNUM ;$50
- EQUAL-BIGNUM? ;$51
- LESS-THAN-BIGNUM? ;$52
- POSITIVE-BIGNUM? ;$53
- FILE-OPEN-CHANNEL ;$54
- FILE-CLOSE-CHANNEL ;$55
- PRIMITIVE-FASDUMP ;$56
- BINARY-FASLOAD ;$57
- STRING-POSITION ;$58
- STRING-LESS? ;$59
- #F ;$5A
- #F ;$5B
- REHASH ;$5C
- LENGTH ;$5D
- ASSQ ;$5E
- LIST->STRING ;$5F
- EQUAL-STRING-TO-LIST? ;$60
- MAKE-CELL ;$61
- CELL-CONTENTS ;$62
- CELL? ;$63
- CHARACTER-UPCASE ;$64
- CHARACTER-LIST-HASH ;$65
- GCD-FIXNUM ;$66
- COERCE-FIXNUM-TO-BIGNUM ;$67
- COERCE-BIGNUM-TO-FIXNUM ;$68
- PLUS-FLONUM ;$69
- MINUS-FLONUM ;$6A
- MULTIPLY-FLONUM ;$6B
- DIVIDE-FLONUM ;$6C
- EQUAL-FLONUM? ;$6D
- LESS-THAN-FLONUM? ;$6E
- ZERO-BIGNUM? ;$6F
- TRUNCATE-FLONUM ;$70
- ROUND-FLONUM ;$71
- COERCE-INTEGER-TO-FLONUM ;$72
- SINE-FLONUM ;$73
- COSINE-FLONUM ;$74
- ARCTAN-FLONUM ;$75
- EXP-FLONUM ;$76
- LN-FLONUM ;$77
- SQRT-FLONUM ;$78
- #F #| PRIMITIVE-FASLOAD |# ;$79
- GET-FIXED-OBJECTS-VECTOR ;$7A
- SET-FIXED-OBJECTS-VECTOR! ;$7B
- LIST->VECTOR ;$7C
- SUBVECTOR->LIST ;$7D
- PAIR? ;$7E
- NEGATIVE-FIXNUM? ;$7F
- NEGATIVE-BIGNUM? ;$80
- GREATER-THAN-FIXNUM? ;$81
- GREATER-THAN-BIGNUM? ;$82
- STRING-HASH ;$83
- SYSTEM-PAIR-CONS ;$84
- SYSTEM-PAIR? ;$85
- SYSTEM-PAIR-CAR ;$86
- SYSTEM-PAIR-CDR ;$87
- SYSTEM-PAIR-SET-CAR! ;$88
- SYSTEM-PAIR-SET-CDR! ;$89
- STRING-HASH-MOD ;$8A
- #F ;$8B
- SET-CELL-CONTENTS! ;$8C
- &MAKE-OBJECT ;$8D
- SYSTEM-HUNK3-CXR0 ;$8E
- SYSTEM-HUNK3-SET-CXR0! ;$8F
- MAP-MACHINE-ADDRESS-TO-CODE ;$90
- SYSTEM-HUNK3-CXR1 ;$91
- SYSTEM-HUNK3-SET-CXR1! ;$92
- MAP-CODE-TO-MACHINE-ADDRESS ;$93
- SYSTEM-HUNK3-CXR2 ;$94
- SYSTEM-HUNK3-SET-CXR2! ;$95
- PRIMITIVE-PROCEDURE-ARITY ;$96
- SYSTEM-LIST-TO-VECTOR ;$97
- SYSTEM-SUBVECTOR-TO-LIST ;$98
- SYSTEM-VECTOR? ;$99
- SYSTEM-VECTOR-REF ;$9A
- SYSTEM-VECTOR-SET! ;$9B
- WITH-HISTORY-DISABLED ;$9C
- SUBVECTOR-MOVE-RIGHT! ;$9D
- SUBVECTOR-MOVE-LEFT! ;$9E
- SUBVECTOR-FILL! ;$9F
- #F ;$A0
- #F ;$A1
- #F ;$A2
- VECTOR-8B-CONS ;$A3
- VECTOR-8B? ;$A4
- VECTOR-8B-REF ;$A5
- VECTOR-8B-SET! ;$A6
- ZERO-FLONUM? ;$A7
- POSITIVE-FLONUM? ;$A8
- NEGATIVE-FLONUM? ;$A9
- GREATER-THAN-FLONUM? ;$AA
- INTERN-CHARACTER-LIST ;$AB
- COMPILED-CODE-ADDRESS->OFFSET ;$AC
- (STRING-SIZE VECTOR-8B-SIZE) ;$AD
- SYSTEM-VECTOR-SIZE ;$AE
- FORCE ;$AF
- PRIMITIVE-DATUM ;$B0
- MAKE-NON-POINTER-OBJECT ;$B1
- DEBUGGING-PRINTER ;$B2
- STRING-UPCASE ;$B3
- PRIMITIVE-PURIFY ;$B4
- COMPILED-CODE-ADDRESS->BLOCK ;$B5
- #F #| COMPLETE-GARBAGE-COLLECT |# ;$B6
- DUMP-BAND ;$B7
- SUBSTRING-SEARCH ;$B8
- LOAD-BAND ;$B9
- CONSTANT? ;$BA
- PURE? ;$BB
- PRIMITIVE-GC-TYPE ;$BC
- PRIMITIVE-IMPURIFY ;$BD
- WITH-THREADED-CONTINUATION ;$BE
- WITHIN-CONTROL-POINT ;$BF
- SET-RUN-LIGHT! ;$C0
- FILE-EOF? ;$C1
- FILE-READ-CHAR ;$C2
- FILE-FILL-INPUT-BUFFER ;$C3
- FILE-LENGTH ;$C4
- FILE-WRITE-CHAR ;$C5
- FILE-WRITE-STRING ;$C6
- CLOSE-LOST-OPEN-FILES ;$C7
- #F ;$C8
- WITH-INTERRUPTS-REDUCED ;$C9
- PRIMITIVE-EVAL-STEP ;$CA
- PRIMITIVE-APPLY-STEP ;$CB
- PRIMITIVE-RETURN-STEP ;$CC
- TTY-READ-CHAR-READY? ;$CD
- TTY-READ-CHAR ;$CE
- TTY-READ-CHAR-IMMEDIATE ;$CF
- TTY-READ-FINISH ;$D0
- BIT-STRING-ALLOCATE ;$D1
- MAKE-BIT-STRING ;$D2
- BIT-STRING? ;$D3
- BIT-STRING-LENGTH ;$D4
- BIT-STRING-REF ;$D5
- BIT-SUBSTRING-MOVE-RIGHT! ;$D6
- BIT-STRING-SET! ;$D7
- BIT-STRING-CLEAR! ;$D8
- BIT-STRING-ZERO? ;$D9
- BIT-SUBSTRING-FIND-NEXT-SET-BIT ;$DA
- #F ;$DB
- UNSIGNED-INTEGER->BIT-STRING ;$DC
- BIT-STRING->UNSIGNED-INTEGER ;$DD
- #F ;$DE
- READ-BITS! ;$DF
- WRITE-BITS! ;$E0
- MAKE-STATE-SPACE ;$E1
- EXECUTE-AT-NEW-STATE-POINT ;$E2
- TRANSLATE-TO-STATE-POINT ;$E3
- GET-NEXT-CONSTANT ;$E4
- MICROCODE-IDENTIFY ;$E5
- ZERO? ;$E6
- POSITIVE? ;$E7
- NEGATIVE? ;$E8
- &= ;$E9
- &< ;$EA
- &> ;$EB
- &+ ;$EC
- &- ;$ED
- &* ;$EE
- &/ ;$EF
- INTEGER-DIVIDE ;$F0
- 1+ ;$F1
- -1+ ;$F2
- TRUNCATE ;$F3
- ROUND ;$F4
- FLOOR ;$F5
- CEILING ;$F6
- SQRT ;$F7
- EXP ;$F8
- LOG ;$F9
- SIN ;$FA
- COS ;$FB
- &ATAN ;$FC
- TTY-WRITE-CHAR ;$FD
- TTY-WRITE-STRING ;$FE
- TTY-BEEP ;$FF
- TTY-CLEAR ;$100
- GET-EXTERNAL-COUNTS ;$101
- GET-EXTERNAL-NAME ;$102
- GET-EXTERNAL-NUMBER ;$103
- #F ;$104
- #F ;$105
- GET-NEXT-INTERRUPT-CHARACTER ;$106
- CHECK-AND-CLEAN-UP-INPUT-CHANNEL ;$107
- #F ;$108
- SYSTEM-CLOCK ;$109
- FILE-EXISTS? ;$10A
- #F ;$10B
- TTY-MOVE-CURSOR ;$10C
- #F ;$10D
- #F #| CURRENT-DATE |# ;$10E
- #F #| CURRENT-TIME |# ;$10F
- #F #| TRANSLATE-FILE |# ;$110
- COPY-FILE ;$111
- RENAME-FILE ;$112
- REMOVE-FILE ;$113
- LINK-FILE ;$114
- MAKE-DIRECTORY ;$115
- #F #| VOLUME-NAME |# ;$116
- SET-WORKING-DIRECTORY-PATHNAME! ;$117
- RE-MATCH-SUBSTRING ;$118
- RE-SEARCH-SUBSTRING-FORWARD ;$119
- RE-SEARCH-SUBSTRING-BACKWARD ;$11A
- #F ;$11B
- #F ;$11C
- #F ;$11D
- #F ;$11E
- #F ;$11F
- #F ;$120
- #F ;$121
- #F ;$122
- #F ;$123
- #F ;$124
- #F ;$125
- CURRENT-YEAR ;$126
- CURRENT-MONTH ;$127
- CURRENT-DAY ;$128
- CURRENT-HOUR ;$129
- CURRENT-MINUTE ;$12A
- CURRENT-SECOND ;$12B
- #F #| INIT-FLOPPY |# ;$12C
- #F #| ZERO-FLOPPY |# ;$12D
- #F #| PACK-VOLUME |# ;$12E
- #F #| LOAD-PICTURE |# ;$12F
- #F #| STORE-PICTURE |# ;$130
- #F #| LOOKUP-SYSTEM-SYMBOL |# ;$131
- #F ;$132
- #F ;$133
- CLEAR-TO-END-OF-LINE ;$134
- #F ;$135
- #F ;$136
- WITH-INTERRUPT-MASK ;$137
- STRING? ;$138
- STRING-LENGTH ;$139
- STRING-REF ;$13A
- STRING-SET! ;$13B
- SUBSTRING-MOVE-RIGHT! ;$13C
- SUBSTRING-MOVE-LEFT! ;$13D
- STRING-ALLOCATE ;$13E
- STRING-MAXIMUM-LENGTH ;$13F
- SET-STRING-LENGTH! ;$140
- VECTOR-8B-FILL! ;$141
- VECTOR-8B-FIND-NEXT-CHAR ;$142
- VECTOR-8B-FIND-PREVIOUS-CHAR ;$143
- VECTOR-8B-FIND-NEXT-CHAR-CI ;$144
- VECTOR-8B-FIND-PREVIOUS-CHAR-CI ;$145
- SUBSTRING-FIND-NEXT-CHAR-IN-SET ;$146
- SUBSTRING-FIND-PREVIOUS-CHAR-IN-SET ;$147
- SUBSTRING=? ;$148
- SUBSTRING-CI=? ;$149
- SUBSTRING<? ;$14A
- SUBSTRING-UPCASE! ;$14B
- SUBSTRING-DOWNCASE! ;$14C
- SUBSTRING-MATCH-FORWARD ;$14D
- SUBSTRING-MATCH-BACKWARD ;$14E
- SUBSTRING-MATCH-FORWARD-CI ;$14F
- SUBSTRING-MATCH-BACKWARD-CI ;$150
- PHOTO-OPEN ;$151
- PHOTO-CLOSE ;$152
- SETUP-TIMER-INTERRUPT ;$153
- #F ;$154
- #F ;$155
- #F ;$156
- #F ;$157
- #F ;$158
- #F ;$159
- #F ;$15A
- #F ;$15B
- #F ;$15C
- #F ;$15D
- #F ;$15E
- #F ;$15F
- #F ;$160
- #F #| EXTRACT-NON-MARKED-VECTOR |# ;$161
- #F #| UNSNAP-LINKS! |# ;$162
- #F #| SAFE-PRIMITIVE? |# ;$163
- #F #| SUBSTRING-READ |# ;$164
- #F #| SUBSTRING-WRITE |# ;$165
- SCREEN-X-SIZE ;$166
- SCREEN-Y-SIZE ;$167
- #F #| SCREEN-WRITE-CURSOR |# ;$168
- #F #| SCREEN-WRITE-CHARACTER |# ;$169
- #F #| SCREEN-WRITE-SUBSTRING |# ;$16A
- #F #| NEXT-FILE-MATCHING |# ;$16B
- #F ;$16C
- #F #| TTY-WRITE-BYTE |# ;$16D
- #F #| FILE-READ-BYTE |# ;$16E
- #F #| FILE-WRITE-BYTE |# ;$16F
- #F #| SAVE-SCREEN |# ;$170
- #F #| RESTORE-SCREEN! |# ;$171
- #F #| SUBSCREEN-CLEAR! |# ;$172
- #F #| &GCD |# ;$173
- #F #| TTY-REDRAW-SCREEN |# ;$174
- #F #| SCREEN-INVERSE-VIDEO! |# ;$175
- STRING->SYNTAX-ENTRY ;$176
- SCAN-WORD-FORWARD ;$177
- SCAN-WORD-BACKWARD ;$178
- SCAN-LIST-FORWARD ;$179
- SCAN-LIST-BACKWARD ;$17A
- SCAN-SEXPS-FORWARD ;$17B
- SCAN-FORWARD-TO-WORD ;$17C
- SCAN-BACKWARD-PREFIX-CHARS ;$17D
- CHAR->SYNTAX-CODE ;$17E
- QUOTED-CHAR? ;$17F
- MICROCODE-TABLES-FILENAME ;$180
- #F ;$181
- #F #| FIND-PASCAL-PROGRAM |# ;$182
- #F #| EXECUTE-PASCAL-PROGRAM |# ;$183
- #F #| GRAPHICS-MOVE |# ;$184
- #F #| GRAPHICS-LINE |# ;$185
- #F #| GRAPHICS-PIXEL |# ;$186
- #F #| GRAPHICS-SET-DRAWING-MODE |# ;$187
- #F #| ALPHA-RASTER? |# ;$188
- #F #| TOGGLE-ALPHA-RASTER |# ;$189
- #F #| GRAPHICS-RASTER? |# ;$18A
- #F #| TOGGLE-GRAPHICS-RASTER |# ;$18B
- #F #| GRAPHICS-CLEAR |# ;$18C
- #F #| GRAPHICS-SET-LINE-STYLE |# ;$18D
- ERROR-PROCEDURE ;$18E
- BIT-STRING-XOR! ;$18F
- RE-CHAR-SET-ADJOIN! ;$190
- RE-COMPILE-FASTMAP ;$191
- RE-MATCH-BUFFER ;$192
- RE-SEARCH-BUFFER-FORWARD ;$193
- RE-SEARCH-BUFFER-BACKWARD ;$194
- (SYSTEM-MEMORY-REF &OBJECT-REF) ;$195
- (SYSTEM-MEMORY-SET! &OBJECT-SET!) ;$196
- BIT-STRING-FILL! ;$197
- BIT-STRING-MOVE! ;$198
- BIT-STRING-MOVEC! ;$199
- BIT-STRING-OR! ;$19A
- BIT-STRING-AND! ;$19B
- BIT-STRING-ANDC! ;$19C
- BIT-STRING=? ;$19D
- WORKING-DIRECTORY-PATHNAME ;$19E
- OPEN-DIRECTORY ;$19F
- DIRECTORY-READ ;$1A0
- UNDER-EMACS? ;$1A1
- TTY-FLUSH-OUTPUT ;$1A2
- RELOAD-BAND-NAME ;$1A3
- ))
-\f
-;;; [] External
-
-(vector-set! (get-fixed-objects-vector)
- 16 ;(fixed-objects-vector-slot 'MICROCODE-EXTERNAL-PRIMITIVES)
- #())
-\f
;;; [] Errors
(vector-set! (get-fixed-objects-vector)
COMPILED-CODE-ERROR ;31
FLOATING-OVERFLOW ;32
UNIMPLEMENTED-PRIMITIVE ;33
+ ILLEGAL-REFERENCE-TRAP ;34
+ BROKEN-VARIABLE-CACHE ;35
+ WRONG-ARITY-PRIMITIVES ;36
+ IO-ERROR ;37
))
\f
;;; [] Terminations
;;; This identification string is saved by the system.
-"$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utabmd.scm,v 9.38 1987/10/09 16:14:47 jinx Rel $"
+"$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utabmd.scm,v 9.39 1987/11/17 08:19:44 jinx Exp $"
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.34 1987/10/09 16:15:08 jinx Rel $ */
+/* $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 $ */
/* This file contains utilities for interrupts, errors, etc. */
long i, Int_Number, The_Int_Code, New_Int_Enb;
long Save_Space;
- The_Int_Code = IntCode;
+ The_Int_Code = FETCH_INTERRUPT_CODE();
Int_Vector = (Get_Fixed_Obj_Slot (System_Interrupt_Vector));
/* The interrupt vector is normally of size (MAX_INTERRUPT_NUMBER + 1).
Int_Number = 0;
i = 1;
while (true)
+ {
+ if (Int_Number > MAX_INTERRUPT_NUMBER)
+ {
+ New_Int_Enb = FETCH_INTERRUPT_MASK();
+ break;
+ }
+ if ((Masked_Interrupts & i) != 0)
{
- if (Int_Number > MAX_INTERRUPT_NUMBER)
- {
- New_Int_Enb = IntEnb;
- break;
- }
- if ((Masked_Interrupts & i) != 0)
- {
- New_Int_Enb = ((1 << Int_Number) - 1);
- break;
- }
- Int_Number += 1;
- i = (i << 1);
+ New_Int_Enb = ((1 << Int_Number) - 1);
+ break;
}
+ Int_Number += 1;
+ i = (i << 1);
+ }
/* Handle case where interrupt vector is too small. */
if (Int_Number >= (Vector_Length (Int_Vector)))
Int_Number, (Vector_Length (Int_Vector)));
fprintf (stderr,
"Interrupts = 0x%x, Mask= 0x%x, Masked = 0x%x\n",
- IntCode, IntEnb, Masked_Interrupts);
+ FETCH_INTERRUPT_CODE(),
+ FETCH_INTERRUPT_MASK(),
+ Masked_Interrupts);
Microcode_Termination (TERM_NO_INTERRUPT_HANDLER);
}
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;
+ if ((New_Int_Enb + 1) == INT_GC)
+ {
+ Save_Space += CONTINUATION_SIZE;
+ }
Will_Push(Save_Space);
/* Return from interrupt handler will re-enable interrupts */
Store_Return(RC_RESTORE_INT_MASK);
- Store_Expression(Make_Unsigned_Fixnum(IntEnb));
+ Store_Expression(MAKE_SIGNED_FIXNUM(FETCH_INTERRUPT_MASK()));
Save_Cont();
- if (New_Int_Enb+1 == INT_GC)
- { Store_Return(RC_GC_CHECK);
+ if ((New_Int_Enb + 1) == INT_GC)
+ {
+ Store_Return(RC_GC_CHECK);
Store_Expression(Make_Unsigned_Fixnum(GC_Space_Needed));
Save_Cont();
}
* the currently enabled interrupts.
*/
- Push(Make_Unsigned_Fixnum(IntEnb));
- Push(Make_Unsigned_Fixnum(The_Int_Code));
+ Push(MAKE_SIGNED_FIXNUM(FETCH_INTERRUPT_MASK()));
+ Push(MAKE_SIGNED_FIXNUM(The_Int_Code));
Push(Handler);
Push(STACK_FRAME_HEADER+2);
Pushed();
- IntEnb = New_Int_Enb; /* Turn off interrupts */
- New_Compiler_MemTop();
+ /* Turn off interrupts */
+ SET_INTERRUPT_MASK(New_Int_Enb);
+ return;
}
\f
- /******************/
- /* ERROR HANDLING */
- /******************/
-
-/* It is assumed that any caller of the error code has already
- * restored its state to a situation which will make it
- * restartable if the error handler returns normally. As a
- * result, the only work to be done on an error is to verify
- * that there is an error handler, save the current continuation and
- * create a new one if entered from Pop_Return rather than Eval,
- * turn off interrupts, and call it with two arguments: Error-Code
- * and Interrupt-Enables.
- */
+/* Error processing utilities */
void
-Err_Print (Micro_Error)
- long Micro_Error;
-{ switch (Micro_Error)
- {
-/* case ERR_BAD_ERROR_CODE:
- printf("unknown error code.\n"); break;
-*/
- case ERR_UNBOUND_VARIABLE:
- printf("unbound variable.\n"); break;
- case ERR_UNASSIGNED_VARIABLE:
- printf("unassigned variable.\n"); break;
- case ERR_INAPPLICABLE_OBJECT:
- printf("Inapplicable operator.\n"); break;
- case ERR_BAD_FRAME:
- printf("bad environment frame.\n"); break;
- case ERR_BROKEN_COMPILED_VARIABLE:
- printf("compiled variable invalid.\n"); break;
- case ERR_UNDEFINED_USER_TYPE:
- printf("undefined type code.\n"); break;
- case ERR_UNDEFINED_PRIMITIVE:
- printf("undefined primitive.\n"); break;
- case ERR_EXTERNAL_RETURN:
- printf("error during 'external' primitive.\n"); break;
- case ERR_EXECUTE_MANIFEST_VECTOR:
- printf("attempt to EVAL a vector.\n"); break;
- case ERR_WRONG_NUMBER_OF_ARGUMENTS:
- printf("wrong number of arguments.\n"); break;
- case ERR_ARG_1_WRONG_TYPE:
- printf("type error argument 1.\n"); break;
- case ERR_ARG_2_WRONG_TYPE:
- printf("type error argument 2.\n"); break;
-
-/* Err_Print continues on the next page */
-\f
-/* Err_Print, continued */
-
- case ERR_ARG_3_WRONG_TYPE:
- printf("type error argument 3.\n"); break;
- case ERR_ARG_1_BAD_RANGE:
- printf("range error argument 1.\n"); break;
- case ERR_ARG_2_BAD_RANGE:
- printf("range error, argument 2.\n"); break;
- case ERR_ARG_3_BAD_RANGE:
- printf("range error, argument 3.\n"); break;
- case ERR_FASL_FILE_TOO_BIG:
- printf("FASL file too large to load.\n"); break;
- case ERR_FASL_FILE_BAD_DATA:
- printf("No such file or not FASL format.\n"); break;
- case ERR_IMPURIFY_OUT_OF_SPACE:
- printf("Not enough room to impurify object.\n"); break;
- case ERR_WRITE_INTO_PURE_SPACE:
- printf("Write into pure area\n"); break;
- case ERR_BAD_SET:
- printf("Attempt to perform side-effect on 'self'.\n"); break;
- case ERR_ARG_1_FAILED_COERCION:
- printf("First argument couldn't be coerced.\n"); break;
- case ERR_ARG_2_FAILED_COERCION:
- printf("Second argument couldn't be coerced.\n"); break;
- case ERR_OUT_OF_FILE_HANDLES:
- printf("Too many open files.\n"); break;
- default:
- printf("Unknown error 0x%x occurred\n.", Micro_Error);
- break;
+err_print(error_code, where)
+ long error_code;
+ FILE *where;
+{
+ extern char *Error_Names[];
+
+ if (error_code > MAX_ERROR)
+ {
+ fprintf(where, "Unknown error code 0x%x.\n", error_code);
+ }
+ else
+ {
+ fprintf(where, "Error code 0x%x (%s).\n",
+ error_code,
+ Error_Names[error_code]);
}
return;
}
+extern long death_blow;
+long death_blow;
+
+void
+error_death(code, message)
+ long code;
+ char *message;
+{
+ death_blow = code;
+ fprintf(stderr, "\nMicrocode Error: %s.\n", message);
+ err_print(code, stderr);
+ fprintf(stderr, "\n**** Stack Trace ****\n\n");
+ Back_Trace(stderr);
+ Microcode_Termination(TERM_NO_ERROR_HANDLER);
+ /*NOTREACHED*/
+}
+
void
-Stack_Death ()
+Stack_Death()
{
fprintf(stderr, "\nWill_Push vs. Pushed inconsistency.\n");
Microcode_Termination(TERM_BAD_STACK);
-}
+ /*NOTREACHED*/
+}
\f
/* Back_Out_Of_Primitive sets the registers up so that the backout
- * mechanism in interpret.c will push the primitive number and
- * an appropriate return code so that the primitive can be
- * restarted.
+ * mechanism in interpret.c will cause the primitive to be
+ * restarted if the error/interrupt is proceeded.
*/
-#if (TC_PRIMITIVE == 0) || (TC_PRIMITIVE_EXTERNAL == 0)
-#include "Error: Some primitive type is 0"
-#endif
-
void
Back_Out_Of_Primitive ()
{
- long nargs;
- Pointer expression = Fetch_Expression();
-
- /* When primitives are called from compiled code, the type code may
- * not be in the expression register.
- */
-
- if (OBJECT_TYPE(expression) == 0)
- {
- expression = Make_Non_Pointer(TC_PRIMITIVE, expression);
- Store_Expression(expression);
- }
+ long nargs, code;
+ Pointer primitive;
/* Setup a continuation to return to compiled code if the primitive is
* restarted and completes successfully.
*/
- nargs = N_Args_Primitive(Get_Integer(expression));
+ primitive = Fetch_Expression();
+ code = OBJECT_DATUM(primitive);
+ nargs = PRIMITIVE_N_ARGUMENTS(code);
if (OBJECT_TYPE(Stack_Ref(nargs)) == TC_RETURN_ADDRESS)
{
- /* This clobbers the expression register. */
compiler_apply_procedure(nargs);
- Store_Expression(expression);
}
- /* When you come back to the primitive, the environment is
- * irrelevant .... primitives run with no real environment.
- * Similarly, the value register is meaningless.
- */
- Store_Return(RC_REPEAT_PRIMITIVE);
+ Push(primitive);
+ Push(STACK_FRAME_HEADER + nargs);
Store_Env(Make_Non_Pointer(GLOBAL_ENV, END_OF_CHAIN));
Val = NIL;
+ Store_Return(RC_INTERNAL_APPLY);
+ Store_Expression(NIL);
+ return;
}
\f
/* Useful error procedures */
Back_Out_Of_Primitive();
Save_Cont();
Store_Return(RC_RESTORE_INT_MASK);
- Store_Expression(Make_Unsigned_Fixnum(IntEnb));
- IntEnb = (local_mask);
+ Store_Expression(MAKE_SIGNED_FIXNUM(FETCH_INTERRUPT_MASK()));
+ SET_INTERRUPT_MASK(local_mask);
PRIMITIVE_ABORT(PRIM_INTERRUPT);
/*NOTREACHED*/
}
argument = (ARG_REF (n));
if (! (FIXNUM_P (argument)))
+ {
error_wrong_type_arg (n);
+ }
return
((FIXNUM_NEGATIVE_P (argument))
? ((UNSIGNED_FIXNUM_VALUE (argument)) | (-1 << ADDRESS_LENGTH))
argument = (ARG_REF (n));
if (! (FIXNUM_P (argument)))
+ {
error_wrong_type_arg (n);
+ }
if (FIXNUM_NEGATIVE_P (argument))
+ {
error_bad_range_arg (n);
+ }
return (UNSIGNED_FIXNUM_VALUE (argument));
}
-
+\f
long
arg_index_integer (n, upper_limit)
int n;
argument = (ARG_REF (n));
if (! (FIXNUM_P (argument)))
+ {
error_wrong_type_arg (n);
+ }
if (FIXNUM_NEGATIVE_P (argument))
+ {
error_bad_range_arg (n);
+ }
result = (UNSIGNED_FIXNUM_VALUE (argument));
if (result >= upper_limit)
+ {
error_bad_range_arg (n);
+ }
return (result);
}
\f
+ /******************/
+ /* ERROR HANDLING */
+ /******************/
+
+/* It is assumed that any caller of the error code has already
+ * restored its state to a situation which will make it
+ * restartable if the error handler returns normally. As a
+ * result, the only work to be done on an error is to verify
+ * that there is an error handler, save the current continuation and
+ * create a new one if entered from Pop_Return rather than Eval,
+ * turn off interrupts, and call it with two arguments: Error-Code
+ * and Interrupt-Enables.
+ */
+
void
Do_Micro_Error (Err, From_Pop_Return)
long Err;
Pointer Error_Vector, Handler;
if (Consistency_Check)
- { Err_Print(Err);
+ {
+ err_print(Err, stdout);
Print_Expression(Fetch_Expression(), "Expression was");
printf("\nEnvironment 0x%x (#%o).\n", Fetch_Env(), Fetch_Env());
Print_Return("Return code");
- printf( "\n");
+ printf("\n");
}
Error_Exit_Hook();
if (Trace_On_Error)
{
- printf( "\n**** Stack Trace ****\n\n");
- Back_Trace();
+ printf("\n\n**** Stack Trace ****\n\n");
+ Back_Trace(stdout);
}
#ifdef ENABLE_DEBUGGING_TOOLS
{
int *From = &(local_circle[0]), *To = &(debug_circle[0]), i;
- for (i=0; i < local_nslots; i++) *To++ = *From++;
+ for (i = 0; i < local_nslots; i++)
+ {
+ *To++ = *From++;
+ }
debug_nslots = local_nslots;
debug_slotno = local_slotno;
}
Get_Fixed_Obj_Slot(System_Error_Vector))) !=
TC_VECTOR))
{
- fprintf(stderr,
- "\nMicrocode Error: code = 0x%x; Bad error handlers vector.\n",
- Err);
- printf("\n**** Stack Trace ****\n\n");
- Back_Trace();
- Microcode_Termination(TERM_NO_ERROR_HANDLER, Err);
+ error_death(Err, "Bad error handlers vector");
+ /*NOTREACHED*/
}
if ((Err < 0) || (Err >= (Vector_Length (Error_Vector))))
+ {
+ if (Vector_Length(Error_Vector) == 0)
{
- if (Vector_Length(Error_Vector) == 0)
- {
- fprintf(stderr,
- "\nMicrocode Error: code = 0x%x; Empty error handlers vector.\n",
- Err);
- printf("\n**** Stack Trace ****\n\n");
- Back_Trace();
- Microcode_Termination(TERM_NO_ERROR_HANDLER, Err);
- }
- Handler = (User_Vector_Ref (Error_Vector, ERR_BAD_ERROR_CODE));
+ error_death(Err, "Empty error handlers vector");
+ /*NOTREACHED*/
}
+ Handler = (User_Vector_Ref (Error_Vector, ERR_BAD_ERROR_CODE));
+ }
else
+ {
Handler = (User_Vector_Ref (Error_Vector, Err));
+ }
\f
/* This can NOT be folded into the Will_Push below since we cannot
afford to have the Will_Push put down its own continuation.
Save_Cont();
Pushed();
}
- Will_Push(STACK_ENV_EXTRA_SLOTS+3+2*CONTINUATION_SIZE+HISTORY_SIZE+
+ Will_Push(STACK_ENV_EXTRA_SLOTS + 3 +
+ 2 * CONTINUATION_SIZE +
+ HISTORY_SIZE +
(From_Pop_Return ? 0 : 1));
if (From_Pop_Return)
+ {
Store_Expression(Val);
+ }
else
+ {
Push(Fetch_Env());
+ }
Store_Return((From_Pop_Return) ?
RC_POP_RETURN_ERROR :
Stop_History();
Store_Return(RC_RESTORE_INT_MASK);
- Store_Expression(Make_Unsigned_Fixnum(IntEnb));
+ Store_Expression(MAKE_SIGNED_FIXNUM(FETCH_INTERRUPT_MASK()));
Save_Cont();
- Push(Make_Unsigned_Fixnum(IntEnb)); /* Arg 2: Int. mask */
+ /* Arg 2: Int. mask */
+ Push(MAKE_SIGNED_FIXNUM(FETCH_INTERRUPT_MASK()));
+ /* Arg 1: Err. No */
if ((Err >= SMALLEST_FIXNUM) && (Err <= BIGGEST_FIXNUM))
- Push(Make_Signed_Fixnum(Err)); /* Arg 1: Err. No */
+ {
+ Push(Make_Signed_Fixnum(Err));
+ }
else
+ {
Push (Make_Unsigned_Fixnum (ERR_BAD_ERROR_CODE));
- Push(Handler); /* Procedure: Handler */
- Push(STACK_FRAME_HEADER+2);
+ }
+ /* Procedure: Handler */
+ Push(Handler);
+ Push(STACK_FRAME_HEADER + 2);
Pushed();
- IntEnb = 0; /* Turn off interrupts */
- New_Compiler_MemTop();
+ /* Disable all interrupts */
+ SET_INTERRUPT_MASK(0);
+ return;
}
\f
-/* Make a Scheme string with the characters in C_String. */
+extern Pointer *copy_c_string_to_scheme_string();
-Pointer
-C_String_To_Scheme_String (C_String)
- fast char *C_String;
+/* Is supposed to have a null character. */
+static char null_string[] = "";
+
+Pointer *
+copy_c_string_to_scheme_string(source, start, end)
+ fast char *source;
+ Pointer *start, *end;
{
- fast char *Next;
- fast long Length, Max_Length;
- Pointer Result;
+ Pointer *saved;
+ long char_count, word_count;
+ fast char *dest, *limit;
- Result = Make_Pointer( TC_CHARACTER_STRING, Free);
- Next = (char *) Nth_Vector_Loc( Result, STRING_CHARS);
- Max_Length = ((Space_Before_GC() - STRING_CHARS) *
- sizeof( Pointer));
- if (C_String == NULL)
+ saved = start;
+ start += STRING_CHARS;
+ dest = ((char *) start);
+
+ if (source == ((char *) NULL))
{
- Length = 0;
- if (Max_Length < 0)
- {
- Primitive_GC(3);
- }
+ source = ((char *) &null_string[0]);
}
- else
+ limit = ((char *) end);
+ if (dest < limit)
{
- for (Length = 0;
- (*C_String != '\0') && (Length < Max_Length);
- Length += 1)
+ do
{
- *Next++ = *C_String++;
- }
- if (Length >= Max_Length)
+ *dest++ = *source;
+ } while ((dest < limit) && (*source++ != '\0'));
+ }
+ if (dest >= limit)
+ {
+ while (*source++ != '\0')
{
- while (*C_String++ != '\0')
- {
- Length += 1;
- }
- Primitive_GC(2 +
- (((Length + 1) + (sizeof( Pointer) - 1))
- / sizeof( Pointer)));
+ dest += 1;
}
}
- *Next = '\0';
- Free += (2 + ((Length + sizeof( Pointer)) / sizeof( Pointer)));
- Vector_Set(Result, STRING_LENGTH, Length);
- Vector_Set(Result, STRING_HEADER,
- Make_Non_Pointer( TC_MANIFEST_NM_VECTOR,
- ((Free - Get_Pointer( Result)) - 1)));
- return Result;
+ char_count = (dest - ((char *) start));
+ word_count = ((char_count + (sizeof(Pointer) - 1)) / sizeof(Pointer));
+ start += word_count;
+ if (start < end)
+ {
+ saved[STRING_HEADER] = Make_Non_Pointer( TC_MANIFEST_NM_VECTOR,
+ (word_count + 1));
+ saved[STRING_LENGTH] = ((Pointer) (char_count - 1));
+ }
+ return (start);
+}
+\f
+/* Make a Scheme string with the characters in C_String. */
+
+Pointer
+C_String_To_Scheme_String (c_string)
+ char *c_string;
+{
+ Pointer *end, *result, value;
+
+ end = &Free[Space_Before_GC()];
+ result = copy_c_string_to_scheme_string(c_string, Free, end);
+ if (result >= end)
+ {
+ Primitive_GC(result - Free);
+ }
+ value = Make_Pointer( TC_CHARACTER_STRING, Free);
+ Free = result;
+ return (value);
}
\f
Boolean
char *Mode_String;
FILE **Handle;
{
+ extern FILE *OS_file_open();
+
*Handle =
- ((FILE *)
- OS_file_open( Scheme_String_To_C_String( Name), (*Mode_String == 'w')));
+ OS_file_open( Scheme_String_To_C_String( Name), (*Mode_String == 'w'));
return ((Boolean) (*Handle != NULL));
}
extern Boolean OS_file_close();
if (!OS_file_close( stream))
+ {
Primitive_Error( ERR_EXTERNAL_RETURN);
+ }
return;
}
+CRLF ()
+{
+ printf( "\n");
+}
+\f
+/* HISTORY manipulation */
+
Pointer *
Make_Dummy_History ()
{
Free[HIST_PREV_SUBPROBLEM] =
Make_Pointer(UNMARKED_HISTORY_TYPE, Result);
Free += 3;
- return Result;
+ return (Result);
}
-\f
+
/* The entire trick to history is right here: it is either copied or
reused when restored. Initially, Stop_History marks the stack so
that the history will merely be popped and reused. On a catch,
void
Stop_History ()
{
- Pointer Saved_Expression = Fetch_Expression();
- long Saved_Return_Code = Fetch_Return();
+ Pointer Saved_Expression;
+ long Saved_Return_Code;
-Will_Push(HISTORY_SIZE);
+ Saved_Expression = Fetch_Expression();
+ Saved_Return_Code = Fetch_Return();
+ Will_Push(HISTORY_SIZE);
Save_History(RC_RESTORE_DONT_COPY_HISTORY);
-Pushed();
+ Pushed();
Prev_Restore_History_Stacklet = NULL;
Prev_Restore_History_Offset = ((Get_End_Of_Stacklet() - Stack_Pointer) +
CONTINUATION_RETURN_CODE);
Store_Return(Saved_Return_Code);
return;
}
-
+\f
Pointer *
Copy_Rib (Orig_Rib)
Pointer *Orig_Rib;
{
Pointer *Result, *This_Rib;
- for (This_Rib=NULL, Result=Free;
+ for (This_Rib = NULL, Result = Free;
(This_Rib != Orig_Rib) && (!GC_Check(0));
This_Rib = Get_Pointer(This_Rib[RIB_NEXT_REDUCTION]))
{
}
Free += 3;
}
- Store_Address((Free-3)[RIB_NEXT_REDUCTION], C_To_Scheme(Result));
- return Result;
+ Store_Address((Free - 3)[RIB_NEXT_REDUCTION], C_To_Scheme(Result));
+ return (Result);
}
-\f
+
/* Restore_History pops a history object off the stack and
makes a COPY of it the current history collection object.
This is called only from the RC_RESTORE_HISTORY case in
{
fprintf(stderr, "Bad history to restore.\n");
Microcode_Termination(TERM_EXIT);
+ /*NOTREACHED*/
}
}
Orig_Vertebra = Get_Pointer(Hist_Obj);
+\f
for (Next_Vertebra = NULL, Prev_Vertebra = NULL;
Next_Vertebra != Orig_Vertebra;
Next_Vertebra =
Get_Pointer(Next_Vertebra[HIST_NEXT_SUBPROBLEM]))
- { Pointer *New_Rib;
+ {
+ Pointer *New_Rib;
if (Prev_Vertebra == NULL)
{
Free += 3;
if (GC_Check(0))
{
- return false;
+ return (false);
}
}
Store_Address(New_History[HIST_PREV_SUBPROBLEM], C_To_Scheme(Free-3));
HISTORY_MARK(Prev_Vertebra[HIST_MARK]);
}
History = New_History;
- return true;
-}
-
-CRLF ()
-{
- printf( "\n");
+ return (true);
}
\f
/* If a debugging version of the interpreter is made, then this
*/
#ifdef ENABLE_DEBUGGING_TOOLS
+
Pointer
Apply_Primitive (Primitive_Number)
long Primitive_Number;
{
Print_Primitive(Primitive_Number);
}
- NArgs = N_Args_Primitive(Primitive_Number);
+ NArgs = PRIMITIVE_N_ARGUMENTS(Primitive_Number);
Saved_Stack = Stack_Pointer;
Result = Internal_Apply_Primitive(Primitive_Number);
if (Saved_Stack != Stack_Pointer)
"\nStack was 0x%x, now 0x%x, #args=%d.\n",
Saved_Stack, Stack_Pointer, NArgs);
Microcode_Termination(TERM_EXIT);
+ /*NOTREACHED*/
}
if (Primitive_Debug)
{
Print_Expression(Result, "Primitive Result");
fprintf(stderr, "\n");
}
- return Result;
+ return (Result);
}
-#endif
+
+#endif /* ENABLE_DEBUGGING_TOOLS */
\f
#ifdef ENABLE_PRIMITIVE_PROFILING
-/* The profiling mechanism is enabled by storing a cons of two vectors
- in the fixed objects vector. The car will record the profiling for
- built-in primitives, and the cdr for user defined primitives. Both
- vectors should be initialized to contain all zeros. */
+/* The profiling mechanism is enabled by storing a vector in the fixed
+ objects vector. The vector should be initialized to contain all zeros
+ */
void
record_primitive_entry (primitive)
Pointer primitive;
{
+ Pointer table;
+
if ((Fixed_Objects != NIL) &&
- ((Get_Fixed_Obj_Slot (Primitive_Profiling_Table)) != NIL))
- {
- Pointer table;
- long index, old_value;
-
- /* Test for TC_PRIMITIVE_EXTERNAL rather than TC_PRIMITIVE here
- because the compiled code interface will use 0 rather than
- TC_PRIMITIVE. */
- table =
- (Vector_Ref
- ((Get_Fixed_Obj_Slot (Primitive_Profiling_Table)),
- (((pointer_type (primitive)) == TC_PRIMITIVE_EXTERNAL) ? 1 : 0)));
- index = (1 + (pointer_datum (primitive)));
- Scheme_Integer_To_C_Integer ((Vector_Ref (table, index)), &old_value);
- Vector_Set (table, index, (C_Integer_To_Scheme_Integer (1 + old_value)));
- }
+ ((table = Get_Fixed_Obj_Slot (Primitive_Profiling_Table)) != NIL))
+ {
+ long index, old_value;
+
+ index = (1 + (pointer_datum (primitive)));
+ Scheme_Integer_To_C_Integer ((Vector_Ref (table, index)), &old_value);
+ Vector_Set (table, index, (C_Integer_To_Scheme_Integer (1 + old_value)));
+ }
+ return;
}
-#endif
+#endif /* ENABLE_PRIMITIVE_PROFILING */
\f
Pointer
Allocate_Float (F)
*Free = Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, FLONUM_SIZE);
Get_Float(C_To_Scheme(Free)) = F;
Primitive_GC_If_Needed(FLONUM_SIZE+1);
- Free += FLONUM_SIZE+1;
- return Result;
+ Free += (FLONUM_SIZE + 1);
+ return (Result);
}
\f
#ifdef USE_STACKLETS
{
#ifdef ENABLE_DEBUGGING_TOOLS
if (Point == NIL)
- { printf("\nState_Point 0x%x wrong: count was %d, NIL at %d\n",
+ {
+ fprintf(stderr,
+ "\nState_Point 0x%x wrong: count was %d, NIL at %d\n",
State_Point, How_Far, i);
Microcode_Termination(TERM_EXIT);
+ /*NOTREACHED*/
}
-#endif
+#endif /* ENABLE_DEBUGGING_TOOLS */
Point = Fast_Vector_Ref(Point, STATE_POINT_NEARER_POINT);
}
- return Point;
+ return (Point);
}
/* ASSUMPTION: State points, which are created only by the interpreter,
Translate_To_Point (Target)
Pointer Target;
{
- Pointer State_Space = Find_State_Space(Target);
- Pointer Current_Location, *Path = Free;
+ Pointer State_Space, Current_Location, *Path;
fast Pointer Path_Point, *Path_Ptr;
long Distance, Merge_Depth, From_Depth, i;
+ State_Space = Find_State_Space(Target);
+ Path = Free;
guarantee_state_point();
Distance =
Get_Integer(Fast_Vector_Ref(Target, STATE_POINT_DISTANCE_TO_ROOT));
{
Current_Location = Vector_Ref(State_Space, STATE_SPACE_NEAREST_POINT);
}
+
if (Target == Current_Location)
{
PRIMITIVE_ABORT(PRIM_POP_RETURN);
/*NOTREACHED*/
}
- for (Path_Ptr=(&(Path[Distance])), Path_Point=Target, i=0;
+
+ for (Path_Ptr = (&(Path[Distance])), Path_Point = Target, i = 0;
i <= Distance;
- i++, Path_Point=Fast_Vector_Ref(Path_Point, STATE_POINT_NEARER_POINT))
+ i++)
{
*Path_Ptr-- = Path_Point;
+ Path_Point = Fast_Vector_Ref(Path_Point, STATE_POINT_NEARER_POINT);
}
+
From_Depth =
Get_Integer(Fast_Vector_Ref(Current_Location, STATE_POINT_DISTANCE_TO_ROOT));
- for (Path_Point=Current_Location, Merge_Depth = From_Depth;
+\f
+ for (Path_Point = Current_Location, Merge_Depth = From_Depth;
Merge_Depth > Distance;
Merge_Depth--)
{
Path_Point = Fast_Vector_Ref(Path_Point, STATE_POINT_NEARER_POINT);
}
- for (Path_Ptr=(&(Path[Merge_Depth])); Merge_Depth >= 0;
- Merge_Depth--, Path_Ptr--,
- Path_Point=Fast_Vector_Ref(Path_Point, STATE_POINT_NEARER_POINT))
+
+ for (Path_Ptr = (&(Path[Merge_Depth]));
+ Merge_Depth >= 0;
+ Merge_Depth--, Path_Ptr--)
{
if (*Path_Ptr == Path_Point)
{
break;
}
+ Path_Point = Fast_Vector_Ref(Path_Point, STATE_POINT_NEARER_POINT);
}
+
#ifdef ENABLE_DEBUGGING_TOOLS
if (Merge_Depth < 0)
{
fprintf(stderr, "\nMerge_Depth went negative: %d\n", Merge_Depth);
Microcode_Termination(TERM_EXIT);
}
-#endif
+#endif /* ENABLE_DEBUGGING_TOOLS */
+
Will_Push(2*CONTINUATION_SIZE + 4);
Store_Return(RC_RESTORE_INT_MASK);
- Store_Expression(Make_Unsigned_Fixnum(IntEnb));
+ Store_Expression(MAKE_SIGNED_FIXNUM(FETCH_INTERRUPT_MASK()));
Save_Cont();
- Push(Make_Unsigned_Fixnum((Distance-Merge_Depth)));
+ Push(Make_Unsigned_Fixnum((Distance - Merge_Depth)));
Push(Target);
- Push(Make_Unsigned_Fixnum((From_Depth-Merge_Depth)));
+ Push(Make_Unsigned_Fixnum((From_Depth - Merge_Depth)));
Push(Current_Location);
Store_Expression(State_Space);
Store_Return(RC_MOVE_TO_ADJACENT_POINT);
Save_Cont();
Pushed();
- IntEnb &= (INT_GC<<1) - 1; /* Disable lower than GC level */
+
+ {
+ long mask;
+
+ /* Disable lower than GC level */
+ mask = (FETCH_INTERRUPT_MASK() & ((INT_GC << 1) - 1));
+ SET_INTERRUPT_MASK(mask);
+ }
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/vector.c,v 9.26 1987/07/23 21:53:19 cph Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/vector.c,v 9.27 1987/11/17 08:21:09 jinx Exp $
*
* This file contains procedures for handling vectors and conversion
* back and forth to lists.
*/
Built_In_Primitive(Prim_List_To_Vector, 1, "LIST->VECTOR", 0x7C)
+Define_Primitive(Prim_List_To_Vector, 1, "LIST->VECTOR")
{
Primitive_1_Arg();
all the items in V.
*/
Built_In_Primitive(Prim_Subvector_To_List, 3, "SUBVECTOR->LIST", 0x7D)
+Define_Primitive(Prim_Subvector_To_List, 3, "SUBVECTOR->LIST")
{
Primitive_3_Args();
initialized to CONTENTS. */
Built_In_Primitive (Prim_Vector_Cons, 2, "VECTOR-CONS", 0x2C)
+Define_Primitive (Prim_Vector_Cons, 2, "VECTOR-CONS")
{
Primitive_2_Args ();
Return the OFFSETth entry in VECTOR. Entries are numbered from 0.
*/
Built_In_Primitive(Prim_Vector_Ref, 2, "VECTOR-REF", 0x2E)
+Define_Primitive(Prim_Vector_Ref, 2, "VECTOR-REF")
{
long Offset;
Primitive_2_Args();
previous value of the entry.
*/
Built_In_Primitive(Prim_Vector_Set, 3, "VECTOR-SET!", 0x30)
+Define_Primitive(Prim_Vector_Set, 3, "VECTOR-SET!")
{
long Offset;
Primitive_3_Args();
Returns the number of entries in VECTOR.
*/
Built_In_Primitive(Prim_Vector_Size, 1, "VECTOR-LENGTH", 0x2D)
+Define_Primitive(Prim_Vector_Size, 1, "VECTOR-LENGTH")
{
Primitive_1_Arg();
an environment from a list of values.
*/
Built_In_Primitive(Prim_Sys_List_To_Vector, 2, "SYSTEM-LIST-TO-VECTOR", 0x97)
+Define_Primitive(Prim_Sys_List_To_Vector, 2, "SYSTEM-LIST-TO-VECTOR")
{
long Type;
Primitive_2_Args();
*/
Built_In_Primitive(Prim_Sys_Subvector_To_List, 3,
"SYSTEM-SUBVECTOR-TO-LIST", 0x98)
+Define_Primitive(Prim_Sys_Subvector_To_List, 3,
+ "SYSTEM-SUBVECTOR-TO-LIST")
{
Primitive_3_Args();
Touch_In_Primitive(Arg1, Arg1);
returns NIL.
*/
Built_In_Primitive(Prim_Sys_Vector, 1, "SYSTEM-VECTOR?", 0x99)
+Define_Primitive(Prim_Sys_Vector, 1, "SYSTEM-VECTOR?")
{
Primitive_1_Arg();
Like VECTOR_REF, but for anything of GC type VECTOR.
*/
Built_In_Primitive(Prim_Sys_Vector_Ref, 2, "SYSTEM-VECTOR-REF", 0x9A)
+Define_Primitive(Prim_Sys_Vector_Ref, 2, "SYSTEM-VECTOR-REF")
{
long Offset;
Primitive_2_Args();
Like VECTOR_SET, but for anything of GC type VECTOR.
*/
Built_In_Primitive(Prim_Sys_Vec_Set, 3, "SYSTEM-VECTOR-SET!", 0x9B)
+Define_Primitive(Prim_Sys_Vec_Set, 3, "SYSTEM-VECTOR-SET!")
{
long Offset;
Primitive_3_Args();
Like VECTOR_SIZE, but for anything of GC type VECTOR.
*/
Built_In_Primitive(Prim_Sys_Vec_Size, 1, "SYSTEM-VECTOR-SIZE", 0xAE)
+Define_Primitive(Prim_Sys_Vec_Size, 1, "SYSTEM-VECTOR-SIZE")
{
Primitive_1_Arg();
Built_In_Primitive (Prim_subvector_move_right, 5, "SUBVECTOR-MOVE-RIGHT!",
0x9D)
+Define_Primitive (Prim_subvector_move_right, 5, "SUBVECTOR-MOVE-RIGHT!")
{
subvector_move_prefix ();
}
Built_In_Primitive (Prim_subvector_move_left, 5, "SUBVECTOR-MOVE-LEFT!", 0x9E)
+Define_Primitive (Prim_subvector_move_left, 5, "SUBVECTOR-MOVE-LEFT!")
{
subvector_move_prefix ();
}
\f
Built_In_Primitive (Prim_vector_fill, 4, "SUBVECTOR-FILL!", 0x9F)
+Define_Primitive (Prim_vector_fill, 4, "SUBVECTOR-FILL!")
{
Pointer *scan;
long start, end, length;
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.2 1987/11/04 20:05:38 cph Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/version.h,v 10.3 1987/11/17 08:21:22 jinx Exp $
This file contains version information for the microcode. */
\f
/* Scheme system release version */
#ifndef RELEASE
-#define RELEASE "6.0.0"
+#define RELEASE "6.2.0"
#endif
/* Microcode release version */
#define VERSION 10
#endif
#ifndef SUBVERSION
-#define SUBVERSION 2
+#define SUBVERSION 5
#endif
#ifndef UCODE_TABLES_FILENAME
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/xdebug.c,v 9.22 1987/10/09 16:15:41 jinx Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/xdebug.c,v 9.23 1987/11/17 08:21:49 jinx Rel $
*
* This file contains primitives to debug the memory management in the
* Scheme system.
Primitive_0_Args();
printf("\n*** Back Trace: ***\n");
- Back_Trace();
+ Back_Trace(stdout);
return TRUTH;
}
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/bintopsb.c,v 9.28 1987/09/21 21:54:48 jinx Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/bintopsb.c,v 9.29 1987/11/17 08:02:39 jinx Exp $
*
* This File contains the code to translate internal format binary
* files to portable format.
*
*/
\f
-/* Cheap renames */
+/* IO definitions */
#define Internal_File Input_File
#define Portable_File Output_File
#include "translate.h"
#include "trap.h"
-static Boolean Shuffle_Bytes = false;
-static Boolean upgrade_traps = false;
-
-static Pointer *Mem_Base;
-static long Heap_Relocation, Constant_Relocation;
-static long Free, Scan, Free_Constant, Scan_Constant;
-static long Objects, Constant_Objects;
-static Pointer *Free_Objects, *Free_Cobjects;
-
-static long NFlonums;
-static long NIntegers, NBits;
-static long NBitstrs, NBBits;
-static long NStrings, NChars;
-
long
Load_Data(Count, To_Where)
long Count;
#define Reloc_or_Load_Debug false
+#include "fasl.h"
+#define INHIBIT_FASL_VERSION_CHECK
#include "load.c"
+#include "bltdef.h"
\f
-/* Utility macros and procedures
- Pointer Objects handled specially in the portable format.
-*/
+/* Character macros and procedures */
+
+extern int strlen();
#ifndef isalpha
#include <ctype.h>
-#endif
+#endif /* isalpha */
#ifndef ispunct
s = &punctuation[0];
while (*s != '\0')
+ {
if (*s++ == c)
- return true;
- return false;
+ {
+ return (true);
+ }
+ }
+ return (false);
}
-#endif
+#endif /* ispunct */
+\f
+/* Global data */
+
+static Boolean Shuffle_Bytes = false;
+static Boolean upgrade_traps = false;
+static Boolean upgrade_primitives = false;
+
+/* Needed to upgrade */
+#define TC_PRIMITIVE_EXTERNAL 0x10
+
+static Boolean upgrade_lengths = false;
+
+#define STRING_LENGTH_TO_LONG(value) \
+((long) (upgrade_lengths ? Get_Integer(value) : (value)))
+
+static Pointer *Mem_Base;
+static long Heap_Relocation, Constant_Relocation;
+static long Free, Scan, Free_Constant, Scan_Constant;
+static long Objects, Constant_Objects;
+static Pointer *Free_Objects, *Free_Cobjects;
+static Pointer *primitive_table;
+
+static long NFlonums;
+static long NIntegers, NBits;
+static long NBitstrs, NBBits;
+static long NStrings, NChars;
+static long NPChars;
+\f
#define OUT(s) \
fprintf(Portable_File, s); \
break
case ' ' : OUT(" ");
default:
if ((isalpha(c)) || (isdigit(c)) || (ispunct(c)))
+ {
putc(c, Portable_File);
+ }
else
{
fprintf(stderr,
fprintf(Portable_File, "\X%x ", ((int) c));
}
}
+ return;
}
\f
#define Do_Compound(Code, Rel, Fre, Scn, Obj, FObj, kernel_code) \
Old_Contents = *Old_Address; \
\
if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
- Mem_Base[(Scn)] = \
- Make_New_Pointer((Code), Old_Contents); \
+ { \
+ Mem_Base[(Scn)] = Make_New_Pointer((Code), Old_Contents); \
+ } \
else \
{ \
kernel_code; \
*(FObj)++ = Make_Non_Pointer((type), 0); \
*(FObj)++ = Old_Contents; \
while(--length >= 0) \
+ { \
*(FObj)++ = *Old_Address++; \
+ } \
}
\f
#define do_string_kernel() \
temp = ((val < 0) ? -val : val);
for (size_in_bits = 0; temp != 0; size_in_bits += 1)
+ {
temp = temp >> 1;
+ }
fprintf(Portable_File, "%02x %c ",
TC_FIXNUM,
(val < 0 ? '-' : '+'));
if (val == 0)
+ {
fprintf(Portable_File, "0\n");
+ }
else
{
fprintf(Portable_File, "%ld ", size_in_bits);
}
\f
void
-print_a_string(from)
- Pointer *from;
+print_a_string_internal(len, string)
+ fast long len;
+ fast char *string;
{
- fast long len;
- fast char *string;
- long maxlen;
-
- maxlen = pointer_to_char((Get_Integer(*from++))-1);
- len = Get_Integer(*from++);
- fprintf(Portable_File, "%02x %ld %ld ",
- TC_CHARACTER_STRING,
- (Compact_P ? len : maxlen),
- len);
- string = ((char *) from);
+ fprintf(Portable_File, "%ld ", len);
if (Shuffle_Bytes)
{
while(len > 0)
{
print_a_char(string[3], "print_a_string");
if (len > 1)
+ {
print_a_char(string[2], "print_a_string");
+ }
if (len > 2)
+ {
print_a_char(string[1], "print_a_string");
+ }
if (len > 3)
+ {
print_a_char(string[0], "print_a_string");
+ }
len -= 4;
string += 4;
}
}
else
+ {
while(--len >= 0)
+ {
print_a_char(*string++, "print_a_string");
+ }
+ }
putc('\n', Portable_File);
return;
}
\f
void
+print_a_string(from)
+ Pointer *from;
+{
+ long len;
+ long maxlen;
+
+ maxlen = pointer_to_char((Get_Integer(*from++)) - 1);
+ len = STRING_LENGTH_TO_LONG(*from++);
+
+ fprintf(Portable_File,
+ "%02x %ld ",
+ TC_CHARACTER_STRING,
+ (Compact_P ? len : maxlen));
+
+ print_a_string_internal(len, ((char *) from));
+ return;
+}
+
+void
+print_a_primitive(arity, length, name)
+ long arity, length;
+ char *name;
+{
+ fprintf(Portable_File, "%ld ", arity);
+ print_a_string_internal(length, name);
+ return;
+}
+\f
+void
print_a_bignum(from)
Pointer *from;
{
the_number = BIGNUM(from);
temp = LEN(the_number);
if (temp == 0)
+ {
fprintf(Portable_File, "%02x + 0\n",
(Compact_P ? TC_FIXNUM : TC_BIG_FIXNUM));
+ }
else
{
fast long tail;
temp = ((long) (*Bignum_Top(the_number)));
temp != 0;
size_in_bits += 1)
+ {
temp = temp >> 1;
-
+ }
+\f
fprintf(Portable_File, "%02x %c %ld ",
(Compact_P ? TC_FIXNUM : TC_BIG_FIXNUM),
(NEG_BIGNUM(the_number) ? '-' : '+'),
size_in_bits);
tail = size_in_bits % SHIFT;
if (tail == 0)
+ {
tail = SHIFT;
+ }
temp = 0;
size_in_bits = 0;
the_top = Bignum_Top(the_number);
}
}
if (size_in_bits > 0)
+ {
fprintf(Portable_File, "%01lx\n", (temp & 0xf));
+ }
else
+ {
fprintf(Portable_File, "\n");
+ }
}
return;
}
\f
/* The following procedure assumes that a C long is at least 4 bits. */
+void
print_a_bit_string(from)
Pointer *from;
{
}
}
if (leftover_bits != 0)
+ {
fprintf(Portable_File, "%01lx", (accumulator & 0xf));
+ }
}
fprintf(Portable_File, "\n");
return;
}
\f
+void
print_a_flonum(val)
double val;
{
}
fprintf(Portable_File, "%01x", digit);
}
- fprintf(Portable_File, "\n");
+ putc('\n', Portable_File);
return;
}
\f
Old_Contents = *Old_Address; \
\
if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
- Mem_Base[(Scn)] = \
- Make_New_Pointer(Type_Code(This), Old_Contents); \
+ { \
+ Mem_Base[(Scn)] = Make_New_Pointer(Type_Code(This), Old_Contents); \
+ } \
else \
{ \
*Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
Old_Contents = *Old_Address; \
\
if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
- Mem_Base[(Scn)] = \
- Make_New_Pointer(Type_Code(This), Old_Contents); \
+ { \
+ Mem_Base[(Scn)] = Make_New_Pointer(Type_Code(This), Old_Contents); \
+ } \
else \
{ \
*Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
Mem_Base[(Fre)++] = *Old_Address++; \
} \
}
-
+\f
#define Do_Triple(Code, Rel, Fre, Scn, Obj, FObj) \
{ \
Old_Address += (Rel); \
Old_Contents = *Old_Address; \
\
if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
- Mem_Base[(Scn)] = \
- Make_New_Pointer(Type_Code(This), Old_Contents); \
+ { \
+ Mem_Base[(Scn)] = Make_New_Pointer(Type_Code(This), Old_Contents); \
+ } \
else \
{ \
*Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
} \
}
+#define Do_Quad(Code, Rel, Fre, Scn, Obj, FObj) \
+{ \
+ Old_Address += (Rel); \
+ Old_Contents = *Old_Address; \
+ \
+ if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
+ { \
+ Mem_Base[(Scn)] = Make_New_Pointer(Type_Code(This), Old_Contents); \
+ } \
+ else \
+ { \
+ *Old_Address++ = Make_Non_Pointer(TC_BROKEN_HEART, (Fre)); \
+ Mem_Base[(Scn)] = Make_Non_Pointer(Type_Code(This), (Fre)); \
+ Mem_Base[(Fre)++] = Old_Contents; \
+ Mem_Base[(Fre)++] = *Old_Address++; \
+ Mem_Base[(Fre)++] = *Old_Address++; \
+ Mem_Base[(Fre)++] = *Old_Address++; \
+ } \
+}
+\f
#define Do_Vector(Code, Rel, Fre, Scn, Obj, FObj) \
{ \
Old_Address += (Rel); \
Old_Contents = *Old_Address; \
\
if (Type_Code(Old_Contents) == TC_BROKEN_HEART) \
- Mem_Base[(Scn)] = \
- Make_New_Pointer(Type_Code(This), Old_Contents); \
+ { \
+ Mem_Base[(Scn)] = Make_New_Pointer(Type_Code(This), Old_Contents); \
+ } \
else \
{ \
fast long len; \
fprintf(stderr, \
"%s: File is not portable: Pointer to stack.\n", \
Program_Name); \
- exit(1); \
+ quit(1); \
} \
(Scn) += 1; \
break; \
}
\f
+/* Primitive upgrading code. */
+
+#define PRIMITIVE_UPGRADE_SPACE 2048
+static Pointer *internal_renumber_table;
+static Pointer *external_renumber_table;
+static Pointer *external_prim_name_table;
+static Boolean found_ext_prims = false;
+
+Pointer *
+relocate(object)
+ Pointer object;
+{
+ Pointer *result;
+ result = (Get_Pointer(object) + ((Datum(object) < Const_Base) ?
+ Heap_Relocation :
+ Constant_Relocation));
+ return (result);
+}
+
+Pointer
+upgrade_primitive(prim)
+ Pointer prim;
+{
+ long datum, type, new_type, code;
+ Pointer new;
+
+ datum = OBJECT_DATUM(prim);
+ type = OBJECT_TYPE(prim);
+ if (type != TC_PRIMITIVE_EXTERNAL)
+ {
+ code = datum;
+ new_type = type;
+ }
+ else
+ {
+ found_ext_prims = true;
+ code = (datum + (MAX_BUILTIN_PRIMITIVE + 1));
+ new_type = TC_PRIMITIVE;
+ }
+\f
+ new = internal_renumber_table[code];
+ if (new == NIL)
+ {
+ /*
+ This does not need to check for overflow because the worst case
+ was checked in setup_primitive_upgrade;
+ */
+
+ new = Make_Non_Pointer(new_type, Primitive_Table_Length);
+ internal_renumber_table[code] = new;
+ external_renumber_table[Primitive_Table_Length] = prim;
+ Primitive_Table_Length += 1;
+ if (type == TC_PRIMITIVE_EXTERNAL)
+ {
+ NPChars +=
+ STRING_LENGTH_TO_LONG((((Pointer *) (external_prim_name_table[datum]))
+ [STRING_LENGTH]));
+ }
+ else
+ {
+ NPChars += strlen(builtin_prim_name_table[datum]);
+ }
+ return (new);
+ }
+ else
+ {
+ return (Make_New_Pointer(new_type, new));
+ }
+}
+\f
+Pointer *
+setup_primitive_upgrade(Heap)
+ Pointer *Heap;
+{
+ fast long count, length;
+ Pointer *old_prims_vector;
+
+ internal_renumber_table = &Heap[0];
+ external_renumber_table =
+ &internal_renumber_table[PRIMITIVE_UPGRADE_SPACE];
+ external_prim_name_table =
+ &external_renumber_table[PRIMITIVE_UPGRADE_SPACE];
+
+ old_prims_vector = relocate(Ext_Prim_Vector);
+ if (*old_prims_vector == NIL)
+ {
+ length = 0;
+ }
+ else
+ {
+ old_prims_vector = relocate(*old_prims_vector);
+ length = Get_Integer(*old_prims_vector);
+ old_prims_vector += VECTOR_DATA;
+ for (count = 0; count < length; count += 1)
+ {
+ Pointer *temp;
+
+ /* symbol */
+ temp = relocate(old_prims_vector[count]);
+ /* string */
+ temp = relocate(temp[SYMBOL_NAME]);
+ external_prim_name_table[count] = ((Pointer) temp);
+ }
+ }
+ length += (MAX_BUILTIN_PRIMITIVE + 1);
+ if (length > PRIMITIVE_UPGRADE_SPACE)
+ {
+ fprintf(stderr, "%s: Too many primitives.\n", Program_Name);
+ fprintf(stderr,
+ "Increase PRIMITIVE_UPGRADE_SPACE and recompile %s.\n",
+ Program_Name);
+ quit(1);
+ }
+ for (count = 0; count < length; count += 1)
+ {
+ internal_renumber_table[count] = NIL;
+ }
+ NPChars = 0;
+ return (&external_prim_name_table[PRIMITIVE_UPGRADE_SPACE]);
+}
+\f
/* Processing of a single area */
#define Do_Area(Code, Area, Bound, Obj, FObj) \
while(*Area != *Bound)
{
This = Mem_Base[*Area];
+
+#ifdef PRIMITIVE_EXTERNAL_REUSED
+ if (upgrade_primitives && (Type_Code(This) == TC_PRIMITIVE_EXTERNAL))
+ {
+ Mem_Base[*Area] = upgrade_primitive(This);
+ *Area += 1;
+ continue;
+ }
+#endif /* PRIMITIVE_EXTERNAL_REUSED */
+
Switch_by_GC_Type(This)
{
+#ifndef PRIMITIVE_EXTERNAL_REUSED
+
+ case TC_PRIMITIVE_EXTERNAL:
+
+#endif /* PRIMITIVE_EXTERNAL_REUSED */
+
+ case TC_PRIMITIVE:
+ case TC_PCOMB0:
+ if (upgrade_primitives)
+ {
+ Mem_Base[*Area] = upgrade_primitive(This);
+ }
+ *Area += 1;
+ break;
+\f
case TC_MANIFEST_NM_VECTOR:
if (Null_NMV)
{
i = Get_Integer(This);
*Area += 1;
for ( ; --i >= 0; *Area += 1)
+ {
Mem_Base[*Area] = NIL;
+ }
break;
}
- /* else, Unknown object! */
fprintf(stderr, "%s: File is not portable: NMH found\n",
Program_Name);
*Area += 1 + Get_Integer(This);
{
fprintf(stderr, "%s: Broken Heart found in scan.\n",
Program_Name);
- exit(1);
+ quit(1);
}
*Area += 1;
break;
fprintf(stderr,
"%s: File is not portable: Compiled code.\n",
Program_Name);
- exit(1);
-\f
+ quit(1);
+
case TC_FIXNUM:
NIntegers += 1;
NBits += fixnum_to_bits;
/* Fall through */
case TC_MANIFEST_SPECIAL_NM_VECTOR:
- case TC_PRIMITIVE_EXTERNAL:
case_simple_Non_Pointer:
*Area += 1;
break;
-
+\f
case_Cell:
Do_Pointer(*Area, Do_Cell);
fprintf(stderr,
"%s: Bad old unassigned object. 0x%x.\n",
Program_Name, This);
- exit(1);
+ quit(1);
}
if (kind <= TRAP_MAX_IMMEDIATE)
{
fprintf(stderr,
"%s: Cannot upgrade environments.\n",
Program_Name);
- exit(1);
+ quit(1);
}
/* Fall through */
Bad_Type:
fprintf(stderr, "%s: Unknown Type Code 0x%x found.\n",
Program_Name, Type_Code(This));
- exit(1);
+ quit(1);
}
}
}
\
case TC_BIT_STRING: \
print_a_bit_string(++from); \
- from += 1 + Get_Integer(*from); \
+ from += (1 + Get_Integer(*from)); \
break; \
\
case TC_BIG_FIXNUM: \
print_a_bignum(++from); \
- from += 1 + Get_Integer(*from); \
+ from += (1 + Get_Integer(*from)); \
break; \
\
case TC_CHARACTER_STRING: \
print_a_string(++from); \
- from += 1 + Get_Integer(*from); \
+ from += (1 + Get_Integer(*from)); \
break; \
\
case TC_BIG_FLONUM: \
print_a_flonum( *((double *) (from + 1))); \
- from += 1 + float_to_pointer; \
+ from += (1 + float_to_pointer); \
break; \
\
case TC_CHARACTER: \
fprintf(stderr, \
"%s: Bad Object to print externally %lx\n", \
Program_Name, *from); \
- exit(1); \
+ quit(1); \
} \
}
-\f
-#define print_an_object(obj) \
-fprintf(Portable_File, "%02x %lx\n", \
- Type_Code(obj), Get_Integer(obj))
+#define print_an_object(obj) \
+{ \
+ fprintf(Portable_File, "%02x %lx\n", \
+ Type_Code(obj), Get_Integer(obj)); \
+}
+\f
/* Debugging Aids and Consistency Checks */
#ifdef DEBUG
-When(what, message)
+#define DEBUGGING(action) action
+
+#define WHEN(condition, message) when(condition, message)
+
+void
+when(what, message)
Boolean what;
char *message;
{
{
fprintf(stderr, "%s: Inconsistency: %s!\n",
Program_Name, (message));
- exit(1);
+ quit(1);
}
return;
}
-#define print_header(name, obj, format) \
+#define PRINT_HEADER(name, obj, format) \
{ \
fprintf(Portable_File, (format), (obj)); \
fprintf(stderr, "%s: ", (name)); \
fprintf(stderr, (format), (obj)); \
}
-#else
+#else /* not DEBUG */
+
+#define DEBUGGING(action)
-#define When(what, message)
+#define WHEN(what, message)
-#define print_header(name, obj, format) \
+#define PRINT_HEADER(name, obj, format) \
{ \
fprintf(Portable_File, (format), (obj)); \
}
-#endif
+#endif /* DEBUG */
\f
/* The main program */
+void
do_it()
{
Pointer *Heap;
fprintf(stderr,
"%s: Input file does not appear to be in FASL format.\n",
Program_Name);
- exit(1);
+ quit(1);
}
- if ((Version != FASL_FORMAT_VERSION) ||
- (Sub_Version > FASL_SUBVERSION) ||
- (Sub_Version < FASL_OLDEST_SUPPORTED) ||
- ((Machine_Type != FASL_INTERNAL_FORMAT) && (!Shuffle_Bytes)))
+ if ((Version > FASL_READ_VERSION) ||
+ (Version < FASL_OLDEST_VERSION) ||
+ (Sub_Version > FASL_READ_SUBVERSION) ||
+ (Sub_Version < FASL_OLDEST_SUBVERSION) ||
+ ((Machine_Type != FASL_INTERNAL_FORMAT) &&
+ (!Shuffle_Bytes)))
{
fprintf(stderr, "%s:\n", Program_Name);
fprintf(stderr,
Version, Sub_Version , Machine_Type);
fprintf(stderr,
"Expected: Version %d Subversion %d Machine Type %d\n",
- FASL_FORMAT_VERSION, FASL_SUBVERSION, FASL_INTERNAL_FORMAT);
- exit(1);
+ FASL_READ_VERSION, FASL_READ_SUBVERSION, FASL_INTERNAL_FORMAT);
+ quit(1);
}
if (Machine_Type == FASL_INTERNAL_FORMAT)
+ {
Shuffle_Bytes = false;
+ }
upgrade_traps = (Sub_Version < FASL_REFERENCE_TRAP);
+ upgrade_primitives = (Sub_Version < FASL_MERGED_PRIMITIVES);
+ upgrade_lengths = upgrade_primitives;
/* Constant Space not currently supported */
fprintf(stderr,
"%s: Input file has a constant space area.\n",
Program_Name);
- exit(1);
+ quit(1);
}
-
+\f
{
long Size;
- Size = ((3 * (Heap_Count + Const_Count)) + NROOTS + 1);
+ Size = ((3 * (Heap_Count + Const_Count)) +
+ (NROOTS + 1) +
+ (upgrade_primitives ?
+ (3 * PRIMITIVE_UPGRADE_SPACE) :
+ Primitive_Table_Size));
Allocate_Heap_Space(Size + HEAP_BUFFER_SPACE);
if (Heap == NULL)
fprintf(stderr,
"%s: Memory Allocation Failed. Size = %ld Scheme Pointers\n",
Program_Name, Size);
- exit(1);
+ quit(1);
}
}
+
Heap += HEAP_BUFFER_SPACE;
Initial_Align_Float(Heap);
Load_Data(Heap_Count, &Heap[0]);
Load_Data(Const_Count, &Heap[Heap_Count]);
+ Load_Data(Primitive_Table_Size, &Heap[Heap_Count + Const_Count]);
Heap_Relocation = &Heap[0] - Get_Pointer(Heap_Base);
Constant_Relocation = &Heap[Heap_Count] - Get_Pointer(Const_Base);
-#ifdef DEBUG
- fprintf(stderr, "Dumped Heap Base = 0x%08x\n", Heap_Base);
- fprintf(stderr, "Dumped Constant Base = 0x%08x\n", Const_Base);
- fprintf(stderr, "Dumped Constant Top = 0x%08x\n", Dumped_Constant_Top);
- fprintf(stderr, "Heap Count = %6d\n", Heap_Count);
- fprintf(stderr, "Constant Count = %6d\n", Const_Count);
-#endif
-\f
- /* Reformat the data */
+ DEBUGGING(fprintf(stderr,
+ "Dumped Heap Base = 0x%08x\n",
+ Heap_Base));
- NFlonums = NIntegers = NStrings = 0;
- NBits = NBBits = NChars = 0;
- Mem_Base = &Heap[Heap_Count + Const_Count];
+ DEBUGGING(fprintf(stderr,
+ "Dumped Constant Base = 0x%08x\n",
+ Const_Base));
+
+ DEBUGGING(fprintf(stderr,
+ "Dumped Constant Top = 0x%08x\n",
+ Dumped_Constant_Top));
+
+ DEBUGGING(fprintf(stderr,
+ "Heap Count = %6d\n",
+ Heap_Count));
- if (Ext_Prim_Vector == NIL)
+ DEBUGGING(fprintf(stderr,
+ "Constant Count = %6d\n",
+ Const_Count));
+\f
+ /* Determine primitive information. */
+
+ primitive_table = &Heap[Heap_Count + Const_Count];
+ if (upgrade_primitives)
{
- Mem_Base[0] = Make_Non_Pointer(TC_CELL, 2);
- Mem_Base[1] = Make_New_Pointer(TC_CELL, Dumped_Object);
- Mem_Base[2] = NIL;
- Initial_Free = NROOTS + 1;
- Scan = 1;
+ Mem_Base = setup_primitive_upgrade(primitive_table);
}
else
{
- Mem_Base[0] = Ext_Prim_Vector; /* Has CELL TYPE */
- Mem_Base[1] = Make_New_Pointer(TC_CELL, Dumped_Object);
- Initial_Free = NROOTS;
- Scan = 0;
+ fast Pointer *table;
+ fast long count, char_count;
+
+ for (char_count = 0,
+ count = Primitive_Table_Length,
+ table = primitive_table;
+ --count >= 0;)
+ {
+ char_count += STRING_LENGTH_TO_LONG(table[1 + STRING_LENGTH]);
+ table += (2 + Get_Integer(table[1 + STRING_HEADER]));
+ }
+ NPChars = char_count;
+ Mem_Base = &primitive_table[Primitive_Table_Size];
}
+\f
+ /* Reformat the data */
+
+ NFlonums = NIntegers = NStrings = 0;
+ NBits = NBBits = NChars = 0;
+
+ Mem_Base[0] = Make_New_Pointer(TC_CELL, Dumped_Object);
+ Initial_Free = NROOTS;
+ Scan = 0;
Free = Initial_Free;
Free_Objects = &Mem_Base[Heap_Count + Initial_Free];
Constant_Objects = 0;
#if true
+
Do_Area(HEAP_CODE, Scan, Free, Objects, Free_Objects);
+
#else
- /* When Constant Space finally becomes supported,
- something like this must be done. */
+
+ /*
+ When Constant Space finally becomes supported,
+ something like this must be done.
+ */
+
while (true)
{
- Do_Area(HEAP_CODE, Scan, Free, Objects, Free_Objects);
- Do_Area(CONSTANT_CODE, Scan_Constant,
- Free_Constant, Constant_Objects, Free_Cobjects);
- Do_Area(PURE_CODE, Scan_Pure, Fre_Pure, Pure_Objects, Free_Pobjects);
+ Do_Area(HEAP_CODE, Scan, Free,
+ Objects, Free_Objects);
+ Do_Area(CONSTANT_CODE, Scan_Constant, Free_Constant,
+ Constant_Objects, Free_Cobjects);
+ Do_Area(PURE_CODE, Scan_Pure, Free_Pure,
+ Pure_Objects, Free_Pobjects);
if (Scan == Free)
+ {
break;
+ }
}
+
#endif
\f
/* Consistency checks */
- When(((Free - Initial_Free) > Heap_Count), "Free overran Heap");
- When(((Free_Objects - &Mem_Base[Initial_Free + Heap_Count]) >
+ WHEN(((Free - Initial_Free) > Heap_Count), "Free overran Heap");
+
+ WHEN(((Free_Objects - &Mem_Base[Initial_Free + Heap_Count]) >
Heap_Count),
"Free_Objects overran Heap Object Space");
- When(((Free_Constant - (Initial_Free + (2 * Heap_Count))) > Const_Count),
+
+ WHEN(((Free_Constant - (Initial_Free + (2 * Heap_Count))) > Const_Count),
"Free_Constant overran Constant Space");
- When(((Free_Cobjects - &Mem_Base[Initial_Free + (2 * Heap_Count) + Const_Count]) >
+
+ WHEN(((Free_Cobjects - &Mem_Base[Initial_Free +
+ (2 * Heap_Count) + Const_Count]) >
Const_Count),
"Free_Cobjects overran Constant Object Space");
\f
/* Output the data */
+ if (found_ext_prims)
+ {
+ fprintf(stderr, "%s:\n", Program_Name);
+ fprintf(stderr, "NOTE: The arity of some primitives is not known.\n");
+ fprintf(stderr, " The portable file has %ld as their arity.\n",
+ UNKNOWN_PRIMITIVE_ARITY);
+ fprintf(stderr, " You may want to fix this by hand.\n");
+ }
+
/* Header */
- print_header("Portable Version", PORTABLE_VERSION, "%ld\n");
- print_header("Flags", Make_Flags(), "%ld\n");
- print_header("Version", FASL_FORMAT_VERSION, "%ld\n");
- print_header("Sub Version", FASL_SUBVERSION, "%ld\n");
+ PRINT_HEADER("Portable Version", PORTABLE_VERSION, "%ld\n");
+ PRINT_HEADER("Flags", Make_Flags(), "%ld\n");
+ PRINT_HEADER("Version", FASL_FORMAT_VERSION, "%ld\n");
+ PRINT_HEADER("Sub Version", FASL_SUBVERSION, "%ld\n");
- print_header("Heap Count", (Free - NROOTS), "%ld\n");
- print_header("Heap Base", NROOTS, "%ld\n");
- print_header("Heap Objects", Objects, "%ld\n");
+ PRINT_HEADER("Heap Count", (Free - NROOTS), "%ld\n");
+ PRINT_HEADER("Heap Base", NROOTS, "%ld\n");
+ PRINT_HEADER("Heap Objects", Objects, "%ld\n");
/* Currently Constant and Pure not supported, but the header is ready */
- print_header("Pure Count", 0, "%ld\n");
- print_header("Pure Base", Free_Constant, "%ld\n");
- print_header("Pure Objects", 0, "%ld\n");
+ PRINT_HEADER("Pure Count", 0, "%ld\n");
+ PRINT_HEADER("Pure Base", Free_Constant, "%ld\n");
+ PRINT_HEADER("Pure Objects", 0, "%ld\n");
+
+ PRINT_HEADER("Constant Count", 0, "%ld\n");
+ PRINT_HEADER("Constant Base", Free_Constant, "%ld\n");
+ PRINT_HEADER("Constant Objects", 0, "%ld\n");
- print_header("Constant Count", 0, "%ld\n");
- print_header("Constant Base", Free_Constant, "%ld\n");
- print_header("Constant Objects", 0, "%ld\n");
+ PRINT_HEADER("& Dumped Object", (Get_Integer(Mem_Base[0])), "%ld\n");
- print_header("& Dumped Object", (Get_Integer(Mem_Base[1])), "%ld\n");
- print_header("& Ext Prim Vector", (Get_Integer(Mem_Base[0])), "%ld\n");
+ PRINT_HEADER("Number of flonums", NFlonums, "%ld\n");
+ PRINT_HEADER("Number of integers", NIntegers, "%ld\n");
+ PRINT_HEADER("Number of bits in integers", NBits, "%ld\n");
+ PRINT_HEADER("Number of bit strings", NBitstrs, "%ld\n");
+ PRINT_HEADER("Number of bits in bit strings", NBBits, "%ld\n");
+ PRINT_HEADER("Number of character strings", NStrings, "%ld\n");
+ PRINT_HEADER("Number of characters in strings", NChars, "%ld\n");
- print_header("Number of flonums", NFlonums, "%ld\n");
- print_header("Number of integers", NIntegers, "%ld\n");
- print_header("Number of bits in integers", NBits, "%ld\n");
- print_header("Number of bit strings", NBitstrs, "%ld\n");
- print_header("Number of bits in bit strings", NBBits, "%ld\n");
- print_header("Number of character strings", NStrings, "%ld\n");
- print_header("Number of characters in strings", NChars, "%ld\n");
+ PRINT_HEADER("Number of primitives", Primitive_Table_Length, "%ld\n");
+ PRINT_HEADER("Number of characters in primitives", NPChars, "%ld\n");
\f
/* External Objects */
Free_Objects = &Mem_Base[Initial_Free + Heap_Count];
for (; Objects > 0; Objects -= 1)
+ {
print_external_object(Free_Objects);
+ }
#if false
/* Pure External Objects */
Free_Cobjects = &Mem_Base[Pure_Objects_Start];
for (; Pure_Objects > 0; Pure_Objects -= 1)
+ {
print_external_object(Free_Cobjects);
+ }
/* Constant External Objects */
print_an_object(*Free_Objects);
}
#endif
+\f
+ /* Primitives */
+
+ if (upgrade_primitives)
+ {
+ Pointer obj;
+ fast Pointer *table;
+ fast long count, datum;
+ for (count = Primitive_Table_Length,
+ table = external_renumber_table;
+ --count >= 0;)
+ {
+ obj = *table++;
+ datum = OBJECT_DATUM(obj);
+ if (OBJECT_TYPE(obj) == TC_PRIMITIVE_EXTERNAL)
+ {
+ Pointer *strobj;
+
+ strobj = ((Pointer *) (external_prim_name_table[datum]));
+ print_a_primitive(((long) UNKNOWN_PRIMITIVE_ARITY),
+ (STRING_LENGTH_TO_LONG(strobj[STRING_LENGTH])),
+ ((char *) &strobj[STRING_CHARS]));
+ }
+ else
+ {
+ char *string;
+
+ string = builtin_prim_name_table[datum];
+ print_a_primitive(((long) builtin_prim_arity_table[datum]),
+ ((long) strlen(string)),
+ string);
+ }
+ }
+ }
+ else
+ {
+ fast Pointer *table;
+ fast long count;
+ long arity;
+
+ for (count = Primitive_Table_Length, table = primitive_table;
+ --count >= 0;)
+ {
+ Sign_Extend(*table, arity);
+ table += 1;
+ print_a_primitive(arity,
+ (STRING_LENGTH_TO_LONG(table[STRING_LENGTH])),
+ ((char *) &table[STRING_CHARS]));
+ table += (1 + Get_Integer(table[STRING_HEADER]));
+ }
+ }
return;
}
\f
char *argv[];
{
Setup_Program(argc, argv, Noptions, Options);
- return;
+ do_it();
+ quit(0);
}
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.24 1987/04/16 02:20:20 jinx Rel $
+/* $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 $
*
* Named constants used throughout the interpreter
*
#define PRIM_NO_TRAP_EVAL -5
#define PRIM_NO_TRAP_APPLY -6
#define PRIM_POP_RETURN -7
-\f
-/* Interrupt bits -- scanned from LSB (1) to MSB (16) */
-
-#define INT_Stack_Overflow 1 /* Local interrupt */
-#define INT_Global_GC 2
-#define INT_GC 4 /* Local interrupt */
-#define INT_Global_1 8
-#define INT_Character 16 /* Local interrupt */
-#define INT_Global_2 32
-#define INT_Timer 64 /* Local interrupt */
-#define INT_Global_3 128
-#define INT_Global_Mask \
- (INT_Global_GC | INT_Global_1 | INT_Global_2 | INT_Global_3)
-#define Global_GC_Level 1
-#define Global_1_Level 3
-#define Global_2_Level 5
-#define Global_3_Level 7
-#define MAX_INTERRUPT_NUMBER 7
-
-#define INT_Mask ((1<<(MAX_INTERRUPT_NUMBER+1))-1)
+/* Some numbers of parameters which mean something special */
+
+#define LEXPR_PRIMITIVE_ARITY -1
+#define UNKNOWN_PRIMITIVE_ARITY -2
+\f
/* Error case detection for precomputed constants */
/* VMS preprocessor does not like line continuations in conditionals */
#define REGBLOCK_TEMP 4
#define REGBLOCK_EXPR 5
#define REGBLOCK_RETURN 6
-#define REGBLOCK_MINIMUM_LENGTH 7
+#define REGBLOCK_LEXPR_ACTUALS 7
+#define REGBLOCK_MINIMUM_LENGTH 8
\f
/* Codes specifying how to start scheme at boot time. */
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/fasl.h,v 9.24 1987/06/05 04:14:25 jinx Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/fasl.h,v 9.25 1987/11/17 08:10:04 jinx Rel $
Contains information relating to the format of FASL files.
Some information is contained in CONFIG.H.
\f
/* FASL Version */
-#define FASL_FILE_MARKER 0XFAFAFAFA
+#define FASL_FILE_MARKER 0xFAFAFAFA
/* The FASL file has a header which begins as follows: */
#define FASL_Offset_Const_Base 5 /* Address of const. area at dump */
#define FASL_Offset_Version 6 /* FASL format version info. */
#define FASL_Offset_Stack_Top 7 /* Top of stack when dumped */
-#define FASL_Offset_Ext_Loc 8 /* Where ext. prims. vector is */
+#define FASL_Offset_Prim_Length 8 /* Number of entries in primitive table */
+#define FASL_Offset_Prim_Size 9 /* Size of primitive table in Pointers */
-#define FASL_Offset_First_Free 9 /* Used to clear header */
+#define FASL_Offset_First_Free 10 /* Used to clear header */
+
+/* Aliases for backwards compatibility. */
+
+/* Where ext. prims. vector is */
+#define FASL_Offset_Ext_Loc FASL_Offset_Prim_Length
/* Version information encoding */
#define FASL_DENSE_TYPES 4
#define FASL_PADDED_STRINGS 5
#define FASL_REFERENCE_TRAP 6
+#define FASL_MERGED_PRIMITIVES 7
-/* Current parameters. */
+/* Current parameters. Always used on output. */
#define FASL_FORMAT_VERSION FASL_FORMAT_ADDED_STACK
-#define FASL_SUBVERSION FASL_REFERENCE_TRAP
-#define FASL_OLDEST_SUPPORTED FASL_PADDED_STRINGS
+#define FASL_SUBVERSION FASL_MERGED_PRIMITIVES
+
+/*
+ The definitions below correspond to the ones above. They usually
+ have the same values. They differ when the format is changing: A
+ system is built which reads the old format, but dumps the new one.
+ */
+
+#define FASL_READ_VERSION FASL_FORMAT_VERSION
+#define FASL_READ_SUBVERSION FASL_SUBVERSION
+
+/* These are for Bintopsb.
+ They are the values of the oldest supported formats.
+ */
+
+#define FASL_OLDEST_VERSION FASL_FORMAT_ADDED_STACK
+#define FASL_OLDEST_SUBVERSION FASL_PADDED_STRINGS
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/gctype.c,v 9.25 1987/10/09 16:11:06 jinx Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/gctype.c,v 9.26 1987/11/17 08:11:56 jinx Rel $
*
* This file contains the table which maps between Types and
* GC Types.
GC_Pair, /* TC_COMPILED_PROCEDURE */
GC_Vector, /* TC_BIG_FIXNUM */
GC_Pair, /* TC_PROCEDURE */
- GC_Non_Pointer, /* TC_PRIMITIVE_EXTERNAL */
+ GC_Undefined, /* 0x10 */
GC_Pair, /* TC_DELAY */
GC_Vector, /* TC_ENVIRONMENT */
GC_Pair, /* TC_DELAYED */
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.34 1987/11/04 20:02:10 cph Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/interp.c,v 9.35 1987/11/17 08:13:04 jinx Exp $
*
* This file contains the heart of the Scheme Scode
* interpreter
#define Immediate_GC(N) \
{ \
Request_GC(N); \
- Interrupt(IntCode & IntEnb); \
+ Interrupt(PENDING_INTERRUPTS()); \
}
#define Prepare_Eval_Repeat() \
Orig_Arg = *Arg; \
\
if (Type_Code(*Arg) != TC_FUTURE) \
+ { \
Pop_Return_Error(Err_No); \
+ } \
\
while ((Type_Code(*Arg) == TC_FUTURE) && (Future_Has_Value(*Arg))) \
{ \
- if (Future_Is_Keep_Slot(*Arg)) Log_Touch_Of_Future(*Arg); \
+ if (Future_Is_Keep_Slot(*Arg)) \
+ { \
+ Log_Touch_Of_Future(*Arg); \
+ } \
*Arg = Future_Value(*Arg); \
} \
if (Type_Code(*Arg) != TC_FUTURE) \
- goto Prim_No_Trap_Apply; \
+ { \
+ goto Apply_Non_Trapping; \
+ } \
\
Save_Cont(); \
Will_Push(STACK_ENV_EXTRA_SLOTS+2); \
\f
Repeat_Dispatch:
switch (Which_Way)
- { case PRIM_APPLY: goto Internal_Apply;
- case PRIM_NO_TRAP_APPLY: goto Apply_Non_Trapping;
- case PRIM_DO_EXPRESSION: Reduces_To(Fetch_Expression());
- case PRIM_NO_TRAP_EVAL: New_Reduction(Fetch_Expression(),Fetch_Env());
- goto Eval_Non_Trapping;
- case 0: if (!dumped_p) break; /* Else fall through */
- case PRIM_POP_RETURN: goto Pop_Return;
- default: Pop_Return_Error(Which_Way);
+ { case PRIM_APPLY:
+ goto Internal_Apply;
+
+ case PRIM_NO_TRAP_APPLY:
+ goto Apply_Non_Trapping;
+
+ case PRIM_DO_EXPRESSION:
+ Reduces_To(Fetch_Expression());
+
+ case PRIM_NO_TRAP_EVAL:
+ New_Reduction(Fetch_Expression(),Fetch_Env());
+ goto Eval_Non_Trapping;
+
+ case 0:
+ if (!dumped_p)
+ {
+ break;
+ }
+ /* Else fall through */
+
+ case PRIM_POP_RETURN:
+ goto Pop_Return;
+
+ default:
+ Pop_Return_Error(Which_Way);
+
case PRIM_INTERRUPT:
- { Save_Cont();
- Interrupt(IntCode & IntEnb);
+ {
+ Save_Cont();
+ Interrupt(PENDING_INTERRUPTS());
}
- case 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);
- case ERR_ARG_3_WRONG_TYPE: Arg_Type_Error(3, ERR_ARG_3_WRONG_TYPE);
+
+ case 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);
+
+ case ERR_ARG_3_WRONG_TYPE:
+ Arg_Type_Error(3, ERR_ARG_3_WRONG_TYPE);
}
\f
Do_Expression:
case TC_NON_MARKED_VECTOR:
case TC_NULL:
case TC_PRIMITIVE:
- case TC_PRIMITIVE_EXTERNAL:
case TC_PROCEDURE:
case TC_QUAD:
case TC_UNINTERNED_SYMBOL:
/* In case we back out */
Reserve_Stack_Space(); /* CONTINUATION_SIZE */
Finished_Eventual_Pushing(); /* of this primitive */
+ Store_Expression(Make_New_Pointer(TC_PRIMITIVE, Fetch_Expression()));
+ goto Primitive_Internal_Apply;
-Primitive_Internal_Apply:
- if (Microcode_Does_Stepping && Trapping &&
- (Fetch_Apply_Trapper() != NIL))
- {Will_Push(3);
- Push(Fetch_Expression());
- Push(Fetch_Apply_Trapper());
- Push(STACK_FRAME_HEADER + 1 +
- N_Args_Primitive(Get_Integer(Fetch_Expression())));
- Pushed();
- Stop_Trapping();
- goto Apply_Non_Trapping;
- }
-Prim_No_Trap_Apply:
- {
- fast long primitive_code;
-
- primitive_code = Get_Integer(Fetch_Expression());
-
- Export_Regs_Before_Primitive();
- Metering_Apply_Primitive(Val, primitive_code);
- Import_Regs_After_Primitive();
- Pop_Primitive_Frame(N_Args_Primitive(primitive_code));
- if (Must_Report_References())
- { Store_Expression(Val);
- Store_Return(RC_RESTORE_VALUE);
- Save_Cont();
- Call_Future_Logging();
- }
- break;
- }
-\f
case TC_PCOMB1:
Reserve_Stack_Space(); /* 1+CONTINUATION_SIZE */
Do_Nth_Then(RC_PCOMB1_APPLY, PCOMB1_ARG_SLOT, {});
if (temp == PRIM_INTERRUPT)
{
Prepare_Eval_Repeat();
- Interrupt(IntCode & IntEnb);
+ Interrupt(PENDING_INTERRUPTS());
}
Eval_Error(temp);
Pop_Return_Error(Result);
}
Prepare_Pop_Return_Interrupt(RC_EXECUTE_ACCESS_FINISH, value);
- Interrupt(IntCode & IntEnb);
+ Interrupt(PENDING_INTERRUPTS());
}
Val = value;
Pop_Return_Error(ERR_BAD_FRAME);
Prepare_Pop_Return_Interrupt(RC_EXECUTE_ASSIGNMENT_FINISH,
value);
- Interrupt(IntCode & IntEnb);
+ Interrupt(PENDING_INTERRUPTS());
}
/* Interpret() continues on the next page */
{
Prepare_Pop_Return_Interrupt(RC_EXECUTE_DEFINITION_FINISH,
value);
- Interrupt(IntCode & IntEnb);
+ Interrupt(PENDING_INTERRUPTS());
}
Val = value;
Pop_Return_Error(result);
Apply_Non_Trapping:
- if ((IntCode & IntEnb) != 0)
+ if ((PENDING_INTERRUPTS()) != 0)
{
long Interrupts;
- Interrupts = (IntCode & IntEnb);
+ Interrupts = (PENDING_INTERRUPTS());
Store_Expression(NIL);
Val = NIL;
Prepare_Apply_Interrupt();
/*
After checking the number of arguments, remove the
frame header since primitives do not expect it.
+
+ NOTE: This code must match the application code which
+ follows Primitive_Internal_Apply.
*/
case TC_PRIMITIVE:
{
- if (Get_Integer(Stack_Ref(STACK_ENV_HEADER)) !=
- STACK_ENV_FIRST_ARG + N_Args_Primitive(Get_Integer(Function)) - 1)
+ long nargs;
+ fast long primitive_code;
+
+ primitive_code = OBJECT_DATUM(Function);
+ if (primitive_code > MAX_PRIMITIVE)
{
- Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
+ Apply_Error(ERR_UNIMPLEMENTED_PRIMITIVE);
}
- Stack_Pointer = Simulate_Popping(STACK_ENV_FIRST_ARG);
- Store_Expression(Function);
- goto Prim_No_Trap_Apply;
- }
- case TC_PRIMITIVE_EXTERNAL:
- {
- fast long NArgs, Proc;
-
- Proc = Datum(Function);
- if (Proc > MAX_EXTERNAL_PRIMITIVE)
+ /* Note that the 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))
{
- Apply_Error(ERR_UNDEFINED_PRIMITIVE);
+ if (PRIMITIVE_ARITY(primitive_code) != LEXPR_PRIMITIVE_ARITY)
+ {
+ Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
+ }
+ Regs[REGBLOCK_LEXPR_ACTUALS] = ((Pointer) nargs);
}
- NArgs = N_Args_External(Proc);
- if (Get_Integer(Stack_Ref(STACK_ENV_HEADER)) !=
- (NArgs + (STACK_ENV_FIRST_ARG - 1)))
- {
- Apply_Error(ERR_WRONG_NUMBER_OF_ARGUMENTS);
- }
Stack_Pointer = Simulate_Popping(STACK_ENV_FIRST_ARG);
Store_Expression(Function);
-Repeat_External_Primitive:
- /* Reinitialize Proc in case we "goto Repeat_External..." */
- Proc = Get_Integer(Fetch_Expression());
-
Export_Regs_Before_Primitive();
- Val = Apply_External(Proc);
- Set_Time_Zone(Zone_Working);
+ Metering_Apply_Primitive(Val, primitive_code);
Import_Regs_After_Primitive();
- Pop_Primitive_Frame(N_Args_External(Proc));
+ Pop_Primitive_Frame(nargs);
+ if (Must_Report_References())
+ {
+ Store_Expression(Val);
+ Store_Return(RC_RESTORE_VALUE);
+ Save_Cont();
+ Call_Future_Logging();
+ }
goto Pop_Return;
}
}
case PRIM_INTERRUPT:
- { compiled_error_backout();
+ {
+ compiled_error_backout();
Save_Cont();
- Interrupt( (IntCode & IntEnb));
+ Interrupt(PENDING_INTERRUPTS());
}
\f
case ERR_WRONG_NUMBER_OF_ARGUMENTS:
- { apply_compiled_backout();
+ {
+ apply_compiled_backout();
Apply_Error( Which_Way);
}
+ case ERR_UNIMPLEMENTED_PRIMITIVE:
+ {
+ /* 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;
+ }
+\f
case ERR_EXECUTE_MANIFEST_VECTOR:
{ /* This error code means that enter_compiled_expression
was called in a system without compiler support.
Push(Val); /* Argument value */
Finished_Eventual_Pushing();
Store_Expression(Fast_Vector_Ref(Fetch_Expression(), PCOMB1_FN_SLOT));
- goto Primitive_Internal_Apply;
+Primitive_Internal_Apply:
+ if (Microcode_Does_Stepping && Trapping &&
+ (Fetch_Apply_Trapper() != NIL))
+ {
+ /* Does this work in the stacklet case?
+ We may have a non-contiguous frame. -- Jinx
+ */
+ Will_Push(3);
+ Push(Fetch_Expression());
+ Push(Fetch_Apply_Trapper());
+ Push(STACK_FRAME_HEADER + 1 +
+ PRIMITIVE_N_PARAMETERS(OBJECT_DATUM(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.
+ */
+ {
+ 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);
+ }
+
+ Export_Regs_Before_Primitive();
+ Metering_Apply_Primitive(Val, primitive_code);
+ Import_Regs_After_Primitive();
+
+ Pop_Primitive_Frame(PRIMITIVE_ARITY(primitive_code));
+ if (Must_Report_References())
+ {
+ Store_Expression(Val);
+ Store_Return(RC_RESTORE_VALUE);
+ Save_Cont();
+ Call_Future_Logging();
+ }
+ break;
+ }
+\f
case RC_PCOMB2_APPLY:
End_Subproblem();
Push(Val); /* Value of arg. 1 */
Restore_Cont();
goto Repeat_Dispatch;
- case RC_REPEAT_PRIMITIVE:
- if (Type_Code(Fetch_Expression()) == TC_PRIMITIVE_EXTERNAL)
- goto Repeat_External_Primitive;
- else goto Primitive_Internal_Apply;
-
/* Interpret() continues on the next page */
\f
/* Interpret(), continued */
*/
case RC_RESTORE_DONT_COPY_HISTORY:
- { Pointer Stacklet;
+ {
+ Pointer Stacklet;
+
Prev_Restore_History_Offset = Get_Integer(Pop());
Stacklet = Pop();
History = Get_Pointer(Fetch_Expression());
if (Prev_Restore_History_Offset == 0)
+ {
Prev_Restore_History_Stacklet = NULL;
+ }
else if (Stacklet == NIL)
+ {
Prev_Restore_History_Stacklet = NULL;
+ }
else
+ {
Prev_Restore_History_Stacklet = Get_Pointer(Stacklet);
+ }
break;
}
case RC_RESTORE_FLUIDS:
Fluid_Bindings = Fetch_Expression();
- New_Compiler_MemTop();
+ /* Why is this here? -- Jinx */
+ COMPILER_SETUP_INTERRUPT();
break;
case RC_RESTORE_INT_MASK:
- IntEnb = Get_Integer(Fetch_Expression());
- New_Compiler_MemTop();
+ SET_INTERRUPT_MASK(Get_Integer(Fetch_Expression()));
break;
/* Interpret() continues on the next page */
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/lookup.c,v 9.37 1987/11/04 20:01:34 cph Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/lookup.c,v 9.38 1987/11/17 08:14:11 jinx Rel $
*
* This file contains symbol lookup and modification routines. See
* Hal Abelson for a paper describing and justifying the algorithm.
(set! <symbol> <value>) in <environment>.
*/
Built_In_Primitive(Prim_Lexical_Assignment, 3, "LEXICAL-ASSIGNMENT", 0x0)
+Define_Primitive(Prim_Lexical_Assignment, 3, "LEXICAL-ASSIGNMENT")
{
Primitive_3_Args();
Indistinguishable from evaluating <symbol> in <environment>.
*/
Built_In_Primitive(Prim_Lexical_Reference, 2, "LEXICAL-REFERENCE", 0x12)
+Define_Primitive(Prim_Lexical_Reference, 2, "LEXICAL-REFERENCE")
{
Primitive_2_Args();
Identical to LEXICAL_REFERENCE, here for histerical reasons.
*/
Built_In_Primitive(Prim_Local_Reference, 2, "LOCAL-REFERENCE", 0x1)
+Define_Primitive(Prim_Local_Reference, 2, "LOCAL-REFERENCE")
{
Primitive_2_Args();
(define <symbol> <value>) in <environment>.
*/
Built_In_Primitive(Prim_Local_Assignment, 3, "LOCAL-ASSIGNMENT", 0x2)
+Define_Primitive(Prim_Local_Assignment, 3, "LOCAL-ASSIGNMENT")
{
Primitive_3_Args();
The special form (unassigned? <symbol>) is built on top of this.
*/
Built_In_Primitive(Prim_Unassigned_Test, 2, "LEXICAL-UNASSIGNED?", 0x18)
+Define_Primitive(Prim_Unassigned_Test, 2, "LEXICAL-UNASSIGNED?")
{
Primitive_2_Args();
The special form (unbound? <symbol>) is built on top of this.
*/
Built_In_Primitive(Prim_Unbound_Test, 2, "LEXICAL-UNBOUND?", 0x33)
+Define_Primitive(Prim_Unbound_Test, 2, "LEXICAL-UNBOUND?")
{
Primitive_2_Args();
*/
Built_In_Primitive(Prim_Unreferenceable_Test, 2,
"LEXICAL-UNREFERENCEABLE?", 0x13)
+Define_Primitive(Prim_Unreferenceable_Test, 2,
+ "LEXICAL-UNREFERENCEABLE?")
{
long Result;
Primitive_2_Args();
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/ppband.c,v 9.28 1987/10/09 16:08:24 jinx Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/ppband.c,v 9.29 1987/11/17 08:04:37 jinx Rel $
*
* Dumps Scheme FASL in user-readable form .
*/
-\f
-#include "scheme.h"
+#include <stdio.h>
+#include "config.h"
+#include "types.h"
+#include "const.h"
+#include "object.h"
+#include "sdata.h"
+
+#define fast register
+\f
/* These are needed by load.c */
static Pointer *Memory_Base;
\f
#define Reloc_or_Load_Debug true
+#include "fasl.h"
#include "load.c"
-#include "gctype.c"
#ifdef Heap_In_Low_Memory
#ifdef spectrum
#define Relocate(P) \
(((long) (P) < Const_Base) ? \
File_To_Pointer(((long) (P)) - Heap_Base) : \
- (Heap_Count+File_To_Pointer(((long) (P)) - Const_Base)))
+ (Heap_Count + File_To_Pointer(((long) (P)) - Const_Base)))
#else
#define Relocate_Into(What, P)
if (((long) (P)) < Const_Base)
fast long i, Count;
fast char *Chars;
- Chars = (char *) &Data[From+STRING_CHARS];
+ Chars = ((char *) &Data[From + STRING_CHARS]);
if (Chars < ((char *) end_of_memory))
- { Count = Get_Integer(Data[From+STRING_LENGTH]);
+ {
+ Count = ((long) (Data[From + STRING_LENGTH]));
if (&Chars[Count] < ((char *) end_of_memory))
- { putchar(Quoted ? '\"' : '\'');
- for (i=0; i < Count; i++) printf("%c", *Chars++);
- if (Quoted) putchar('\"');
+ {
+ if (Quoted)
+ {
+ putchar('\"');
+ }
+ for (i = 0; i < Count; i++)
+ {
+ printf("%c", *Chars++);
+ }
+ if (Quoted)
+ {
+ putchar('\"');
+ }
putchar('\n');
- return true;
+ return (true);
}
}
if (Quoted)
- printf("String not in memory; datum = %x\n", From);
- return false;
+ {
+ printf("String not in memory; datum = %lx\n", From);
+ }
+ return (false);
}
#define via(File_Address) Relocate(OBJECT_DATUM(Data[File_Address]))
symbol = &Data[From+SYMBOL_NAME];
if ((symbol >= end_of_memory) ||
- !scheme_string(via(From+SYMBOL_NAME), false))
- printf("symbol not in memory; datum = %x\n", From);
+ (!(scheme_string(via(From + SYMBOL_NAME), false))))
+ {
+ printf("symbol not in memory; datum = %lx\n", From);
+ }
return;
}
\f
+static char string_buffer[10];
+
+#define PRINT_OBJECT(type, datum) \
+{ \
+ printf("[%s %lx]", type, datum); \
+}
+
+#define NON_POINTER(string) \
+{ \
+ the_string = string; \
+ Points_To = The_Datum; \
+ break; \
+}
+
+#define POINTER(string) \
+{ \
+ the_string = string; \
+ break; \
+}
+
void
Display(Location, Type, The_Datum)
long Location, Type, The_Datum;
{
+ char *the_string;
long Points_To;
- printf("%5x: %2x|%6x ", Location, Type, The_Datum);
- if (GC_Type_Map[Type] != GC_Non_Pointer)
- Points_To = Relocate((Pointer *) The_Datum);
- else
- Points_To = The_Datum;
+ printf("%5lx: %2lx|%6lx ", Location, Type, The_Datum);
+ Points_To = Relocate((Pointer *) The_Datum);
+
switch (Type)
{ /* "Strange" cases */
- case TC_NULL: if (The_Datum == 0)
- { printf("NIL\n");
- return;
- }
- else printf("[NULL ");
- break;
- case TC_TRUE: if (The_Datum == 0)
- { printf("TRUE\n");
- return;
- }
- else printf("[TRUE ");
- break;
- case TC_BROKEN_HEART: printf("[BROKEN-HEART ");
- if (The_Datum == 0)
- Points_To = 0;
- break;
- case TC_MANIFEST_SPECIAL_NM_VECTOR: printf("[MANIFEST-SPECIAL-NM ");
- Points_To = The_Datum;
- break;
- case TC_MANIFEST_NM_VECTOR: printf("[MANIFEST-NM-VECTOR ");
- Points_To = The_Datum;
- break;
- case TC_INTERNED_SYMBOL: scheme_symbol(Points_To);
- return;
+ case TC_NULL:
+ if (The_Datum == 0)
+ {
+ printf("NIL\n");
+ return;
+ }
+ NON_POINTER("NULL");
+
+ case TC_TRUE:
+ if (The_Datum == 0)
+ {
+ printf("TRUE\n");
+ return;
+ }
+ NON_POINTER("TRUE");
+
+ case TC_MANIFEST_SPECIAL_NM_VECTOR:
+ NON_POINTER("MANIFEST-SPECIAL-NM");
+
+ case TC_MANIFEST_NM_VECTOR:
+ NON_POINTER("MANIFEST-NM-VECTOR");
+\f
+ case TC_BROKEN_HEART:
+ if (The_Datum == 0)
+ {
+ Points_To = 0;
+ }
+ POINTER("BROKEN-HEART");
+
+ case TC_INTERNED_SYMBOL:
+ PRINT_OBJECT("INTERNED-SYMBOL", Points_To);
+ printf(" = ");
+ scheme_symbol(Points_To);
+ return;
+
case TC_UNINTERNED_SYMBOL:
- printf("uninterned ");
+ PRINT_OBJECT("UNINTERNED-SYMBOL", Points_To);
+ printf(" = ");
scheme_symbol(Points_To);
return;
- case TC_CHARACTER_STRING: scheme_string(Points_To, true);
- return;
- case TC_FIXNUM: printf("%d\n", Points_To);
- return;
-
- /* Default cases */
- case TC_LIST: printf("[LIST "); break;
- case TC_CHARACTER: printf("[CHARACTER "); break;
- case TC_SCODE_QUOTE: printf("[SCODE-QUOTE "); break;
- case TC_PCOMB2: printf("[PCOMB2 "); break;
- case TC_BIG_FLONUM: printf("[BIG-FLONUM "); break;
- case TC_COMBINATION_1: printf("[COMBINATION-1 "); break;
- case TC_EXTENDED_PROCEDURE: printf("[EXTENDED-PROCEDURE "); break;
- case TC_VECTOR: printf("[VECTOR "); break;
- case TC_RETURN_CODE: printf("[RETURN-CODE "); break;
- case TC_COMBINATION_2: printf("[COMBINATION-2 "); break;
- case TC_COMPILED_PROCEDURE: printf("[COMPILED-PROCEDURE "); break;
- case TC_BIG_FIXNUM: printf("[BIG-FIXNUM "); break;
- case TC_PROCEDURE: printf("[PROCEDURE "); break;
- case TC_PRIMITIVE_EXTERNAL: printf("[PRIMITIVE-EXTERNAL "); break;
- case TC_DELAY: printf("[DELAY "); break;
- case TC_ENVIRONMENT: printf("[ENVIRONMENT "); break;
- case TC_DELAYED: printf("[DELAYED "); break;
- case TC_EXTENDED_LAMBDA: printf("[EXTENDED-LAMBDA "); break;
- case TC_COMMENT: printf("[COMMENT "); break;
- case TC_NON_MARKED_VECTOR: printf("[NON-MARKED-VECTOR "); break;
- case TC_LAMBDA: printf("[LAMBDA "); break;
- case TC_PRIMITIVE: printf("[PRIMITIVE "); break;
- case TC_SEQUENCE_2: printf("[SEQUENCE-2 "); break;
- case TC_PCOMB1: printf("[PCOMB1 "); break;
- case TC_CONTROL_POINT: printf("[CONTROL-POINT "); break;
- case TC_ACCESS: printf("[ACCESS "); break;
- case TC_DEFINITION: printf("[DEFINITION "); break;
- case TC_ASSIGNMENT: printf("[ASSIGNMENT "); break;
- case TC_HUNK3_A: printf("[HUNK3_A "); break;
- case TC_HUNK3_B: printf("[HUNK3_B "); break;
- case TC_IN_PACKAGE: printf("[IN-PACKAGE "); break;
- case TC_COMBINATION: printf("[COMBINATION "); break;
- case TC_COMPILED_EXPRESSION: printf("[COMPILED-EXPRESSION "); break;
- case TC_LEXPR: printf("[LEXPR "); break;
- case TC_PCOMB3: printf("[PCOMB3 "); break;
-
- case TC_VARIABLE: printf("[VARIABLE "); break;
- case TC_THE_ENVIRONMENT: printf("[THE-ENVIRONMENT "); break;
- case TC_FUTURE: printf("[FUTURE "); break;
- case TC_VECTOR_1B: printf("[VECTOR-1B "); break;
- case TC_PCOMB0: printf("[PCOMB0 "); break;
- case TC_VECTOR_16B: printf("[VECTOR-16B "); break;
- case TC_SEQUENCE_3: printf("[SEQUENCE-3 "); break;
- case TC_CONDITIONAL: printf("[CONDITIONAL "); break;
- case TC_DISJUNCTION: printf("[DISJUNCTION "); break;
- case TC_CELL: printf("[CELL "); break;
- case TC_WEAK_CONS: printf("[WEAK-CONS "); break;
- case TC_REFERENCE_TRAP: printf("[REFERENCE-TRAP "); break;
- case TC_RETURN_ADDRESS: printf("[RETURN-ADDRESS "); break;
- case TC_COMPILER_LINK: printf("[COMPILER-LINK "); break;
- case TC_STACK_ENVIRONMENT: printf("[STACK-ENVIRONMENT "); break;
- case TC_COMPLEX: printf("[COMPLEX "); break;
- case TC_QUAD: printf("[QUAD "); break;
-
- default: printf("[0x%02x ", Type); break;
+
+ case TC_CHARACTER_STRING:
+ PRINT_OBJECT("CHARACTER-STRING", Points_To);
+ printf(" = ");
+ scheme_string(Points_To, true);
+ return;
+
+ case TC_FIXNUM:
+ PRINT_OBJECT("FIXNUM", The_Datum);
+ Sign_Extend(The_Datum, Points_To);
+ printf(" = %ld\n", Points_To);
+ return;
+
+ case TC_REFERENCE_TRAP:
+ if (The_Datum <= TRAP_MAX_IMMEDIATE)
+ {
+ NON_POINTER("REFERENCE-TRAP");
+ }
+ else
+ {
+ POINTER("REFERENCE-TRAP");
+ }
+
+ case TC_CHARACTER: NON_POINTER("CHARACTER");
+ case TC_RETURN_CODE: NON_POINTER("RETURN-CODE");
+ case TC_PRIMITIVE: NON_POINTER("PRIMITIVE");
+ case TC_THE_ENVIRONMENT: NON_POINTER("THE-ENVIRONMENT");
+ case TC_PCOMB0: NON_POINTER("PCOMB0");
+ case TC_LIST: POINTER("LIST");
+ case TC_SCODE_QUOTE: POINTER("SCODE-QUOTE");
+ case TC_PCOMB2: POINTER("PCOMB2");
+ case TC_BIG_FLONUM: POINTER("FLONUM");
+\f
+ case TC_COMBINATION_1: POINTER("COMBINATION-1");
+ case TC_EXTENDED_PROCEDURE: POINTER("EXTENDED-PROCEDURE");
+ case TC_VECTOR: POINTER("VECTOR");
+ case TC_COMBINATION_2: POINTER("COMBINATION-2");
+ case TC_COMPILED_PROCEDURE: POINTER("COMPILED-PROCEDURE");
+ case TC_BIG_FIXNUM: POINTER("BIG-FIXNUM");
+ case TC_PROCEDURE: POINTER("PROCEDURE");
+ case TC_DELAY: POINTER("DELAY");
+ case TC_ENVIRONMENT: POINTER("ENVIRONMENT");
+ case TC_DELAYED: POINTER("DELAYED");
+ case TC_EXTENDED_LAMBDA: POINTER("EXTENDED-LAMBDA");
+ case TC_COMMENT: POINTER("COMMENT");
+ case TC_NON_MARKED_VECTOR: POINTER("NON-MARKED-VECTOR");
+ case TC_LAMBDA: POINTER("LAMBDA");
+ case TC_SEQUENCE_2: POINTER("SEQUENCE-2");
+ case TC_PCOMB1: POINTER("PCOMB1");
+ case TC_CONTROL_POINT: POINTER("CONTROL-POINT");
+ case TC_ACCESS: POINTER("ACCESS");
+ case TC_DEFINITION: POINTER("DEFINITION");
+ case TC_ASSIGNMENT: POINTER("ASSIGNMENT");
+ case TC_HUNK3_A: POINTER("HUNK3_A");
+ case TC_HUNK3_B: POINTER("HUNK3-B");
+ case TC_IN_PACKAGE: POINTER("IN-PACKAGE");
+ case TC_COMBINATION: POINTER("COMBINATION");
+ case TC_COMPILED_EXPRESSION: POINTER("COMPILED-EXPRESSION");
+ case TC_LEXPR: POINTER("LEXPR");
+ case TC_PCOMB3: POINTER("PCOMB3");
+ case TC_VARIABLE: POINTER("VARIABLE");
+ case TC_FUTURE: POINTER("FUTURE");
+ case TC_VECTOR_1B: POINTER("VECTOR-1B");
+ case TC_VECTOR_16B: POINTER("VECTOR-16B");
+ case TC_SEQUENCE_3: POINTER("SEQUENCE-3");
+ case TC_CONDITIONAL: POINTER("CONDITIONAL");
+ case TC_DISJUNCTION: POINTER("DISJUNCTION");
+ case TC_CELL: POINTER("CELL");
+ case TC_WEAK_CONS: POINTER("WEAK-CONS");
+ case TC_RETURN_ADDRESS: POINTER("RETURN-ADDRESS");
+ case TC_COMPILER_LINK: POINTER("COMPILER_LINK");
+ case TC_STACK_ENVIRONMENT: POINTER("STACK-ENVIRONMENT");
+ case TC_COMPLEX: POINTER("COMPLEX");
+ case TC_QUAD: POINTER("QUAD");
+ case TC_COMPILED_CODE_BLOCK: POINTER("COMPILED-CODE-BLOCK");
+
+ default:
+ sprintf(&the_string[0], "0x%02lx ", Type);
+ POINTER(&the_string[0]);
}
- printf("%x]\n", Points_To);
+ PRINT_OBJECT(the_string, Points_To);
+ putchar('\n');
+ return;
}
+\f
+Pointer *
+show_area(area, size, name)
+ fast Pointer *area;
+ fast long size;
+ char *name;
+{
+ fast long i;
+ printf("\n%s contents:\n\n", name);
+ for (i = 0; i < size; area++, i++)
+ {
+ if (OBJECT_TYPE(*area) == TC_MANIFEST_NM_VECTOR)
+ {
+ fast long j, count;
+
+ count = Get_Integer(*area);
+ Display(i, OBJECT_TYPE(*area), OBJECT_DATUM(*area));
+ area += 1;
+ for (j = 0; j < count ; j++, area++)
+ {
+ printf(" %02lx%06lx\n",
+ OBJECT_TYPE(*area), OBJECT_DATUM(*area));
+ }
+ i += count;
+ area -= 1;
+ }
+ else
+ {
+ Display(i, OBJECT_TYPE(*area), OBJECT_DATUM(*area));
+ }
+ }
+ return (area);
+}
+\f
main(argc, argv)
int argc;
char **argv;
{
- Pointer *Next;
- long i, total_length;
+ fast Pointer *Next;
+ long total_length, load_length;
if (argc == 1)
{
if (!Read_Header())
- { fprintf(stderr, "Input does not appear to be in FASL format.\n");
+ {
+ fprintf(stderr,
+ "%s: Input does not appear to be in correct FASL format.\n",
+ argv[0]);
exit(1);
}
- printf("Dumped object at 0x%x\n", Relocate(Dumped_Object));
- if (Sub_Version >= FASL_LONG_HEADER)
- printf("External primitives at 0x%x\n\n", Relocate(Ext_Prim_Vector));
+ printf("Dumped object at 0x%lx\n", Relocate(Dumped_Object));
}
else
{
Const_Count = 0;
+ Primitive_Table_Size = 0;
sscanf(argv[1], "%x", &Heap_Base);
sscanf(argv[2], "%x", &Const_Base);
sscanf(argv[3], "%d", &Heap_Count);
- printf("Heap Base = 0x%08x; Constant Base = 0x%08x; Heap Count = %d\n",
+ printf("Heap Base = 0x%08lx; Constant Base = 0x%08lx; Heap Count = %ld\n",
Heap_Base, Const_Base, Heap_Count);
}
- Data = ((Pointer *) malloc(sizeof(Pointer) * (Heap_Count + Const_Count)));
+\f
+ load_length = (Heap_Count + Const_Count + Primitive_Table_Size);
+ Data = ((Pointer *) malloc(sizeof(Pointer) * (load_length + 4)));
if (Data == NULL)
{
- fprintf(stderr, "Allocation of %d words failed.\n", (Heap_Count + Const_Count));
+ fprintf(stderr, "Allocation of %ld words failed.\n", (load_length + 4));
exit(1);
}
- end_of_memory = &Data[Heap_Count + Const_Count];
- total_length = Load_Data(Heap_Count + Const_Count, Data);
- if (total_length != (Heap_Count + Const_Count))
+ total_length = Load_Data(load_length, Data);
+ end_of_memory = &Data[total_length];
+ if (total_length != load_length)
{
printf("The FASL file does not have the right length.\n");
- printf("Expected %d objects. Obtained %d objects.\n\n",
- (Heap_Count + Const_Count), total_length);
+ printf("Expected %d objects. Obtained %ld objects.\n\n",
+ load_length, total_length);
if (total_length < Heap_Count)
{
Heap_Count = total_length;
{
Const_Count = total_length;
}
- }
- printf("Heap contents:\n\n");
- for (Next = Data, i = 0; i < Heap_Count; Next++, i++)
- {
- if (OBJECT_TYPE(*Next) == TC_MANIFEST_NM_VECTOR)
+ total_length -= Const_Count;
+ if (total_length < Primitive_Table_Size)
{
- long j, count;
-
- count = Get_Integer(*Next);
- Display(i, OBJECT_TYPE(*Next), OBJECT_DATUM(*Next));
- Next += 1;
- for (j = 0; j < count ; j++, Next++)
- {
- printf(" %02x%06x\n",
- OBJECT_TYPE(*Next), OBJECT_DATUM(*Next));
- }
- i += count;
- Next -= 1;
- }
- else
- {
- Display(i, OBJECT_TYPE(*Next), OBJECT_DATUM(*Next));
+ Primitive_Table_Size = total_length;
}
}
- printf("\n\nConstant space:\n\n");
- for (; i < Heap_Count + Const_Count; Next++, i++)
+\f
+ if (Heap_Count > 0)
{
- if (OBJECT_TYPE(*Next) == TC_MANIFEST_NM_VECTOR)
- {
- long j, count;
+ Next = show_area(Data, Heap_Count, "Heap");
+ }
+ if (Const_Count > 0)
+ {
+ Next = show_area(Next, Const_Count, "Constant Space");
+ }
+ if ((Primitive_Table_Size > 0) && (Next < end_of_memory))
+ {
+ long arity, size;
+ fast long entries, count;
- count = Get_Integer(*Next);
- Display(i, OBJECT_TYPE(*Next), OBJECT_DATUM(*Next));
- Next += 1;
- for (j = 0; j < count ; j++, Next++)
- {
- printf(" %02x%06x\n",
- OBJECT_TYPE(*Next), OBJECT_DATUM(*Next));
- }
- i += count;
- Next -= 1;
- }
- else
+ /* This is done in case the file is short. */
+ end_of_memory[0] = ((Pointer) 0);
+ end_of_memory[1] = ((Pointer) 0);
+ end_of_memory[2] = ((Pointer) 0);
+ end_of_memory[3] = ((Pointer) 0);
+
+ entries = Primitive_Table_Length;
+ printf("\nPrimitive table: number of entries = %ld\n\n", entries);
+
+ for (count = 0;
+ ((count < entries) && (Next < end_of_memory));
+ count += 1)
{
- Display(i, OBJECT_TYPE(*Next), OBJECT_DATUM(*Next));
+ Sign_Extend(*Next++, arity);
+ size = Get_Integer(*Next);
+ printf("Number = %3lx; Arity = %2ld; Name = ", count, arity);
+ scheme_string((Next - Data), true);
+ Next += (1 + size);
}
+ printf("\n");
}
+ exit(0);
}
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/psbmap.h,v 9.22 1987/08/07 15:36:46 jinx Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/psbmap.h,v 9.23 1987/11/17 08:18:32 jinx Exp $
*
* This file contains macros and declarations for Bintopsb.c
* and Psbtobin.c
#include "object.h"
#include "bignum.h"
#include "bitstr.h"
-#include "gc.h"
#include "types.h"
#include "sdata.h"
#include "const.h"
#include "missing.c"
#endif
-#define PORTABLE_VERSION 2
+#define PORTABLE_VERSION 3
/* Number of objects which, when traced recursively, point at all other
- objects dumped. Currently the dumped object and the external
- primitives vector.
+ objects dumped. Currently only the dumped object.
*/
-#define NROOTS 2
+#define NROOTS 1
/* Types to recognize external object references. Any occurrence of these
(which are external types and thus handled separately) means a reference
to an external object.
*/
-#define CONSTANT_CODE TC_BIG_FIXNUM
-#define HEAP_CODE TC_FIXNUM
+#define CONSTANT_CODE TC_FIXNUM
+#define HEAP_CODE TC_CHARACTER
#define fixnum_to_bits FIXNUM_LENGTH
#define bignum_to_bits(len) ((len) * SHIFT)
Boolean *ptr;
};
-Boolean strequal(s1, s2)
-fast char *s1, *s2;
-{ while (*s1 != '\0')
- if (*s1++ != *s2++) return false;
+Boolean
+strequal(s1, s2)
+ fast char *s1, *s2;
+{
+ while (*s1 != '\0')
+ {
+ if (*s1++ != *s2++)
+ {
+ return false;
+ }
+ }
return (*s2 == '\0');
}
-char *Find_Options(argc, argv, Noptions, Options)
-int argc;
-char **argv;
-int Noptions;
-struct Option_Struct Options[];
-{ for ( ; --argc >= 0; argv++)
- { char *this = *argv;
+char *
+Find_Options(argc, argv, Noptions, Options)
+ int argc;
+ char **argv;
+ int Noptions;
+ struct Option_Struct Options[];
+{
+ for ( ; --argc >= 0; argv++)
+ {
+ char *this;
int n;
+
+ this = *argv;
for (n = 0;
((n < Noptions) && (!strequal(this, Options[n].name)));
- n++) ;
- if (n >= Noptions) return this;
+ n++)
+ {};
+ if (n >= Noptions)
+ {
+ return (this);
+ }
*(Options[n].ptr) = Options[n].value;
}
- return NULL;
+ return (NULL);
}
\f
/* Usage information */
+void
Print_Options(n, options, where)
-int n;
-struct Option_Struct *options;
-FILE *where;
-{ if (--n < 0) return;
+ int n;
+ struct Option_Struct *options;
+ FILE *where;
+{
+ if (--n < 0)
+ {
+ return;
+ }
fprintf(where, "[%s]", options->name);
options += 1;
for (; --n >= 0; options += 1)
+ {
fprintf(where, " [%s]", options->name);
+ }
return;
}
+void
Print_Usage_and_Exit(noptions, options, io_options)
-int noptions;
-struct Option_Struct *options;
-char *io_options;
-{ fprintf(stderr, "usage: %s%s%s",
+ int noptions;
+ struct Option_Struct *options;
+ char *io_options;
+{
+ fprintf(stderr, "usage: %s%s%s",
Program_Name,
(((io_options == NULL) ||
(io_options[0] == '\0')) ? "" : " "),
io_options);
if (noptions != 0)
- { putc(' ', stderr);
+ {
+ putc(' ', stderr);
Print_Options(noptions, options, stderr);
}
putc('\n', stderr);
/* On unix use io redirection */
+void
Setup_Program(argc, argv, Noptions, Options)
-int argc;
-char *argv[];
-int Noptions;
-struct Option_Struct *Options;
-{ extern do_it();
+ int argc;
+ char *argv[];
+ int Noptions;
+ struct Option_Struct *Options;
+{
Program_Name = argv[0];
Input_File = stdin;
Output_File = stdout;
if (((argc - 1) > Noptions) ||
(Find_Options((argc - 1), &argv[1], Noptions, Options) != NULL))
+ {
Print_Usage_and_Exit(Noptions, Options, "");
- do_it();
+ }
return;
}
-#else
+#define quit exit
+\f
+#else /* not unix */
/* Otherwise use command line arguments */
+void
Setup_Program(argc, argv, Noptions, Options)
-int argc;
-char *argv[];
-int Noptions;
-struct Option_Struct *Options;
-{ extern do_it();
+ int argc;
+ char *argv[];
+ int Noptions;
+ struct Option_Struct *Options;
+{
Program_Name = argv[0];
if ((argc < 3) ||
((argc - 3) > Noptions) ||
(Find_Options((argc - 3), &argv[3], Noptions, Options) != NULL))
+ {
Print_Usage_and_Exit(Noptions, Options, "input_file output_file");
+ }
Input_File = ((strequal(argv[1], "-")) ?
stdin :
fopen(argv[1], "r"));
if (Input_File == NULL)
- { perror("Open failed.");
+ {
+ perror("Open failed.");
exit(1);
}
Output_File = ((strequal(argv[2], "-")) ?
stdout :
fopen(argv[2], "w"));
if (Output_File == NULL)
- { perror("Open failed.");
+ {
+ perror("Open failed.");
fclose(Input_File);
exit(1);
}
fprintf(stderr, "%s: Reading from %s, writing to %s.\n",
Program_Name, argv[1], argv[2]);
- do_it();
+ return;
+}
+\f
+void
+quit(code)
+ int code;
+{
fclose(Input_File);
fclose(Output_File);
+ /* VMS brain dammage */
+ if (code != 0)
+ {
+ exit(code);
+ }
return;
}
-#endif
+#endif /* unix */
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/psbtobin.c,v 9.27 1987/09/21 21:55:06 jinx Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/psbtobin.c,v 9.28 1987/11/17 08:05:02 jinx Exp $
*
* This File contains the code to translate portable format binary
* files to internal format.
#include "translate.h"
-static long Dumped_Object_Addr, Dumped_Ext_Prim_Addr;
+static long Dumped_Object_Addr;
static long Dumped_Heap_Base, Heap_Objects, Heap_Count;
static long Dumped_Constant_Base, Constant_Objects, Constant_Count;
static long Dumped_Pure_Base, Pure_Objects, Pure_Count;
+static long Primitive_Table_Length;
+
static Pointer *Heap;
static Pointer *Heap_Base, *Heap_Table, *Heap_Object_Base, *Free;
static Pointer *Constant_Base, *Constant_Table,
*Constant_Object_Base, *Free_Constant;
static Pointer *Pure_Base, *Pure_Table, *Pure_Object_Base, *Free_Pure;
+static Pointer *primitive_table, *primitive_table_end;
static Pointer *Stack_Top;
long
return (fwrite(((char *) From_Where), sizeof(Pointer), Count, Internal_File));
}
+#include "fasl.h"
#include "dump.c"
\f
+void
inconsistency()
{
/* Provide some context (2 lines). */
fgets(&yow[0], 100, Portable_File);
fprintf(stderr, "%s\n", &yow[0]);
- exit(1);
+ quit(1);
+ /*NOTREACHED*/
}
\f
#define OUT(c) return ((long) ((c) & MAX_CHAR))
C = getc(Portable_File);
if (C != '\\')
+ {
OUT(C);
+ }
C = getc(Portable_File);
switch(C)
{
default : OUT(C);
}
}
-
+\f
Pointer *
-read_a_string(To, Slot)
- Pointer *To, *Slot;
+read_a_string_internal(To, maxlen)
+ Pointer *To;
+ long maxlen;
{
- long maxlen, len, Pointer_Count;
+ long ilen, Pointer_Count;
fast char *string;
+ fast long len;
string = ((char *) (&To[STRING_CHARS]));
- *Slot = Make_Pointer(TC_CHARACTER_STRING, To);
- fscanf(Portable_File, "%ld %ld", &maxlen, &len);
+ fscanf(Portable_File, "%ld", &ilen);
+ len = ilen;
+
+ if (maxlen == -1)
+ {
+ maxlen = len;
+ }
/* Null terminated */
+
maxlen += 1;
+
Pointer_Count = STRING_CHARS + char_to_pointer(maxlen);
To[STRING_HEADER] =
Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, (Pointer_Count - 1));
- To[STRING_LENGTH] = Make_Non_Pointer(TC_FIXNUM, len);
+ To[STRING_LENGTH] = ((Pointer) len);
/* Space */
+
getc(Portable_File);
while (--len >= 0)
+ {
*string++ = ((char) read_a_char());
+ }
*string = '\0';
return (To + Pointer_Count);
}
+
+Pointer *
+read_a_string(To, Slot)
+ Pointer *To, *Slot;
+{
+ long maxlen;
+
+ *Slot = Make_Pointer(TC_CHARACTER_STRING, To);
+ fscanf(Portable_File, "%ld", &maxlen);
+ return (read_a_string_internal(To, maxlen));
+}
\f
/*
The following two lines appears by courtesy of your friendly
long digit;
int c;
- while ((c = fgetc(Portable_File)) == ' ') ;
+ while ((c = fgetc(Portable_File)) == ' ')
+ {};
digit = ((c >= 'a') ? (c - 'a' + 10)
: ((c >= 'A') ? (c - 'A' + 10)
: ((c >= '0') ? (c - '0')
: fprintf(stderr, "Losing big: %d\n", c))));
- return digit;
+ return (digit);
}
#endif
}
}
if (negative)
+ {
Value = -Value;
- *Slot = Make_Non_Pointer(TC_FIXNUM, Value);
- return To;
+ }
+ *Slot = MAKE_SIGNED_FIXNUM(Value);
+ return (To);
}
else if (size_in_bits == 0)
{
long Length;
if ((The_Type == TC_FIXNUM) && (!Compact_P))
+ {
fprintf(stderr,
"%s: Fixnum too large, coercing to bignum.\n",
Program_Name);
+ }
size = bits_to_bigdigit(size_in_bits);
ndigits = hex_digits(size_in_bits);
Length = Align(size);
}
}
if (bits_accumulated != 0)
+ {
*(inc_bit_string_ptr(scan)) = accumulator;
+ }
}
*Slot = the_bit_string;
- return To;
+ return (To);
}
\f
/* Underflow and Overflow */
for (expt = MAX_FLONUM_EXPONENT;
expt != 0;
expt >>= 1)
+ {
Result += ldexp(1.0, expt);
+ }
the_max = Result;
return Result;
}
VMS_BUG(size_in_bits = 0);
fscanf(Portable_File, "%ld %ld", &exponent, &size_in_bits);
if (size_in_bits == 0)
+ {
Result = 0.0;
+ }
else if ((exponent > MAX_FLONUM_EXPONENT) ||
(exponent < -MAX_FLONUM_EXPONENT))
{
/* Skip over mantissa */
- while (getc(Portable_File) != '\n') { };
+ while (getc(Portable_File) != '\n')
+ {};
fprintf(stderr,
"%s: Floating point exponent too %s!\n",
Program_Name,
long digit;
if (size_in_bits > FLONUM_MANTISSA_BITS)
+ {
fprintf(stderr,
"%s: Some precision may be lost.",
Program_Name);
+ }
getc(Portable_File); /* Space */
for (ndigits = hex_digits(size_in_bits),
Result = 0.0,
Result = ldexp(Result, ((int) exponent));
}
if (negative)
+ {
Result = -Result;
- return Result;
+ }
+ return (Result);
}
\f
Pointer *
int The_Type;
while (Table < Until)
+ {
+ fscanf(Portable_File, "%2x", &The_Type);
+ switch(The_Type)
{
- fscanf(Portable_File, "%2x", &The_Type);
- switch(The_Type)
- {
- case TC_CHARACTER_STRING:
- To = read_a_string(To, Table++);
- continue;
+ case TC_CHARACTER_STRING:
+ To = read_a_string(To, Table++);
+ continue;
- case TC_BIT_STRING:
- To = read_a_bit_string(To, Table++);
- continue;
+ case TC_BIT_STRING:
+ To = read_a_bit_string(To, Table++);
+ continue;
- case TC_FIXNUM:
- case TC_BIG_FIXNUM:
- To = read_an_integer(The_Type, To, Table++);
- continue;
+ case TC_FIXNUM:
+ case TC_BIG_FIXNUM:
+ To = read_an_integer(The_Type, To, Table++);
+ continue;
- case TC_CHARACTER:
- {
- long the_char_code;
+ case TC_CHARACTER:
+ {
+ long the_char_code;
- getc(Portable_File); /* Space */
- VMS_BUG(the_char_code = 0);
- fscanf( Portable_File, "%3lx", &the_char_code);
- *Table++ = Make_Non_Pointer( TC_CHARACTER, the_char_code);
- continue;
- }
+ getc(Portable_File); /* Space */
+ VMS_BUG(the_char_code = 0);
+ fscanf( Portable_File, "%3lx", &the_char_code);
+ *Table++ = Make_Non_Pointer( TC_CHARACTER, the_char_code);
+ continue;
+ }
\f
- case TC_BIG_FLONUM:
- {
- double The_Flonum = read_a_flonum();
-
- Align_Float(To);
- *Table++ = Make_Pointer(TC_BIG_FLONUM, To);
- *To++ = Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, (float_to_pointer));
- *((double *) To) = The_Flonum;
- To += float_to_pointer;
- continue;
- }
- default:
- fprintf(stderr,
- "%s: Unknown external object found; Type = 0x%02x\n",
- Program_Name, The_Type);
- inconsistency();
- /*NOTREACHED*/
- }
+ case TC_BIG_FLONUM:
+ {
+ double The_Flonum = read_a_flonum();
+
+ Align_Float(To);
+ *Table++ = Make_Pointer(TC_BIG_FLONUM, To);
+ *To++ = Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, (float_to_pointer));
+ *((double *) To) = The_Flonum;
+ To += float_to_pointer;
+ continue;
+ }
+
+ default:
+ fprintf(stderr,
+ "%s: Unknown external object found; Type = 0x%02x\n",
+ Program_Name, The_Type);
+ inconsistency();
+ /*NOTREACHED*/
+ }
}
- return To;
+ return (To);
}
\f
#if false
+void
Move_Memory(From, N, To)
fast Pointer *From, *To;
long N;
Until = &From[N];
while (From < Until)
+ {
*To++ = *From++;
+ }
return;
}
#endif
+void
Relocate_Objects(From, N, disp)
fast Pointer *From;
long N;
inconsistency();
}
}
+ return;
}
\f
-#define Relocate_Into(Where, Addr) \
-if ((Addr) < Dumped_Pure_Base) \
- (Where) = &Heap_Object_Base[(Addr) - Dumped_Heap_Base]; \
-else if ((Addr) < Dumped_Constant_Base) \
- (Where) = &Pure_Base[(Addr) - Dumped_Pure_Base]; \
-else \
- (Where) = &Constant_Base[(Addr) - Dumped_Constant_Base]
+#define Relocate_Into(Where, Addr) \
+{ \
+ if ((Addr) < Dumped_Pure_Base) \
+ { \
+ (Where) = &Heap_Object_Base[(Addr) - Dumped_Heap_Base]; \
+ } \
+ else if ((Addr) < Dumped_Constant_Base) \
+ { \
+ (Where) = &Pure_Base[(Addr) - Dumped_Pure_Base]; \
+ } \
+ else \
+ { \
+ (Where) = &Constant_Base[(Addr) - Dumped_Constant_Base]; \
+ } \
+}
#ifndef Conditional_Bug
-#define Relocate(Addr) \
-(((Addr) < Dumped_Pure_Base) ? \
- &Heap_Object_Base[(Addr) - Dumped_Heap_Base] : \
- (((Addr) < Dumped_Constant_Base) ? \
- &Pure_Base[(Addr) - Dumped_Pure_Base] : \
+#define Relocate(Addr) \
+(((Addr) < Dumped_Pure_Base) ? \
+ &Heap_Object_Base[(Addr) - Dumped_Heap_Base] : \
+ (((Addr) < Dumped_Constant_Base) ? \
+ &Pure_Base[(Addr) - Dumped_Pure_Base] : \
&Constant_Base[(Addr) - Dumped_Constant_Base]))
#else
static Pointer *Relocate_Temp;
-#define Relocate(Addr) \
+#define Relocate(Addr) \
(Relocate_Into(Relocate_Temp, Addr), Relocate_Temp)
#endif
int The_Type;
long The_Datum;
- /* Align_Float(To); */
+#if false
+ Align_Float(To);
+#endif
+
while (--N >= 0)
{
VMS_BUG(The_Type = 0);
continue;
case TC_MANIFEST_NM_VECTOR:
- if (!(Null_NMV)) /* Unknown object! */
+ if (!(Null_NMV))
+ {
+ /* Unknown object! */
fprintf(stderr,
"%s: File is not portable: NMH found\n",
Program_Name);
+ }
*To++ = Make_Non_Pointer(The_Type, The_Datum);
{
fast long count;
fprintf(stderr, "%s: Broken Heart Found\n", Program_Name);
inconsistency();
}
- /* Fall Through */
- case TC_PRIMITIVE_EXTERNAL:
+ /* fall through */
+
+ case TC_PCOMB0:
+ case TC_PRIMITIVE:
case TC_MANIFEST_SPECIAL_NM_VECTOR:
case_simple_Non_Pointer:
*To++ = Make_Non_Pointer(The_Type, The_Datum);
continue;
}
/* It is a pointer, fall through. */
+
default:
/* Should be stricter */
*To++ = Make_Pointer(The_Type, Relocate(The_Datum));
continue;
}
}
- /* Align_Float(To); */
- return To;
+#if false
+ Align_Float(To);
+#endif
+ return (To);
+}
+\f
+static Boolean primitive_warn = false;
+
+Pointer *
+read_primitives(how_many, where)
+ fast long how_many;
+ fast Pointer *where;
+{
+ long arity;
+
+ while (--how_many >= 0)
+ {
+ fscanf(Portable_File, "%ld", &arity);
+ if (arity == ((long) UNKNOWN_PRIMITIVE_ARITY))
+ {
+ primitive_warn = true;
+ }
+ *where++ = MAKE_SIGNED_FIXNUM(arity);
+ where = read_a_string_internal(where, ((long) -1));
+ }
+ return (where);
}
\f
#ifdef DEBUG
-Print_External_Objects(area_name, Table, N)
+void
+print_external_objects(area_name, Table, N)
char *area_name;
fast Pointer *Table;
fast long N;
fprintf(stderr, "Table = 0x%x; N = %d\n", Table, N);
for( ; Table < Table_End; Table++)
+ {
switch (Type_Code(*Table))
{
case TC_FIXNUM:
(N - (Table_End - Table)),
*Table);
break;
- }
+ }
+ }
+ return;
+}
+
+#define DEBUGGING(action) action
+
+#define WHEN(condition, message) when(condition, message)
+
+void
+when(what, message)
+ Boolean what;
+ char *message;
+{
+ if (what)
+ {
+ fprintf(stderr, "%s: Inconsistency: %s!\n",
+ Program_Name, (message));
+ quit(1);
+ }
+ return;
+}
+
+#define READ_HEADER(string, format, value) \
+{ \
+ fscanf(Input_File, format, value); \
+ fprintf(stderr, "%s: ", (string)); \
+ fprintf(stderr, (format), (*(value))); \
+ fprintf(stderr, "\n"); \
}
-#endif
+\f
+#else /* not DEBUG */
+
+#define DEBUGGING(action)
+
+#define WHEN(what, message)
+
+#define READ_HEADER(string, format, value) \
+{ \
+ fscanf(Input_File, format, value); \
+}
+
+#endif /* DEBUG */
\f
long
Read_Header_and_Allocate()
{
long Portable_Version, Flags, Version, Sub_Version;
- long NFlonums, NIntegers, NBits, NBitstrs, NBBits, NStrings, NChars;
+ long NFlonums, NIntegers, NBits, NBitstrs, NBBits, NStrings, NChars, NPChars;
long Size;
/* Read Header */
- fscanf(Input_File, "%ld %ld %ld %ld",
- &Portable_Version, &Flags, &Version, &Sub_Version);
-
- fscanf(Input_File, "%ld %ld %ld",
- &Heap_Count, &Dumped_Heap_Base, &Heap_Objects);
-
- fscanf(Input_File, "%ld %ld %ld",
- &Constant_Count, &Dumped_Constant_Base, &Constant_Objects);
-
- fscanf(Input_File, "%ld %ld %ld",
- &Pure_Count, &Dumped_Pure_Base, &Pure_Objects);
-
- fscanf(Input_File, "%ld %ld",
- &Dumped_Object_Addr, &Dumped_Ext_Prim_Addr);
-
- fscanf(Input_File, "%ld %ld %ld %ld %ld %ld %ld",
- &NFlonums,
- &NIntegers, &NBits,
- &NBitstrs, &NBBits,
- &NStrings, &NChars);
+ READ_HEADER("Portable Version", "%ld", &Portable_Version);
+ READ_HEADER("Flags", "%ld", &Flags);
+ READ_HEADER("Version", "%ld", &Version);
+ READ_HEADER("Sub Version", "%ld", &Sub_Version);
if ((Portable_Version != PORTABLE_VERSION) ||
(Version != FASL_FORMAT_VERSION) ||
(Sub_Version != FASL_SUBVERSION))
{
fprintf(stderr,
- "FASL File Version %4d Subversion %4d Portable Version %4d\n",
+ "Portable File Version %4d Subversion %4d Portable Version %4d\n",
Version, Sub_Version, Portable_Version);
fprintf(stderr,
- "Expected: Version %4d Subversion %4d Portable Version %4d\n",
+ "Expected: Version %4d Subversion %4d Portable Version %4d\n",
FASL_FORMAT_VERSION, FASL_SUBVERSION, PORTABLE_VERSION);
- exit(1);
+ quit(1);
}
Read_Flags(Flags);
+ READ_HEADER("Heap Count", "%ld", &Heap_Count);
+ READ_HEADER("Dumped Heap Base", "%ld", &Dumped_Heap_Base);
+ READ_HEADER("Heap Objects", "%ld", &Heap_Objects);
+
+ READ_HEADER("Constant Count", "%ld", &Constant_Count);
+ READ_HEADER("Dumped Constant Base", "%ld", &Dumped_Constant_Base);
+ READ_HEADER("Constant Objects", "%ld", &Constant_Objects);
+
+ READ_HEADER("Pure Count", "%ld", &Pure_Count);
+ READ_HEADER("Dumped Pure Base", "%ld", &Dumped_Pure_Base);
+ READ_HEADER("Pure Objects", "%ld", &Pure_Objects);
+
+ READ_HEADER("& Dumped Object", "%ld", &Dumped_Object_Addr);
+
+ READ_HEADER("Number of flonums", "%ld", &NFlonums);
+ READ_HEADER("Number of integers", "%ld", &NIntegers);
+ READ_HEADER("Number of bits in integers", "%ld", &NBits);
+ READ_HEADER("Number of bit strings", "%ld", &NBitstrs);
+ READ_HEADER("Number of bits in bit strings", "%ld", &NBBits);
+ READ_HEADER("Number of character strings", "%ld", &NStrings);
+ READ_HEADER("Number of characters in strings", "%ld", &NChars);
+
+ READ_HEADER("Primitive Table Length", "%ld", &Primitive_Table_Length);
+ READ_HEADER("Number of characters in primitives", "%ld", &NPChars);
+
Size = (6 + /* SNMV */
HEAP_BUFFER_SPACE +
Heap_Count + Heap_Objects +
((NStrings * (1 + STRING_CHARS)) +
(char_to_pointer(NChars))) +
((NBitstrs * (1 + BIT_STRING_FIRST_WORD)) +
- (bits_to_pointers(NBBits))));
+ (bits_to_pointers(NBBits))) +
+ ((Primitive_Table_Length * (2 + STRING_CHARS)) +
+ (char_to_pointer(NPChars))));
Allocate_Heap_Space(Size);
if (Heap == NULL)
fprintf(stderr,
"%s: Memory Allocation Failed. Size = %ld Scheme Pointers\n",
Program_Name, Size);
- exit(1);
+ quit(1);
}
Heap += HEAP_BUFFER_SPACE;
Initial_Align_Float(Heap);
return (Size - HEAP_BUFFER_SPACE);
}
\f
+void
do_it()
{
+ Pointer *primitive_table_end;
Boolean result;
long Size;
Size = Read_Header_and_Allocate();
+
Stack_Top = &Heap[Size];
+
Heap_Table = &Heap[0];
Heap_Base = &Heap_Table[Heap_Objects];
Heap_Object_Base =
Read_External(Heap_Objects, Heap_Table, Heap_Base);
+ /* The various 2s below are for SNMV headers. */
+
Pure_Table = &Heap_Object_Base[Heap_Count];
- Pure_Base = &Pure_Table[Pure_Objects + 2]; /* SNMV */
+ Pure_Base = &Pure_Table[Pure_Objects + 2];
Pure_Object_Base =
Read_External(Pure_Objects, Pure_Table, Pure_Base);
Constant_Table = &Heap[Size - Constant_Objects];
- Constant_Base = &Pure_Object_Base[Pure_Count + 2]; /* SNMV */
+ Constant_Base = &Pure_Object_Base[Pure_Count + 2];
Constant_Object_Base =
Read_External(Constant_Objects, Constant_Table, Constant_Base);
-#ifdef DEBUG
- Print_External_Objects("Heap", Heap_Table, Heap_Objects);
- Print_External_Objects("Pure", Pure_Table, Pure_Objects);
- Print_External_Objects("Constant", Constant_Table, Constant_Objects);
-#endif
+ primitive_table = &Constant_Object_Base[Constant_Count + 2];
+
+ WHEN((primitive_table > Constant_Table),
+ "primitive_table overran Constant_Table");
+
+ DEBUGGING(print_external_objects("Heap", Heap_Table, Heap_Objects));
+ DEBUGGING(print_external_objects("Pure", Pure_Table, Pure_Objects));
+ DEBUGGING(print_external_objects("Constant",
+ Constant_Table,
+ Constant_Objects));
\f
/* Read the normal objects */
Free =
Read_Pointers_and_Relocate(Heap_Count, Heap_Object_Base);
+
+ WHEN((Free > Pure_Table),
+ "Free overran Pure_Table");
+ WHEN((Free < Pure_Table),
+ "Free did not reach Pure_Table");
+
Free_Pure =
Read_Pointers_and_Relocate(Pure_Count, Pure_Object_Base);
+
+ WHEN((Free_Pure > (Constant_Base - 2)),
+ "Free_Pure overran Constant_Base");
+ WHEN((Free_Pure < (Constant_Base - 2)),
+ "Free_Pure did not reach Constant_Base");
+
Free_Constant =
Read_Pointers_and_Relocate(Constant_Count, Constant_Object_Base);
+ WHEN((Free_Constant > (primitive_table - 2)),
+ "Free_Constant overran primitive_table");
+ WHEN((Free_Constant < (primitive_table - 2)),
+ "Free_Constant did not reach primitive_table");
+
+ primitive_table_end =
+ read_primitives(Primitive_Table_Length, primitive_table);
+
+ /*
+ primitive_table_end can be well below Constant_Table, since
+ the memory allocation is conservative (it rounds up), and all
+ the slack ends up between them.
+ */
+
+ WHEN((primitive_table_end > Constant_Table),
+ "primitive_table_end overran Constant_Table");
+
+ if (primitive_warn)
+ {
+ fprintf(stderr, "%s:\n", Program_Name);
+ fprintf(stderr,
+ "NOTE: The binary file contains primitives with unknown arity.\n");
+ }
+\f
/* Dump the objects */
{
- Pointer *Dumped_Object, *Dumped_Ext_Prim;
+ Pointer *Dumped_Object;
Relocate_Into(Dumped_Object, Dumped_Object_Addr);
- Relocate_Into(Dumped_Ext_Prim, Dumped_Ext_Prim_Addr);
-
-#ifdef DEBUG
- fprintf(stderr, "Dumping:\n");
- fprintf(stderr,
- "Heap = 0x%x; Heap Count = %d\n",
- Heap_Base, (Free - Heap_Base));
- fprintf(stderr,
- "Pure Space = 0x%x; Pure Count = %d\n",
- Pure_Base, (Free_Pure - Pure_Base));
- fprintf(stderr,
- "Constant Space = 0x%x; Constant Count = %d\n",
- Constant_Base, (Free_Constant - Constant_Base));
- fprintf(stderr,
- "& Dumped Object = 0x%x; Dumped Object = 0x%x\n",
- Dumped_Object, *Dumped_Object);
- fprintf(stderr,
- "& Dumped Ext Prim = 0x%x; Dumped Ext Prim = 0x%x\n",
- Dumped_Ext_Prim, *Dumped_Ext_Prim);
-#endif
+ DEBUGGING(fprintf(stderr, "Dumping:\n"));
+ DEBUGGING(fprintf(stderr,
+ "Heap = 0x%x; Heap Count = %d\n",
+ Heap_Base, (Free - Heap_Base)));
+ DEBUGGING(fprintf(stderr,
+ "Pure Space = 0x%x; Pure Count = %d\n",
+ Pure_Base, (Free_Pure - Pure_Base)));
+ DEBUGGING(fprintf(stderr,
+ "Constant Space = 0x%x; Constant Count = %d\n",
+ Constant_Base, (Free_Constant - Constant_Base)));
+ DEBUGGING(fprintf(stderr,
+ "& Dumped Object = 0x%x; Dumped Object = 0x%x\n",
+ Dumped_Object, *Dumped_Object));
+ DEBUGGING(fprintf(stderr, "Primitive_Table_Length = %ld; ",
+ Primitive_Table_Length));
+ DEBUGGING(fprintf(stderr, "Primitive_Table_Size = %ld\n",
+ (primitive_table_end - primitive_table)));
+\f
/* Is there a Pure/Constant block? */
if ((Constant_Objects == 0) && (Constant_Count == 0) &&
(Pure_Objects == 0) && (Pure_Count == 0))
- result = Write_File((Free - Heap_Base), Heap_Base, Dumped_Object,
- 0, &Heap[Size], Dumped_Ext_Prim);
+ {
+ result = Write_File(Dumped_Object,
+ (Free - Heap_Base), Heap_Base,
+ 0, Stack_Top,
+ primitive_table, Primitive_Table_Length,
+ ((long) (primitive_table_end - primitive_table)));
+ }
else
{
long Pure_Length, Total_Length;
Free_Constant[1] =
Make_Non_Pointer(END_OF_BLOCK, Total_Length);
- result = Write_File((Free - Heap_Base), Heap_Base, Dumped_Object,
- Total_Length, (Pure_Base - 2), Dumped_Ext_Prim);
+ result = Write_File(Dumped_Object,
+ (Free - Heap_Base), Heap_Base,
+ Total_Length, (Pure_Base - 2),
+ primitive_table, Primitive_Table_Length,
+ ((long) (primitive_table_end - primitive_table)));
}
}
if (!result)
{
- fprintf(stderr, "Error writing the output file.\n");
- exit(1);
+ fprintf(stderr, "%s: Error writing the output file.\n", Program_Name);
+ quit(1);
}
return;
}
/* Top level */
static int Noptions = 0;
+
/* C does not usually like empty initialized arrays, so ... */
+
static struct Option_Struct Options[] = {{"dummy", true, NULL}};
main(argc, argv)
char *argv[];
{
Setup_Program(argc, argv, Noptions, Options);
- return;
+ do_it();
+ quit(0);
}
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/types.h,v 9.25 1987/10/09 16:14:39 jinx Rel $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/types.h,v 9.26 1987/11/17 08:18:54 jinx Rel $
*
* Type code definitions, numerical order
*
#define TC_COMPILED_PROCEDURE 0x0D
#define TC_BIG_FIXNUM 0x0E
#define TC_PROCEDURE 0x0F
-#define TC_PRIMITIVE_EXTERNAL 0x10
+/* 0x10 used to be TC_PRIMITIVE_EXTERNAL */
+/* if it is reused, define PRIMITIVE_EXTERNAL_REUSED below. */
+/* Unused 0x10 */
#define TC_DELAY 0x11
#define TC_ENVIRONMENT 0x12
#define TC_DELAYED 0x13
/* If you add a new type, don't forget to update gccode.h and gctype.c */
+/* Remove #if false and #endif if type code 0x10 is reused. */
+
+#if false
+#define PRIMITIVE_EXTERNAL_REUSED
+#endif
+
/* Aliases */
#define TC_FALSE TC_NULL
;;;; Machine Dependent Type Tables
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/utabmd.scm,v 9.38 1987/10/09 16:14:47 jinx Rel $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/utabmd.scm,v 9.39 1987/11/17 08:19:44 jinx Exp $
(declare (usual-integrations))
;;; [] Fixed
;;; [] Types
;;; [] Returns
-;;; [] Primitives
-;;; [] External
;;; [] Errors
;;; [] Identification
\f
OBARRAY ;03
MICROCODE-TYPES-VECTOR ;04
MICROCODE-RETURNS-VECTOR ;05
- MICROCODE-PRIMITIVES-VECTOR ;06
+ #F ;06
MICROCODE-ERRORS-VECTOR ;07
MICROCODE-IDENTIFICATION-VECTOR ;08
#F ;09
#F ;0D
STEPPER-STATE ;0E
MICROCODE-FIXED-OBJECTS-SLOTS ;0F
- MICROCODE-EXTERNAL-PRIMITIVES ;10
+ #F ;10
STATE-SPACE-TAG ;11
STATE-POINT-TAG ;12
DUMMY-HISTORY ;13
COMPILED-PROCEDURE ;0D
(BIGNUM BIG-FIXNUM) ;0E
PROCEDURE ;0F
- PRIMITIVE-EXTERNAL ;10
+ #F ;10
DELAY ;11
ENVIRONMENT ;12
DELAYED ;13
COMPILER-CACHE-ASSIGNMENT-RESTART ;5A
))
\f
-;;; [] Primitives
-
-(vector-set! (get-fixed-objects-vector)
- 6 ;(fixed-objects-vector-slot 'MICROCODE-PRIMITIVES-VECTOR)
- #(LEXICAL-ASSIGNMENT ;$00
- LOCAL-REFERENCE ;$01
- LOCAL-ASSIGNMENT ;$02
- CALL-WITH-CURRENT-CONTINUATION ;$03
- SCODE-EVAL ;$04
- APPLY ;$05
- SET-INTERRUPT-ENABLES! ;$06
- STRING->SYMBOL ;$07
- GET-WORK ;$08
- NON-REENTRANT-CALL-WITH-CURRENT-CONTINUATION ;$09
- CURRENT-DYNAMIC-STATE ;$0A
- SET-CURRENT-DYNAMIC-STATE! ;$0B
- (NULL? NOT FALSE?) ;$0C
- EQ? ;$0D
- STRING-EQUAL? ;$0E
- PRIMITIVE-TYPE? ;$0F
- PRIMITIVE-TYPE ;$10
- PRIMITIVE-SET-TYPE ;$11
- LEXICAL-REFERENCE ;$12
- LEXICAL-UNREFERENCEABLE? ;$13
- MAKE-CHAR ;$14
- CHAR-BITS ;$15
- EXIT ;$16
- CHAR-CODE ;$17
- LEXICAL-UNASSIGNED? ;$18
- INSERT-NON-MARKED-VECTOR! ;$19
- HALT ;$1A
- CHAR->INTEGER ;$1B
- MEMQ ;$1C
- INSERT-STRING ;$1D
- ENABLE-INTERRUPTS! ;$1E
- MAKE-EMPTY-STRING ;$1F
- CONS ;$20
- (CAR FIRST) ;$21
- (CDR FIRST-TAIL) ;$22
- (SET-CAR! SET-FIRST!) ;$23
- (SET-CDR! SET-FIRST-TAIL!) ;$24
- GET-COMMAND-LINE ;$25
- TTY-GET-CURSOR ;$26
- GENERAL-CAR-CDR ;$27
- HUNK3-CONS ;$28
- HUNK3-CXR ;$29
- HUNK3-SET-CXR! ;$2A
- INSERT-STRING! ;$2B
- VECTOR-CONS ;$2C
- (VECTOR-LENGTH VECTOR-SIZE) ;$2D
- VECTOR-REF ;$2E
- SET-CURRENT-HISTORY! ;$2F
- VECTOR-SET! ;$30
- NON-MARKED-VECTOR-CONS ;$31
- #F ;$32
- LEXICAL-UNBOUND? ;$33
- INTEGER->CHAR ;$34
- CHAR-DOWNCASE ;$35
- CHAR-UPCASE ;$36
- ASCII->CHAR ;$37
- CHAR-ASCII? ;$38
- CHAR->ASCII ;$39
- GARBAGE-COLLECT ;$3A
- PLUS-FIXNUM ;$3B
- MINUS-FIXNUM ;$3C
- MULTIPLY-FIXNUM ;$3D
- DIVIDE-FIXNUM ;$3E
- EQUAL-FIXNUM? ;$3F
- LESS-THAN-FIXNUM? ;$40
- POSITIVE-FIXNUM? ;$41
- ONE-PLUS-FIXNUM ;$42
- MINUS-ONE-PLUS-FIXNUM ;$43
- TRUNCATE-STRING! ;$44
- SUBSTRING ;$45
- ZERO-FIXNUM? ;$46
- #F ;$47
- #F ;$48
- #F ;$49
- SUBSTRING->LIST ;$4A
- MAKE-FILLED-STRING ;$4B
- PLUS-BIGNUM ;$4C
- MINUS-BIGNUM ;$4D
- MULTIPLY-BIGNUM ;$4E
- DIVIDE-BIGNUM ;$4F
- LISTIFY-BIGNUM ;$50
- EQUAL-BIGNUM? ;$51
- LESS-THAN-BIGNUM? ;$52
- POSITIVE-BIGNUM? ;$53
- FILE-OPEN-CHANNEL ;$54
- FILE-CLOSE-CHANNEL ;$55
- PRIMITIVE-FASDUMP ;$56
- BINARY-FASLOAD ;$57
- STRING-POSITION ;$58
- STRING-LESS? ;$59
- #F ;$5A
- #F ;$5B
- REHASH ;$5C
- LENGTH ;$5D
- ASSQ ;$5E
- LIST->STRING ;$5F
- EQUAL-STRING-TO-LIST? ;$60
- MAKE-CELL ;$61
- CELL-CONTENTS ;$62
- CELL? ;$63
- CHARACTER-UPCASE ;$64
- CHARACTER-LIST-HASH ;$65
- GCD-FIXNUM ;$66
- COERCE-FIXNUM-TO-BIGNUM ;$67
- COERCE-BIGNUM-TO-FIXNUM ;$68
- PLUS-FLONUM ;$69
- MINUS-FLONUM ;$6A
- MULTIPLY-FLONUM ;$6B
- DIVIDE-FLONUM ;$6C
- EQUAL-FLONUM? ;$6D
- LESS-THAN-FLONUM? ;$6E
- ZERO-BIGNUM? ;$6F
- TRUNCATE-FLONUM ;$70
- ROUND-FLONUM ;$71
- COERCE-INTEGER-TO-FLONUM ;$72
- SINE-FLONUM ;$73
- COSINE-FLONUM ;$74
- ARCTAN-FLONUM ;$75
- EXP-FLONUM ;$76
- LN-FLONUM ;$77
- SQRT-FLONUM ;$78
- #F #| PRIMITIVE-FASLOAD |# ;$79
- GET-FIXED-OBJECTS-VECTOR ;$7A
- SET-FIXED-OBJECTS-VECTOR! ;$7B
- LIST->VECTOR ;$7C
- SUBVECTOR->LIST ;$7D
- PAIR? ;$7E
- NEGATIVE-FIXNUM? ;$7F
- NEGATIVE-BIGNUM? ;$80
- GREATER-THAN-FIXNUM? ;$81
- GREATER-THAN-BIGNUM? ;$82
- STRING-HASH ;$83
- SYSTEM-PAIR-CONS ;$84
- SYSTEM-PAIR? ;$85
- SYSTEM-PAIR-CAR ;$86
- SYSTEM-PAIR-CDR ;$87
- SYSTEM-PAIR-SET-CAR! ;$88
- SYSTEM-PAIR-SET-CDR! ;$89
- STRING-HASH-MOD ;$8A
- #F ;$8B
- SET-CELL-CONTENTS! ;$8C
- &MAKE-OBJECT ;$8D
- SYSTEM-HUNK3-CXR0 ;$8E
- SYSTEM-HUNK3-SET-CXR0! ;$8F
- MAP-MACHINE-ADDRESS-TO-CODE ;$90
- SYSTEM-HUNK3-CXR1 ;$91
- SYSTEM-HUNK3-SET-CXR1! ;$92
- MAP-CODE-TO-MACHINE-ADDRESS ;$93
- SYSTEM-HUNK3-CXR2 ;$94
- SYSTEM-HUNK3-SET-CXR2! ;$95
- PRIMITIVE-PROCEDURE-ARITY ;$96
- SYSTEM-LIST-TO-VECTOR ;$97
- SYSTEM-SUBVECTOR-TO-LIST ;$98
- SYSTEM-VECTOR? ;$99
- SYSTEM-VECTOR-REF ;$9A
- SYSTEM-VECTOR-SET! ;$9B
- WITH-HISTORY-DISABLED ;$9C
- SUBVECTOR-MOVE-RIGHT! ;$9D
- SUBVECTOR-MOVE-LEFT! ;$9E
- SUBVECTOR-FILL! ;$9F
- #F ;$A0
- #F ;$A1
- #F ;$A2
- VECTOR-8B-CONS ;$A3
- VECTOR-8B? ;$A4
- VECTOR-8B-REF ;$A5
- VECTOR-8B-SET! ;$A6
- ZERO-FLONUM? ;$A7
- POSITIVE-FLONUM? ;$A8
- NEGATIVE-FLONUM? ;$A9
- GREATER-THAN-FLONUM? ;$AA
- INTERN-CHARACTER-LIST ;$AB
- COMPILED-CODE-ADDRESS->OFFSET ;$AC
- (STRING-SIZE VECTOR-8B-SIZE) ;$AD
- SYSTEM-VECTOR-SIZE ;$AE
- FORCE ;$AF
- PRIMITIVE-DATUM ;$B0
- MAKE-NON-POINTER-OBJECT ;$B1
- DEBUGGING-PRINTER ;$B2
- STRING-UPCASE ;$B3
- PRIMITIVE-PURIFY ;$B4
- COMPILED-CODE-ADDRESS->BLOCK ;$B5
- #F #| COMPLETE-GARBAGE-COLLECT |# ;$B6
- DUMP-BAND ;$B7
- SUBSTRING-SEARCH ;$B8
- LOAD-BAND ;$B9
- CONSTANT? ;$BA
- PURE? ;$BB
- PRIMITIVE-GC-TYPE ;$BC
- PRIMITIVE-IMPURIFY ;$BD
- WITH-THREADED-CONTINUATION ;$BE
- WITHIN-CONTROL-POINT ;$BF
- SET-RUN-LIGHT! ;$C0
- FILE-EOF? ;$C1
- FILE-READ-CHAR ;$C2
- FILE-FILL-INPUT-BUFFER ;$C3
- FILE-LENGTH ;$C4
- FILE-WRITE-CHAR ;$C5
- FILE-WRITE-STRING ;$C6
- CLOSE-LOST-OPEN-FILES ;$C7
- #F ;$C8
- WITH-INTERRUPTS-REDUCED ;$C9
- PRIMITIVE-EVAL-STEP ;$CA
- PRIMITIVE-APPLY-STEP ;$CB
- PRIMITIVE-RETURN-STEP ;$CC
- TTY-READ-CHAR-READY? ;$CD
- TTY-READ-CHAR ;$CE
- TTY-READ-CHAR-IMMEDIATE ;$CF
- TTY-READ-FINISH ;$D0
- BIT-STRING-ALLOCATE ;$D1
- MAKE-BIT-STRING ;$D2
- BIT-STRING? ;$D3
- BIT-STRING-LENGTH ;$D4
- BIT-STRING-REF ;$D5
- BIT-SUBSTRING-MOVE-RIGHT! ;$D6
- BIT-STRING-SET! ;$D7
- BIT-STRING-CLEAR! ;$D8
- BIT-STRING-ZERO? ;$D9
- BIT-SUBSTRING-FIND-NEXT-SET-BIT ;$DA
- #F ;$DB
- UNSIGNED-INTEGER->BIT-STRING ;$DC
- BIT-STRING->UNSIGNED-INTEGER ;$DD
- #F ;$DE
- READ-BITS! ;$DF
- WRITE-BITS! ;$E0
- MAKE-STATE-SPACE ;$E1
- EXECUTE-AT-NEW-STATE-POINT ;$E2
- TRANSLATE-TO-STATE-POINT ;$E3
- GET-NEXT-CONSTANT ;$E4
- MICROCODE-IDENTIFY ;$E5
- ZERO? ;$E6
- POSITIVE? ;$E7
- NEGATIVE? ;$E8
- &= ;$E9
- &< ;$EA
- &> ;$EB
- &+ ;$EC
- &- ;$ED
- &* ;$EE
- &/ ;$EF
- INTEGER-DIVIDE ;$F0
- 1+ ;$F1
- -1+ ;$F2
- TRUNCATE ;$F3
- ROUND ;$F4
- FLOOR ;$F5
- CEILING ;$F6
- SQRT ;$F7
- EXP ;$F8
- LOG ;$F9
- SIN ;$FA
- COS ;$FB
- &ATAN ;$FC
- TTY-WRITE-CHAR ;$FD
- TTY-WRITE-STRING ;$FE
- TTY-BEEP ;$FF
- TTY-CLEAR ;$100
- GET-EXTERNAL-COUNTS ;$101
- GET-EXTERNAL-NAME ;$102
- GET-EXTERNAL-NUMBER ;$103
- #F ;$104
- #F ;$105
- GET-NEXT-INTERRUPT-CHARACTER ;$106
- CHECK-AND-CLEAN-UP-INPUT-CHANNEL ;$107
- #F ;$108
- SYSTEM-CLOCK ;$109
- FILE-EXISTS? ;$10A
- #F ;$10B
- TTY-MOVE-CURSOR ;$10C
- #F ;$10D
- #F #| CURRENT-DATE |# ;$10E
- #F #| CURRENT-TIME |# ;$10F
- #F #| TRANSLATE-FILE |# ;$110
- COPY-FILE ;$111
- RENAME-FILE ;$112
- REMOVE-FILE ;$113
- LINK-FILE ;$114
- MAKE-DIRECTORY ;$115
- #F #| VOLUME-NAME |# ;$116
- SET-WORKING-DIRECTORY-PATHNAME! ;$117
- RE-MATCH-SUBSTRING ;$118
- RE-SEARCH-SUBSTRING-FORWARD ;$119
- RE-SEARCH-SUBSTRING-BACKWARD ;$11A
- #F ;$11B
- #F ;$11C
- #F ;$11D
- #F ;$11E
- #F ;$11F
- #F ;$120
- #F ;$121
- #F ;$122
- #F ;$123
- #F ;$124
- #F ;$125
- CURRENT-YEAR ;$126
- CURRENT-MONTH ;$127
- CURRENT-DAY ;$128
- CURRENT-HOUR ;$129
- CURRENT-MINUTE ;$12A
- CURRENT-SECOND ;$12B
- #F #| INIT-FLOPPY |# ;$12C
- #F #| ZERO-FLOPPY |# ;$12D
- #F #| PACK-VOLUME |# ;$12E
- #F #| LOAD-PICTURE |# ;$12F
- #F #| STORE-PICTURE |# ;$130
- #F #| LOOKUP-SYSTEM-SYMBOL |# ;$131
- #F ;$132
- #F ;$133
- CLEAR-TO-END-OF-LINE ;$134
- #F ;$135
- #F ;$136
- WITH-INTERRUPT-MASK ;$137
- STRING? ;$138
- STRING-LENGTH ;$139
- STRING-REF ;$13A
- STRING-SET! ;$13B
- SUBSTRING-MOVE-RIGHT! ;$13C
- SUBSTRING-MOVE-LEFT! ;$13D
- STRING-ALLOCATE ;$13E
- STRING-MAXIMUM-LENGTH ;$13F
- SET-STRING-LENGTH! ;$140
- VECTOR-8B-FILL! ;$141
- VECTOR-8B-FIND-NEXT-CHAR ;$142
- VECTOR-8B-FIND-PREVIOUS-CHAR ;$143
- VECTOR-8B-FIND-NEXT-CHAR-CI ;$144
- VECTOR-8B-FIND-PREVIOUS-CHAR-CI ;$145
- SUBSTRING-FIND-NEXT-CHAR-IN-SET ;$146
- SUBSTRING-FIND-PREVIOUS-CHAR-IN-SET ;$147
- SUBSTRING=? ;$148
- SUBSTRING-CI=? ;$149
- SUBSTRING<? ;$14A
- SUBSTRING-UPCASE! ;$14B
- SUBSTRING-DOWNCASE! ;$14C
- SUBSTRING-MATCH-FORWARD ;$14D
- SUBSTRING-MATCH-BACKWARD ;$14E
- SUBSTRING-MATCH-FORWARD-CI ;$14F
- SUBSTRING-MATCH-BACKWARD-CI ;$150
- PHOTO-OPEN ;$151
- PHOTO-CLOSE ;$152
- SETUP-TIMER-INTERRUPT ;$153
- #F ;$154
- #F ;$155
- #F ;$156
- #F ;$157
- #F ;$158
- #F ;$159
- #F ;$15A
- #F ;$15B
- #F ;$15C
- #F ;$15D
- #F ;$15E
- #F ;$15F
- #F ;$160
- #F #| EXTRACT-NON-MARKED-VECTOR |# ;$161
- #F #| UNSNAP-LINKS! |# ;$162
- #F #| SAFE-PRIMITIVE? |# ;$163
- #F #| SUBSTRING-READ |# ;$164
- #F #| SUBSTRING-WRITE |# ;$165
- SCREEN-X-SIZE ;$166
- SCREEN-Y-SIZE ;$167
- #F #| SCREEN-WRITE-CURSOR |# ;$168
- #F #| SCREEN-WRITE-CHARACTER |# ;$169
- #F #| SCREEN-WRITE-SUBSTRING |# ;$16A
- #F #| NEXT-FILE-MATCHING |# ;$16B
- #F ;$16C
- #F #| TTY-WRITE-BYTE |# ;$16D
- #F #| FILE-READ-BYTE |# ;$16E
- #F #| FILE-WRITE-BYTE |# ;$16F
- #F #| SAVE-SCREEN |# ;$170
- #F #| RESTORE-SCREEN! |# ;$171
- #F #| SUBSCREEN-CLEAR! |# ;$172
- #F #| &GCD |# ;$173
- #F #| TTY-REDRAW-SCREEN |# ;$174
- #F #| SCREEN-INVERSE-VIDEO! |# ;$175
- STRING->SYNTAX-ENTRY ;$176
- SCAN-WORD-FORWARD ;$177
- SCAN-WORD-BACKWARD ;$178
- SCAN-LIST-FORWARD ;$179
- SCAN-LIST-BACKWARD ;$17A
- SCAN-SEXPS-FORWARD ;$17B
- SCAN-FORWARD-TO-WORD ;$17C
- SCAN-BACKWARD-PREFIX-CHARS ;$17D
- CHAR->SYNTAX-CODE ;$17E
- QUOTED-CHAR? ;$17F
- MICROCODE-TABLES-FILENAME ;$180
- #F ;$181
- #F #| FIND-PASCAL-PROGRAM |# ;$182
- #F #| EXECUTE-PASCAL-PROGRAM |# ;$183
- #F #| GRAPHICS-MOVE |# ;$184
- #F #| GRAPHICS-LINE |# ;$185
- #F #| GRAPHICS-PIXEL |# ;$186
- #F #| GRAPHICS-SET-DRAWING-MODE |# ;$187
- #F #| ALPHA-RASTER? |# ;$188
- #F #| TOGGLE-ALPHA-RASTER |# ;$189
- #F #| GRAPHICS-RASTER? |# ;$18A
- #F #| TOGGLE-GRAPHICS-RASTER |# ;$18B
- #F #| GRAPHICS-CLEAR |# ;$18C
- #F #| GRAPHICS-SET-LINE-STYLE |# ;$18D
- ERROR-PROCEDURE ;$18E
- BIT-STRING-XOR! ;$18F
- RE-CHAR-SET-ADJOIN! ;$190
- RE-COMPILE-FASTMAP ;$191
- RE-MATCH-BUFFER ;$192
- RE-SEARCH-BUFFER-FORWARD ;$193
- RE-SEARCH-BUFFER-BACKWARD ;$194
- (SYSTEM-MEMORY-REF &OBJECT-REF) ;$195
- (SYSTEM-MEMORY-SET! &OBJECT-SET!) ;$196
- BIT-STRING-FILL! ;$197
- BIT-STRING-MOVE! ;$198
- BIT-STRING-MOVEC! ;$199
- BIT-STRING-OR! ;$19A
- BIT-STRING-AND! ;$19B
- BIT-STRING-ANDC! ;$19C
- BIT-STRING=? ;$19D
- WORKING-DIRECTORY-PATHNAME ;$19E
- OPEN-DIRECTORY ;$19F
- DIRECTORY-READ ;$1A0
- UNDER-EMACS? ;$1A1
- TTY-FLUSH-OUTPUT ;$1A2
- RELOAD-BAND-NAME ;$1A3
- ))
-\f
-;;; [] External
-
-(vector-set! (get-fixed-objects-vector)
- 16 ;(fixed-objects-vector-slot 'MICROCODE-EXTERNAL-PRIMITIVES)
- #())
-\f
;;; [] Errors
(vector-set! (get-fixed-objects-vector)
COMPILED-CODE-ERROR ;31
FLOATING-OVERFLOW ;32
UNIMPLEMENTED-PRIMITIVE ;33
+ ILLEGAL-REFERENCE-TRAP ;34
+ BROKEN-VARIABLE-CACHE ;35
+ WRONG-ARITY-PRIMITIVES ;36
+ IO-ERROR ;37
))
\f
;;; [] Terminations
;;; This identification string is saved by the system.
-"$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/utabmd.scm,v 9.38 1987/10/09 16:14:47 jinx Rel $"
+"$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/utabmd.scm,v 9.39 1987/11/17 08:19:44 jinx Exp $"
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.2 1987/11/04 20:05:38 cph Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/version.h,v 10.3 1987/11/17 08:21:22 jinx Exp $
This file contains version information for the microcode. */
\f
/* Scheme system release version */
#ifndef RELEASE
-#define RELEASE "6.0.0"
+#define RELEASE "6.2.0"
#endif
/* Microcode release version */
#define VERSION 10
#endif
#ifndef SUBVERSION
-#define SUBVERSION 2
+#define SUBVERSION 5
#endif
#ifndef UCODE_TABLES_FILENAME
projects / mit-scheme.git / commitdiff