Attempt to fix OS_read_char_ready on bsd.
Some changes for VMS.
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.23 1987/04/07 16:58:25 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/bitstr.c,v 9.24 1987/04/16 02:26:50 jinx Exp $
Bit string primitives.
}
/* (BIT-STRING-ALLOCATE length)
- [Primitive number 0xD1]
Returns an uninitialized bit string of the given length. */
-Built_In_Primitive( Prim_bit_string_allocate, 1, "BIT-STRING-ALLOCATE")
+Built_In_Primitive( Prim_bit_string_allocate, 1, "BIT-STRING-ALLOCATE", 0xD1)
{
Primitive_1_Arg();
}
/* (BIT-STRING? object)
- [Primitive number 0xD3]
Returns true iff object is a bit string. */
-Built_In_Primitive( Prim_bit_string_p, 1, "BIT-STRING?")
+Built_In_Primitive( Prim_bit_string_p, 1, "BIT-STRING?", 0xD3)
{
Primitive_1_Arg();
}
\f
/* (MAKE-BIT-STRING size initialization)
- [Primitive number 0xD2]
Returns a bit string of the specified size with all the bits
set to zero if the initialization is false, one otherwise. */
-Built_In_Primitive( Prim_make_bit_string, 2, "MAKE-BIT-STRING")
+Built_In_Primitive( Prim_make_bit_string, 2, "MAKE-BIT-STRING", 0xD2)
{
Pointer result;
Primitive_2_Args();
}
/* (BIT-STRING-FILL! bit-string initialization)
- [Primitive number 0x197]
Fills the bit string with zeros if the initialization is false,
otherwise fills it with ones. */
-Built_In_Primitive( Prim_bit_string_fill_x, 2, "BIT-STRING-FILL!")
+Built_In_Primitive( Prim_bit_string_fill_x, 2, "BIT-STRING-FILL!", 0x197)
{
Primitive_2_Args();
}
/* (BIT-STRING-LENGTH bit-string)
- [Primitive number 0xD4]
Returns the number of bits in BIT-STRING. */
-Built_In_Primitive(Prim_bit_string_length, 1, "BIT-STRING-LENGTH")
+Built_In_Primitive(Prim_bit_string_length, 1, "BIT-STRING-LENGTH", 0xD4)
{
Primitive_1_Arg();
mask = (1 << (index % POINTER_LENGTH));
\f
/* (BIT-STRING-REF bit-string index)
- [Primitive number 0xD5]
Returns the boolean value of the indexed bit. */
-Built_In_Primitive( Prim_bit_string_ref, 2, "BIT-STRING-REF")
+Built_In_Primitive( Prim_bit_string_ref, 2, "BIT-STRING-REF", 0xD5)
{
ref_initialization();
}
/* (BIT-STRING-CLEAR! bit-string index)
- [Primitive number 0xD8]
Sets the indexed bit to zero, returning its previous value
as a boolean. */
-Built_In_Primitive( Prim_bit_string_clear_x, 2, "BIT-STRING-CLEAR!")
+Built_In_Primitive( Prim_bit_string_clear_x, 2, "BIT-STRING-CLEAR!", 0xD8)
{
ref_initialization();
}
/* (BIT-STRING-SET! bit-string index)
- [Primitive number 0xD7]
Sets the indexed bit to one, returning its previous value
as a boolean. */
-Built_In_Primitive( Prim_bit_string_set_x, 2, "BIT-STRING-SET!")
+Built_In_Primitive( Prim_bit_string_set_x, 2, "BIT-STRING-SET!", 0xD7)
{
ref_initialization();
}
/* (BIT-STRING-ZERO? bit-string)
- [Primitive number 0xD9]
Returns true the argument has no "set" bits. */
-Built_In_Primitive( Prim_bit_string_zero_p, 2, "BIT-STRING-ZERO?")
+Built_In_Primitive( Prim_bit_string_zero_p, 2, "BIT-STRING-ZERO?", 0xD9)
{
long length, odd_bits;
Primitive_1_Args();
}
/* (BIT-STRING=? bit-string-1 bit-string-2)
- [Primitive number 0x19D]
Returns true iff the two bit strings contain the same bits. */
-Built_In_Primitive( Prim_bit_string_equal_p, 2, "BIT-STRING=?")
+Built_In_Primitive( Prim_bit_string_equal_p, 2, "BIT-STRING=?", 0x19D)
{
long length;
Primitive_2_Args();
#define bit_string_and_x_action() &=
#define bit_string_andc_x_action() &= ~
-Built_In_Primitive( Prim_bit_string_move_x, 2, "BIT-STRING-MOVE!")
+Built_In_Primitive( Prim_bit_string_move_x, 2, "BIT-STRING-MOVE!", 0x198)
bitwise_op( bit_string_move_x_action)
-Built_In_Primitive( Prim_bit_string_movec_x, 2, "BIT-STRING-MOVEC!")
+Built_In_Primitive( Prim_bit_string_movec_x, 2, "BIT-STRING-MOVEC!", 0x199)
bitwise_op( bit_string_movec_x_action)
-Built_In_Primitive( Prim_bit_string_or_x, 2, "BIT-STRING-OR!")
+Built_In_Primitive( Prim_bit_string_or_x, 2, "BIT-STRING-OR!", 0x19A)
bitwise_op( bit_string_or_x_action)
-Built_In_Primitive( Prim_bit_string_and_x, 2, "BIT-STRING-AND!")
+Built_In_Primitive( Prim_bit_string_and_x, 2, "BIT-STRING-AND!", 0x19B)
bitwise_op( bit_string_and_x_action)
-Built_In_Primitive( Prim_bit_string_andc_x, 2, "BIT-STRING-ANDC!")
+Built_In_Primitive( Prim_bit_string_andc_x, 2, "BIT-STRING-ANDC!", 0x19C)
bitwise_op( bit_string_andc_x_action)
\f
/* (BIT-SUBSTRING-MOVE-RIGHT! source start1 end1 destination start2)
- [Primitive number 0xD6]
Destructively copies the substring of SOURCE between START1 and
END1 into DESTINATION at START2. The copying is done from the
MSB to the LSB (which only matters when SOURCE and DESTINATION
are the same). */
Built_In_Primitive( Prim_bit_substring_move_right_x, 5,
- "BIT-SUBSTRING-MOVE-RIGHT!")
+ "BIT-SUBSTRING-MOVE-RIGHT!", 0xD6)
{
long start1, end1, start2, end2, nbits;
long end1_mod, end2_mod;
}
\f
/* (UNSIGNED-INTEGER->BIT-STRING length integer)
- [Primitive number 0xDC]
INTEGER, which must be a non-negative integer, is converted to
a bit-string of length LENGTH. If INTEGER is too large, an
error is signalled. */
-Built_In_Primitive( Prim_unsigned_integer_to_bit_string, 2,
- "UNSIGNED-INTEGER->BIT-STRING")
+Built_In_Primitive( Prim_unsigned_to_bit_string, 2,
+ "UNSIGNED-INTEGER->BIT-STRING", 0xDC)
{
long length;
Primitive_2_Args();
}
\f
/* (BIT-STRING->UNSIGNED-INTEGER bit-string)
- [Primitive number 0xDD]
BIT-STRING is converted to the appropriate non-negative integer.
This operation is the inverse of `integer->bit-string'. */
-Built_In_Primitive( Prim_bit_string_to_unsigned_integer, 1,
- "BIT-STRING->UNSIGNED-INTEGER")
+Built_In_Primitive( Prim_bit_string_to_unsigned, 1,
+ "BIT-STRING->UNSIGNED-INTEGER", 0xDD)
{
Pointer *scan;
long nwords, nbits, ndigits, align_ndigits, word;
word = *scan++;
}
if (nwords == 0)
- return FIXNUM_0;
+ return Make_Unsigned_Fixnum(0);
nbits = (((nwords - 1) * POINTER_LENGTH) + long_significant_bits( word));
/* Handle fixnum case. */
verify that it is a pointer. */
/* (READ-BITS! pointer offset bit-string)
- [Primitive number 0xDF]
Read the contents of memory at the address (POINTER,OFFSET)
into BIT-STRING. */
-Built_In_Primitive( Prim_read_bits_x, 3, "READ-BITS!")
+Built_In_Primitive( Prim_read_bits_x, 3, "READ-BITS!", 0xDF)
{
long end, end_mod;
Primitive_3_Args();
}
/* (WRITE-BITS! pointer offset bit-string)
- [Primitive number 0xE0]
Write the contents of BIT-STRING in memory at the address
(POINTER,OFFSET). */
-Built_In_Primitive( Prim_write_bits_x, 3, "WRITE-BITS!")
+Built_In_Primitive( Prim_write_bits_x, 3, "WRITE-BITS!", 0xE0)
{
long end, end_mod;
Primitive_3_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/char.c,v 9.20 1987/01/21 20:16:35 jinx Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/char.c,v 9.21 1987/04/16 02:18:50 jinx Exp $ */
/* Character primitives. */
#include "character.h"
#include <ctype.h>
\f
-#define define_ascii_character_guarantee(procedure_name, wta, bra) \
+#define define_ascii_char_guarantee(procedure_name, wta, bra) \
long \
procedure_name (argument) \
Pointer argument; \
return (ascii); \
}
-define_ascii_character_guarantee (guarantee_ascii_character_arg_1,
- error_wrong_type_arg_1,
- error_bad_range_arg_1)
+define_ascii_char_guarantee (guarantee_ascii_char_arg_1,
+ error_wrong_type_arg_1,
+ error_bad_range_arg_1)
-define_ascii_character_guarantee (guarantee_ascii_character_arg_2,
- error_wrong_type_arg_2,
- error_bad_range_arg_2)
+define_ascii_char_guarantee (guarantee_ascii_char_arg_2,
+ error_wrong_type_arg_2,
+ error_bad_range_arg_2)
-define_ascii_character_guarantee (guarantee_ascii_character_arg_3,
- error_wrong_type_arg_3,
- error_bad_range_arg_3)
+define_ascii_char_guarantee (guarantee_ascii_char_arg_3,
+ error_wrong_type_arg_3,
+ error_bad_range_arg_3)
-define_ascii_character_guarantee (guarantee_ascii_character_arg_4,
- error_wrong_type_arg_4,
- error_bad_range_arg_4)
+define_ascii_char_guarantee (guarantee_ascii_char_arg_4,
+ error_wrong_type_arg_4,
+ error_bad_range_arg_4)
-define_ascii_character_guarantee (guarantee_ascii_character_arg_5,
- error_wrong_type_arg_5,
- error_bad_range_arg_5)
+define_ascii_char_guarantee (guarantee_ascii_char_arg_5,
+ error_wrong_type_arg_5,
+ error_bad_range_arg_5)
-define_ascii_character_guarantee (guarantee_ascii_character_arg_6,
- error_wrong_type_arg_6,
- error_bad_range_arg_6)
+define_ascii_char_guarantee (guarantee_ascii_char_arg_6,
+ error_wrong_type_arg_6,
+ error_bad_range_arg_6)
-define_ascii_character_guarantee (guarantee_ascii_character_arg_7,
- error_wrong_type_arg_7,
- error_bad_range_arg_7)
+define_ascii_char_guarantee (guarantee_ascii_char_arg_7,
+ error_wrong_type_arg_7,
+ error_bad_range_arg_7)
-define_ascii_character_guarantee (guarantee_ascii_character_arg_8,
- error_wrong_type_arg_8,
- error_bad_range_arg_8)
+define_ascii_char_guarantee (guarantee_ascii_char_arg_8,
+ error_wrong_type_arg_8,
+ error_bad_range_arg_8)
-define_ascii_character_guarantee (guarantee_ascii_character_arg_9,
- error_wrong_type_arg_9,
- error_bad_range_arg_9)
+define_ascii_char_guarantee (guarantee_ascii_char_arg_9,
+ error_wrong_type_arg_9,
+ error_bad_range_arg_9)
-define_ascii_character_guarantee (guarantee_ascii_character_arg_10,
- error_wrong_type_arg_10,
- error_bad_range_arg_10)
+define_ascii_char_guarantee (guarantee_ascii_char_arg_10,
+ error_wrong_type_arg_10,
+ error_bad_range_arg_10)
\f
#define define_ascii_integer_guarantee(procedure_name, wta, bra) \
long \
error_wrong_type_arg_10,
error_bad_range_arg_10)
\f
-Built_In_Primitive (Prim_Make_Char, 2, "MAKE-CHAR")
+Built_In_Primitive (Prim_Make_Char, 2, "MAKE-CHAR", 0x14)
{
long bucky_bits, code;
Primitive_2_Args ();
return (make_char (bucky_bits, code));
}
-Built_In_Primitive (Prim_Char_Bits, 1, "CHAR-BITS")
+Built_In_Primitive (Prim_Char_Bits, 1, "CHAR-BITS", 0x15)
{
Primitive_1_Arg ();
- guarantee_character_arg_1 ();
+ guarantee_char_arg_1 ();
return (Make_Unsigned_Fixnum (char_bits (Arg1)));
}
-Built_In_Primitive (Prim_Char_Code, 1, "CHAR-CODE")
+Built_In_Primitive (Prim_Char_Code, 1, "CHAR-CODE", 0x17)
{
Primitive_1_Arg ();
- guarantee_character_arg_1 ();
+ guarantee_char_arg_1 ();
return (Make_Unsigned_Fixnum (char_code (Arg1)));
}
-Built_In_Primitive (Prim_Char_To_Integer, 1, "CHAR->INTEGER")
+Built_In_Primitive (Prim_Char_To_Integer, 1, "CHAR->INTEGER", 0x1B)
{
Primitive_1_Arg ();
- guarantee_character_arg_1 ();
+ guarantee_char_arg_1 ();
return (Make_Unsigned_Fixnum (Arg1 & MASK_EXTNDD_CHAR));
}
-Built_In_Primitive (Prim_Integer_To_Char, 1, "INTEGER->CHAR")
+Built_In_Primitive (Prim_Integer_To_Char, 1, "INTEGER->CHAR", 0x34)
{
Primitive_1_Arg ();
return ((islower (c)) ? ((c - 'a') + 'A') : c);
}
-Built_In_Primitive (Prim_Char_Downcase, 1, "CHAR-DOWNCASE")
+Built_In_Primitive (Prim_Char_Downcase, 1, "CHAR-DOWNCASE", 0x35)
{
Primitive_1_Arg ();
- guarantee_character_arg_1 ();
+ guarantee_char_arg_1 ();
return (make_char ((char_bits (Arg1)), (char_downcase (char_code (Arg1)))));
}
-Built_In_Primitive (Prim_Char_Upcase, 1, "CHAR-UPCASE")
+Built_In_Primitive (Prim_Char_Upcase, 1, "CHAR-UPCASE", 0x36)
{
Primitive_1_Arg ();
- guarantee_character_arg_1 ();
+ guarantee_char_arg_1 ();
return (make_char ((char_bits (Arg1)), (char_upcase (char_code (Arg1)))));
}
-Built_In_Primitive (Prim_Ascii_To_Char, 1, "ASCII->CHAR")
+Built_In_Primitive (Prim_Ascii_To_Char, 1, "ASCII->CHAR", 0x37)
{
Primitive_1_Arg ();
return (c_char_to_scheme_char (guarantee_ascii_integer_arg_1 (Arg1)));
}
-Built_In_Primitive (Prim_Char_To_Ascii, 1, "CHAR->ASCII")
+Built_In_Primitive (Prim_Char_To_Ascii, 1, "CHAR->ASCII", 0x39)
{
Primitive_1_Arg ();
- return (Make_Unsigned_Fixnum (guarantee_ascii_character_arg_1 (Arg1)));
+ return (Make_Unsigned_Fixnum (guarantee_ascii_char_arg_1 (Arg1)));
}
-Built_In_Primitive (Prim_Char_Ascii_P, 1, "CHAR-ASCII?")
+Built_In_Primitive (Prim_Char_Ascii_P, 1, "CHAR-ASCII?", 0x38)
{
long ascii;
Primitive_1_Arg ();
- guarantee_character_arg_1 ();
+ guarantee_char_arg_1 ();
ascii = (scheme_char_to_c_char (Arg1));
return ((ascii == NOT_ASCII) ? NIL : (Make_Unsigned_Fixnum (ascii)));
}
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/config.h,v 9.23 1987/04/03 00:09:46 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/config.h,v 9.24 1987/04/16 02:20:07 jinx Exp $
*
* This file contains the configuration information and the information
* given on the command line on Unix.
option is incompatible with the stepper and compiler.
*/
/* #define USE_STACKLETS */
-
-/* To enable "trap on reference" variable bindings (used by parallel processor
- deep binding).
-*/
-/* #define TRAP_ON_REFERENCE */
#endif
#endif
\f
#ifdef USE_STACKLETS
#ifdef COMPILE_STEPPER
-#include "Error: The stepper doesn't work with stacklets. Fix it."
+#include "Error: The stepper doesn't work with stacklets."
#endif
#endif
-
-/* To enable metering of the time spent in various parts of the Scheme
- interpreter. Collecting this data slows down the operation of the
- interpreter, and no tools are supported for accessing the values
- collected. Useful for collecting statistics and performance work on
- the interpreter itself or user programs. */
-
-/* #define METERING */
\f
/* These C type definitions are needed by everybody.
They should not be here, but it is unavoidable. */
#define false 0
/* This defines it so that C will be happy.
- The various fields are defined in OBJECT.H */
+ The various fields are defined in object.h */
typedef unsigned long Pointer;
\f
but if it does, it will probably compute the correct information.
Note that the C type void is used in the sources. If your version
- of C does not have this type, you should bypass it. Look at what
- vms (below) does.
+ of C does not have this type, you should bypass it.
+ This can be done by inserting the preprocessor command
+ '#define void' in this file.
CHAR_SIZE is the size of a character in bits.
#define FASL_CYBER 8
#define FASL_CELERITY 9
#define FASL_HP_SPECTRUM 10
+#define FASL_UMAX 11
\f
/* These (pdp10 and nu) haven't worked in a while.
* Should be upgraded or flushed some day.
#endif
#ifdef nu
-#define noquick /* Bignum code fails for certain
- variables in registers because of
- a compiler bug! */
#define Heap_In_Low_Memory
#define CHAR_SIZE 8
#define USHORT_SIZE 16
#define FLONUM_MANTISSA_BITS 56
#define MAX_FLONUM_EXPONENT 127
#define HAS_FREXP
+#ifdef quick
+/* Bignum code fails for certain variables in registers because of a
+ compiler bug!
+*/
+#undef quick
+#define quick
+#endif
#endif
\f
#ifdef vax
#ifdef vms
-/* VMS C has not void type, thus make it go away */
-#define void
+/* Pre version 4 VMS C has not void type, thus make it go away */
+/* #define void */
/* Name conflict in VMS with system variable */
#define Free Free_Register
#define Exit_Scheme_Declarations static jmp_buf Exit_Point
#define Init_Exit_Scheme() \
-{ int Which_Way = setjmp(Exit_Point); \
- if (Which_Way == NORMAL_EXIT) return; \
+{ \
+ int Which_Way = setjmp(Exit_Point); \
+ if (Which_Way == NORMAL_EXIT) \
+ return; \
}
#define Exit_Scheme(value) \
-if (value != 0) exit(value); \
+if (value != 0) \
+ exit(value); \
longjmp(Exit_Point, NORMAL_EXIT)
#else /* not a vms */
/* Vax Unix C compiler bug */
#define double_into_fixnum(what, target) \
- { long For_Vaxes_Sake = (long) what; \
- target = Make_Non_Pointer(TC_FIXNUM, For_Vaxes_Sake); \
- }
+{ \
+ long For_Vaxes_Sake = ((long) what); \
+ \
+ target = Make_Non_Pointer(TC_FIXNUM, For_Vaxes_Sake); \
+}
#endif /* not vms */
#endif /* vax */
#define MAX_FLONUM_EXPONENT 1023
#define HAS_FLOOR
#define HAS_FREXP
-#define term_type int /* C compiler bug in GC_Type */
+/* C compiler bug in GC_Type */
+#define term_type int
#endif
#ifdef hp9000s500
#define FLONUM_EXPT_SIZE 7
#define FLONUM_MANTISSA_BITS 56
#define MAX_FLONUM_EXPONENT 127
-#define Allow_Aux_Compilation false /* Prevent race in lookup */
#include <public.h>
#define HAS_FREXP
#define STACK_SIZE 4 /* 4K objects */
#define HAS_FLOOR
#define HAS_FREXP
#endif
+
+#ifdef umax
+#define Heap_In_Low_Memory
+#define UNSIGNED_SHIFT
+#define CHAR_SIZE 8
+#define USHORT_SIZE 16
+#define ULONG_SIZE 32
+#define BELL '\007'
+#define FASL_INTERNAL_FORMAT FASL_UMAX
+#define FLONUM_EXPT_SIZE 10
+#define FLONUM_MANTISSA_BITS 53
+#define MAX_FLONUM_EXPONENT 1023
+#define HAS_FLOOR
+#define HAS_FREXP
+#endif
\f
/* Make sure that some definition applies.
If this error occurs, and the parameters of the
#include "Error: config.h: Unknown configuration."
#endif
-#ifdef noquick
-#define quick
-#else
-#define quick fast
-#endif
-
#if (ULONG_SIZE == 32)
#define b32
#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/const.h,v 9.23 1987/04/03 00:10:08 jinx Exp $
+/* $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 $
*
* Named constants used throughout the interpreter
*
#define NIL Make_Non_Pointer(TC_NULL, 0)
#define TRUTH Make_Non_Pointer(TC_TRUE, 0)
-#define FIXNUM_0 Make_Non_Pointer(TC_FIXNUM, 0)
-#define BROKEN_HEART_0 Make_Non_Pointer(TC_BROKEN_HEART, 0)
-#define STRING_0 Make_Non_Pointer(TC_CHARACTER_STRING, 0)
+#define FIXNUM_ZERO Make_Non_Pointer(TC_FIXNUM, 0)
+#define BROKEN_HEART_ZERO Make_Non_Pointer(TC_BROKEN_HEART, 0)
#else /* 32 bit word */
#define NIL 0x00000000
#define TRUTH 0x08000000
-#define FIXNUM_0 0x1A000000
-#define BROKEN_HEART_0 0x22000000
-#define STRING_0 0x1E000000
+#define FIXNUM_ZERO 0x1A000000
+#define BROKEN_HEART_ZERO 0x22000000
#endif /* b32 */
#define NOT_THERE -1 /* Command line parser */
#define REGBLOCK_EXPR 5
#define REGBLOCK_RETURN 6
#define REGBLOCK_MINIMUM_LENGTH 7
+\f
+/* Codes specifying how to start scheme at boot time. */
+
+#define BOOT_FASLOAD 0
+#define BOOT_LOAD_BAND 1
+#define BOOT_GET_WORK 2
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.23 1987/04/03 00:10:26 jinx Exp $
+/* $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 $
This file contains code for the Garbage Collection daemons.
There are currently two daemons, one for closing files which
the runtime system for a longer description.
*/
-extern Boolean OS_file_close();
-
-Built_In_Primitive(Prim_Close_Lost_Open_Files, 1, "CLOSE-LOST-OPEN-FILES")
-{ fast Pointer *Smash, Cell, Weak_Cell;
+Built_In_Primitive(Prim_Close_Lost_Open_Files, 1, "CLOSE-LOST-OPEN-FILES", 0xC7)
+{
+ extern Boolean OS_file_close();
+ fast Pointer *Smash, Cell, Weak_Cell, Value;
long channel_number;
Primitive_1_Arg();
+ Value = TRUTH;
+
for (Smash = Nth_Vector_Loc(Arg1, CONS_CDR), Cell = *Smash;
Cell != NIL;
Cell = *Smash)
if (Fast_Vector_Ref(Weak_Cell, CONS_CAR) == NIL)
{
channel_number = Get_Integer(Fast_Vector_Ref(Weak_Cell, CONS_CDR));
- (void) OS_file_close (Channels[channel_number]);
+ if (!OS_file_close (Channels[channel_number]))
+ Value = NIL;
Channels[channel_number] = NULL;
*Smash = Fast_Vector_Ref(Cell, CONS_CDR);
}
else
Smash = Nth_Vector_Loc(Cell, CONS_CDR);
}
- return TRUTH;
+ return Value;
}
\f
/* Utilities for the rehash daemon below */
See hash.scm in the runtime system for a description.
*/
-Built_In_Primitive(Prim_Rehash, 2, "REHASH")
-{ long table_size, counter;
+Built_In_Primitive(Prim_Rehash, 2, "REHASH", 0x5C)
+{
+ long table_size, counter;
Pointer *bucket;
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/debug.c,v 9.23 1987/04/03 00:10:44 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/debug.c,v 9.24 1987/04/16 02:20:42 jinx Rel $
*
* Utilities to help with debugging
*/
if (Type_Code(procedure) == AUX_LIST_TYPE)
{
extension = procedure;
- procedure = Fast_Vector_Ref(extension, ENVIRONMENT_EXTENSION_PROCEDURE);
+ procedure = Fast_Vector_Ref(extension, ENV_EXTENSION_PROCEDURE);
}
else
extension = NIL;
}
}
\f
-/* For debugging, given a String, return either a "not interned"
- * message or the address of the symbol and its global value.
- */
-
-void Find_Symbol(Scheme_String)
-Pointer Scheme_String;
-{ Pointer Ob_Array, The_Symbol, *Bucket;
- char *String, *Temp_String;
- long i, Hashed_Value;
- String = Scheme_String_To_C_String(Scheme_String);
- for (Temp_String=String, i=0; *Temp_String == '\0'; i++) Temp_String++;
- Hashed_Value = Do_Hash(String, i);
- Ob_Array = Get_Fixed_Obj_Slot(OBArray);
- Hashed_Value %= Vector_Length(Ob_Array);
- Bucket = Nth_Vector_Loc(Ob_Array, Hashed_Value);
- while (*Bucket != NIL)
- { if (String_Equal(Scheme_String,
- Vector_Ref(Vector_Ref(*Bucket, CONS_CAR),
- SYMBOL_NAME)))
- { The_Symbol = Vector_Ref(*Bucket, CONS_CAR);
- printf("\nInterned Symbol: 0x%x", The_Symbol);
- Print_Expression(Vector_Ref(The_Symbol, SYMBOL_GLOBAL_VALUE),
- "Value");
- printf("\n");
- return;
- }
- Bucket = Nth_Vector_Loc(*Bucket, CONS_CDR);
- }
- printf("\nNot interned.\n");
-}
-\f
List_Print(Expr)
Pointer Expr;
{ int Count;
printf(" (from ");
procedure = Vector_Ref(Expr, ENVIRONMENT_FUNCTION);
if (Type_Code(procedure) == TC_QUAD)
- procedure = Vector_Ref(procedure, ENVIRONMENT_EXTENSION_PROCEDURE);
+ procedure = Vector_Ref(procedure, ENV_EXTENSION_PROCEDURE);
Do_Printing(procedure, false);
printf(")");
return;
printf(" 0x%x]", Temp_Address);
}
\f
-Boolean Print_One_Continuation_Frame(Temp)
-Pointer Temp;
-{ Pointer Expr;
+Boolean
+Print_One_Continuation_Frame(Temp)
+ Pointer Temp;
+{
+ Pointer Expr;
+
Print_Expression(Temp, "Return code");
CRLF();
Expr = Pop();
/* 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. */
-void Back_Trace()
-{ Pointer Temp, *Old_Stack;
+void
+Back_Trace()
+{
+ Pointer Temp, *Old_Stack;
+
Back_Trace_Entry_Hook();
Old_Stack = Stack_Pointer;
while (true)
Back_Trace_Exit_Hook();
}
-void Print_Stack(SP)
-Pointer *SP;
-{ Pointer *Saved_SP;
+void
+Print_Stack(SP)
+ Pointer *SP;
+{
+ Pointer *Saved_SP;
+
Saved_SP = Stack_Pointer;
Stack_Pointer = SP;
Back_Trace();
return;
}
\f
-Boolean Prt_PName(Number)
-long Number;
-{ if ((Number < 0) ||
- (Number > MAX_PRIMITIVE) ||
- (Primitive_Names[Number] == NULL))
- { printf("Unknown primitive 0x%08x", Number);
+Boolean
+Prt_PName(Number)
+ long Number;
+{
+ extern char *primitive_to_name();
+ char *name;
+
+ name = primitive_to_name(Number);
+ if (name == ((char *) NULL))
+ {
+ printf("Unknown primitive 0x%08x", Number);
return false;
}
else
- { printf("%s", Primitive_Names[Number]);
+ {
+ printf("%s", name);
return true;
}
}
void Print_Primitive(Number)
-long Number;
-{ short NArgs;
+ long Number;
+{
+
+ extern long primitive_to_arity();
+ char buffer1[40], buffer2[40];
+ int NArgs, i;
printf("Primitive: ");
- if (Prt_PName(Number)) NArgs = (int) Arg_Count_Table[Number];
- else NArgs = 3; /* Unknown primitive */
+ if (Prt_PName(Number))
+ NArgs = primitive_to_arity(Number);
+ else
+ NArgs = 3; /* Unknown primitive */
printf("\n");
- if (NArgs > 0)
- { Print_Expression(Stack_Ref(0), "...Arg 1");
- printf("\n");
- }
- if (NArgs > 1)
- { Print_Expression(Stack_Ref(1), "...Arg 2");
- printf("\n");
- }
- if (NArgs > 2)
- { Print_Expression(Stack_Ref(2), "...Arg 3");
+
+ for (i = 0; i < NArgs; i++)
+ {
+ sprintf(buffer1, "Stack_Ref(%d)", i);
+ sprintf(buffer2, "...Arg %d", (i + 1));
+ Print_Expression(buffer1, buffer2);
printf("\n");
}
}
putchar('\n');
}
-/* (TEMP_PRINTER OBJECT)
- [Primitive number 0xB2]
+/* (DEBUGGING-PRINTER OBJECT)
A cheap, built-in printer intended for debugging the
interpreter.
*/
-Built_In_Primitive(Prim_Temp_Printer, 1, "TEMP-PRINTER")
-{ Primitive_1_Arg();
+Built_In_Primitive(Prim_Temp_Printer, 1, "DEBUGGING-PRINTER", 0xB2)
+{
+ Primitive_1_Arg();
+
Debug_Printer(Arg1);
return TRUTH;
}
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/default.h,v 9.21 1987/01/22 14:23:17 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/default.h,v 9.22 1987/04/16 02:20:58 jinx Exp $
*
* This file contains default definitions for some hooks which
* various machines require. These machines define these hooks
/* Primitive calling code. */
#ifndef ENABLE_DEBUGGING_TOOLS
-#define Apply_Primitive(N) (*(Primitive_Table[N]))()
+#define Apply_Primitive(N) Internal_Apply_Primitive(N)
#else
extern Pointer Apply_Primitive();
#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/Attic/dmpwrld.c,v 9.23 1987/04/11 16:05:19 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/dmpwrld.c,v 9.24 1987/04/16 02:21:08 jinx Exp $
*
* This file contains a primitive to dump an executable version of Scheme.
* It uses unexec.c from GNU Emacs.
#define TEXT_START (PAGSIZ + (sizeof(struct exec)))
#endif
-/* I don't know whether the following two are right or not. */
+/* I haven't tried any below this point. */
-#ifdef sun2
+#if defined(umax)
#define UNEXEC_AVAILABLE
-#define SEGMENT_MASK (SEGSIZ - 1)
+#define HAVE_GETPAGESIZE
+#define COFF
+#define UMAX
+#define SECTION_ALIGNMENT pagemask
+#define SEGMENT_MASK (64 * 1024 - 1)
#endif
#ifdef celerity
#define UNEXEC_AVAILABLE
#endif
+#ifdef sun2
+#define UNEXEC_AVAILABLE
+#define SEGMENT_MASK (SEGSIZ - 1)
+#endif
+\f
#ifndef UNEXEC_AVAILABLE
#include "Error: dumpworld.c only works on a few machines."
#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/extern.c,v 9.21 1987/01/22 14:23:45 jinx Exp $
- *
- * This file contains the support routines for externally supplied
- * procedure -- that is, primitives 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 duration of a single
- * Scheme session.
- */
+/* $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 $ */
#include "scheme.h"
#include "primitive.h"
\f
-Pointer Undefined_Externals = NIL;
-
-#define NUndefined() \
-((Undefined_Externals==NIL) ? \
- 0 : Get_Integer(User_Vector_Ref(Undefined_Externals, 0)))
-
-#define CHUNK_SIZE 20 /* Grow undefined vector by this much */
-
-/* (GET-EXTERNALS-COUNT)
- [Primitive number 0x101]
+/* (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.
*/
-Built_In_Primitive(Prim_Get_External_Count, 0, "GET-EXTERNALS-COUNT")
-{ Primitive_0_Args();
- *Free++ = FIXNUM_0 + (MAX_EXTERNAL_PRIMITIVE + 1);
- *Free++ = FIXNUM_0 + NUndefined();
- return Make_Pointer(TC_LIST, Free-2);
-}
-\f
-Pointer Get_Name_Of_Impl_External(Number)
-long Number;
-{ Pointer Result;
- Pointer *Orig_Result, *Orig_Free = Free;
+Built_In_Primitive(Prim_Get_External_Count, 0, "GET-EXTERNAL-COUNTS", 0x101)
+{
+ Primitive_0_Args();
- Result = C_String_To_Scheme_String(Ext_Prim_Desc[Number].name);
- Free[SYMBOL_NAME] = Result;
- Free[SYMBOL_GLOBAL_VALUE] = NIL;
- Result = Make_Pointer(TC_UNINTERNED_SYMBOL, Free);
- Orig_Result = Free;
- Free += 2;
- Intern(&Result);
- if (Get_Pointer(Result) != Orig_Result) Free = Orig_Free;
- return Result;
+ *Free++ = Make_Unsigned_Fixnum(MAX_EXTERNAL_PRIMITIVE + 1);
+ *Free++ = Make_Unsigned_Fixnum(NUndefined());
+ return Make_Pointer(TC_LIST, Free - 2);
}
-
+\f
/* (GET-EXTERNAL-NAME n)
- [Primitive number 0x102]
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.
*/
-Built_In_Primitive(Prim_Get_Ext_Name, 1, "GET-EXTERNAL-NAME")
-{ long Number, TC;
+Built_In_Primitive(Prim_Get_Ext_Name, 1, "GET-EXTERNAL-NAME", 0x102)
+{
+ extern Pointer external_primitive_name();
+ long Number, TC;
Primitive_1_Arg();
TC = Type_Code(Arg1);
Range_Check(Number, Arg1, 0, MAX_EXTERNAL_PRIMITIVE+NUndefined(),
ERR_ARG_1_BAD_RANGE);
if (Number <= MAX_EXTERNAL_PRIMITIVE)
- return Get_Name_Of_Impl_External(Number);
+ return external_primitive_name(Number);
else return User_Vector_Ref(Undefined_Externals,
- Number-MAX_EXTERNAL_PRIMITIVE);
+ (Number - MAX_EXTERNAL_PRIMITIVE));
}
\f
-Boolean PGEN_Compare(C_String, S_String)
-char *C_String;
-Pointer S_String;
-{ char *S = (char *) Nth_Vector_Loc(S_String, STRING_CHARS);
- long N = Get_Integer(Fast_Vector_Ref(S_String, STRING_LENGTH));
- long i;
- for (i=0; i < N; i++) if (*S++ != *C_String++) return false;
- return (*C_String == 0);
-}
-
-long Get_Ext_Number(Symbol, Intern_It)
-Pointer Symbol, Intern_It;
-{ Pointer *Next, Name = Fast_Vector_Ref(Symbol, SYMBOL_NAME);
- long i, Max;
-
- for (i=0; i <= MAX_EXTERNAL_PRIMITIVE; i++)
- if (PGEN_Compare(Ext_Prim_Desc[i].name, Name)) return i;
- if (Intern_It == NIL) return -1;
- Max = NUndefined();
- 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 MAX_EXTERNAL_PRIMITIVE+i;
- if (Intern_It != TRUTH) return -1;
- /* 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);
- *Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, Max+CHUNK_SIZE+1);
- *Free++ = FIXNUM_0 + Max + 1;
- for (i=0; i < Max; i++) *Free++ = Fetch(*Next++);
- *Free++ = Symbol;
- for (i=1; i < CHUNK_SIZE; i++) *Free++ = NIL;
- }
- else
- { User_Vector_Set(Undefined_Externals, Max+1, Symbol);
- User_Vector_Set(Undefined_Externals, 0, FIXNUM_0+Max+1);
- }
- return MAX_EXTERNAL_PRIMITIVE+Max+1;
-}
-
/* (GET-EXTERNAL-NUMBER name intern?)
- [Primitive number 0x103]
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
the name does not exist either.
*/
-Built_In_Primitive(Prim_Get_Ext_Number, 2, "GET-EXTERNAL-NUMBER")
-{ long Answer;
+Built_In_Primitive(Prim_Get_Ext_Number, 2, "GET-EXTERNAL-NUMBER", 0x103)
+{
+ extern long make_external_primitive();
Primitive_2_Args();
Arg_1_Type(TC_INTERNED_SYMBOL);
Touch_In_Primitive(Arg2, Arg2);
- Answer = Get_Ext_Number(Arg1, Arg2);
- return ((Answer == -1) ?
- NIL : Make_Non_Pointer(TC_PRIMITIVE_EXTERNAL, Answer));
-}
-\f
-/* Called from FASDUMP and BAND_DUMP to create a vector with
- symbols for each of the external primitives known to the system.
-*/
-
-Pointer Make_Prim_Exts()
-{ Pointer Result = Make_Pointer(TC_VECTOR, Free), *Orig_Free=Free;
- long i, Max=NUndefined(), Count;
-
- Count = MAX_EXTERNAL_PRIMITIVE + Max + 1;
- Primitive_GC_If_Needed(Count+1);
- Free += Count+1;
- *Orig_Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, Count);
- for (i=0; i <= MAX_EXTERNAL_PRIMITIVE; i++)
- *Orig_Free++ = Get_Name_Of_Impl_External(i);
- for (i=1; i <= Max; i++)
- *Orig_Free++ = User_Vector_Ref(Undefined_Externals, i);
- return Result;
+ return make_external_primitive(Arg1, Arg2);
}
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.23 1987/04/03 00:11:43 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/extern.h,v 9.24 1987/04/16 02:21:28 jinx Exp $
*
* External declarations.
*
extern Pointer Lookup_Base;
extern long Lookup_Offset;
-extern char *Primitive_Names[], *Return_Names[];
-extern long MAX_PRIMITIVE, MAX_RETURN;
+extern char *Return_Names[];
+extern long MAX_RETURN;
-extern char Arg_Count_Table[],
- *CONT_PRINT_RETURN_MESSAGE,
+extern char *CONT_PRINT_RETURN_MESSAGE,
*CONT_PRINT_EXPR_MESSAGE,
*RESTORE_CONT_RETURN_MESSAGE,
*RESTORE_CONT_EXPR_MESSAGE;
extern Boolean Photo_Open; /* Photo file open */
extern jmp_buf *Back_To_Eval;
-extern Boolean Trapping, Can_Do_Cursor;
-extern Pointer Old_Return_Code, *Return_Hook_Address,
- *Previous_Restore_History_Stacklet,
- Weak_Chain;
-extern long Previous_Restore_History_Offset;
+extern Boolean Trapping;
+extern Pointer Old_Return_Code, *Return_Hook_Address;
+
+extern Pointer *Prev_Restore_History_Stacklet;
+extern long Prev_Restore_History_Offset;
\f
/* And file "channels" */
extern long Heap_Size, Constant_Size, Stack_Size;
extern Pointer *Highest_Allocated_Address;
\f
+/* Environment lookup utilities. */
+
+extern long Lex_Ref(), Local_Set(), Lex_Set(),
+ Symbol_Lex_Ref(), Symbol_Lex_Set();
+
/* String utilities */
-extern Boolean String_Equal();
-extern Pointer Make_String(), C_String_To_Scheme_String();
+extern Pointer C_String_To_Scheme_String();
+
#define Scheme_String_To_C_String(Scheme_String) \
((char *) Nth_Vector_Loc(Scheme_String, STRING_CHARS))
-/* Symbol and variable utilities */
-
-extern long Lex_Ref(), Local_Set(), Lex_Set(),
- Symbol_Lex_Ref(), Symbol_Lex_Set(), Binding_Lookup_Slot(),
- Intern(), Lookup_Fluid(), Symbol_Lookup(), Do_Hash();
-extern Pointer Hash();
-
/* Numeric utilities */
extern int Scheme_Integer_To_C_Integer();
extern Pointer C_Integer_To_Scheme_Integer(), Allocate_Float(),
Float_To_Big(), Big_To_Float(), Big_To_Fix(),
- Fix_To_Big(), Mul();
+ Fix_To_Big();
/* Random and OS utilities */
Back_Out_Of_Primitive(), Translate_To_Point(),
Stop_History(), Stack_Death();
-extern void Clear_Int_Timer(), Set_Int_Timer();
-
#ifdef USE_STACKLETS
extern void Allocate_New_Stacklet();
#endif
-extern Pointer (*(Primitive_Table[]))(), *Make_Dummy_History(),
- Find_State_Space();
+extern Pointer *Make_Dummy_History(), Find_State_Space();
/* Debugging utilities */
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.23 1987/04/03 00:12:00 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasdump.c,v 9.24 1987/04/16 02:21:39 jinx Exp $
This file contains code for fasdump and dump-band.
*/
Setup_Pointer_for_Dump(Transport_Pair());
case TC_INTERNED_SYMBOL:
- Setup_Pointer_for_Dump(Fasdump_Symbol(BROKEN_HEART_0));
+ Setup_Pointer_for_Dump(Fasdump_Symbol(Make_Broken_Heart(0)));
case TC_UNINTERNED_SYMBOL:
Setup_Pointer_for_Dump(Fasdump_Symbol(UNBOUND_OBJECT));
return true;
} /* DumpLoop */
\f
+/*
+ Used to create a vector with symbols for each of the external
+ primitives known to the system.
+*/
+
+Pointer
+Make_Prim_Exts()
+{
+ extern Pointer external_primitive_name();
+ 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++)
+ {
+ *scan++ = external_primitive_name(i);
+ }
+ for (i = 1; i <= Max; i++)
+ {
+ *scan++ = User_Vector_Ref(Undefined_Externals, i);
+ }
+ return Result;
+}
+\f
+void
+Fasdump_Exit()
+{
+ fast Pointer *Fixes;
+
+ Fixes = Fixup;
+ fclose(File_Handle);
+ while (Fixes != NewMemTop)
+ {
+ fast Pointer *Fix_Address;
+
+ Fix_Address = Get_Pointer(*Fixes++); /* Where it goes. */
+ *Fix_Address = *Fixes++; /* Put it there. */
+ }
+ Fixup = Fixes;
+ Fasdump_Exit_Hook();
+}
+\f
/* (PRIMITIVE-FASDUMP object-to-dump file-name flag)
- [Primitive number 0x56]
- Dump an object into a file so that it can be loaded using
- BINARY-FASLOAD. A spare heap is required for this operation.
- The first argument is the object to be dumped. The second is
- the filename and the third a flag. The flag, if #!TRUE, means
- that the object is to be dumped for reloading into constant
- space. This is currently disabled. If the flag is NIL, it means
- that it will be reloaded into the heap. The primitive returns
- #!TRUE or NIL indicating whether it successfully dumped the
- object (it can fail on an object that is too large).
+ Dump an object into a file so that it can be loaded using
+ BINARY-FASLOAD. A spare heap is required for this operation.
+ The first argument is the object to be dumped. The second is
+ the filename and the third a flag. The flag, if #!TRUE, means
+ that the object is to be dumped for reloading into constant
+ space. This is currently disabled. If the flag is NIL, it means
+ that it will be reloaded into the heap. The primitive returns
+ #!TRUE or NIL indicating whether it successfully dumped the
+ object (it can fail on an object that is too large).
+
+ The code for dumping pure is severely broken and conditionalized out.
*/
-Built_In_Primitive(Prim_Prim_Fasdump, 3, "PRIMITIVE-FASDUMP")
-{ Pointer Object, File_Name, Flag, *New_Object,
+Built_In_Primitive(Prim_Prim_Fasdump, 3, "PRIMITIVE-FASDUMP", 0x56)
+{
+ Pointer Object, File_Name, Flag, *New_Object,
*Addr_Of_New_Object, Prim_Exts;
long Pure_Length, Length;
Primitive_3_Args();
if (!Open_Dump_File(File_Name, WRITE_FLAG))
Primitive_Error(ERR_ARG_2_BAD_RANGE);
#if false
- /* Cannot dump pure at all */
if ((Flag != NIL) && (Flag != TRUTH))
#else
if (Flag != NIL)
New_Object = NewFree;
*NewFree++ = Object;
*NewFree++ = Prim_Exts;
-
-/* Prim_Primitive_Fasdump continues on next page */
\f
-/* Prim_Primitive_Fasdump, continued */
-
#if false
- /* This code is supposed to handle pure dumping. It is severely
- broken. It should be removed or fixed.
- */
- if (Flag==TRUTH)
+ if (Flag == TRUTH)
{ if (!DumpLoop(New_Object, PURE_COPY))
- { Fasdump_Exit();
+ {
+ Fasdump_Exit();
return NIL;
}
/* Can't align.
*NewFree++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
*NewFree++ = Make_Non_Pointer(CONSTANT_PART, Pure_Length);
if (!DumpLoop(New_Object, CONSTANT_COPY))
- { Fasdump_Exit();
+ {
+ Fasdump_Exit();
return NIL;
}
Length = NewFree-New_Object+2;
Write_File(0, 0x000000, Addr_Of_New_Object,
Length, New_Object, Prim_Exts);
}
-
-/* Fasdump continues on the next page */
-\f
-/* Fasdump, continued */
-
else /* Dumping for reload into heap */
#endif
{ if (!DumpLoop(New_Object, NORMAL_GC))
- { Fasdump_Exit();
+ {
+ Fasdump_Exit();
return NIL;
}
/* Aligning might screw up some of the counters.
Fasdump_Exit();
return TRUTH;
}
-
-Fasdump_Exit()
-{ register Pointer *Fixes = Fixup;
- fclose(File_Handle);
- while (Fixes != NewMemTop)
- { register Pointer *Fix_Address;
- Fix_Address = Get_Pointer(*Fixes++); /* Where it goes. */
- *Fix_Address = *Fixes++; /* Put it there. */
- }
- Fixup = Fixes;
- Fasdump_Exit_Hook();
-}
\f
/* (DUMP-BAND PROCEDURE FILE-NAME)
- [Primitive number 0xB7]
- Saves all of the heap and pure space on FILE-NAME. When the
- file is loaded back using BAND_LOAD, PROCEDURE is called with an
- argument of NIL.
+ Saves all of the heap and pure space on FILE-NAME. When the
+ file is loaded back using BAND_LOAD, PROCEDURE is called with an
+ argument of NIL.
*/
-Built_In_Primitive(Prim_Band_Dump, 2, "DUMP-BAND")
-{ Pointer Combination, Ext_Prims;
+Built_In_Primitive(Prim_Band_Dump, 2, "DUMP-BAND", 0xB7)
+{
+ Pointer Combination, Ext_Prims;
long Arg1Type;
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/fasload.c,v 9.24 1987/04/11 15:16:37 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fasload.c,v 9.25 1987/04/16 02:21:50 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)
-#define print_char(C) printf(((C < ' ') || (C > '|')) ? \
- "\\%03o" : "%c", (C && MAX_CHAR));
-
-Pointer String_To_Symbol();
-
#include "load.c"
\f
-/* Here is a totally randomly constructed string hashing function */
-
-long Do_Hash(String_Ptr, String_Length)
-char *String_Ptr;
-long String_Length;
-{ long i, Value, End_Count;
-
- Value = LENGTH_MULTIPLIER*String_Length;
- End_Count = (String_Length > MAX_HASH_CHARS) ?
- MAX_HASH_CHARS : String_Length;
- for (i=0; i < End_Count; i++)
- Value = (Value << SHIFT_AMOUNT) + (MAX_CHAR & String_Ptr[i]);
- if (Intern_Debug)
- { char *C;
- printf(" Hashing: %d: ", String_Length);
- C = String_Ptr;
- for (i=0; i < String_Length; i++, C++)
- print_char(*C);
- printf(" -> 0x%x\n", Value);
- }
- return Value;
-}
-
-Pointer Hash(Ptr)
-Pointer Ptr;
-{ long String_Length;
-
- String_Length = Get_Integer(Fast_Vector_Ref(Ptr, STRING_LENGTH));
- return Make_Non_Pointer(TC_FIXNUM,
- Do_Hash(Scheme_String_To_C_String(Ptr),
- String_Length));
-}
-\f
-Pointer Hash_Chars(Ptr)
-Pointer Ptr;
-{ long Length;
- Pointer This_Char;
- char String[MAX_HASH_CHARS];
-
- Touch_In_Primitive(Ptr, Ptr);
- for (Length=0; Type_Code(Ptr)==TC_LIST; Length++)
- { if (Length < MAX_HASH_CHARS)
- { Touch_In_Primitive(Vector_Ref(Ptr, CONS_CAR), This_Char);
- if (Type_Code(This_Char) != TC_CHARACTER)
- Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- Range_Check(String[Length], This_Char,
- (char) 0, (char) MAX_CHAR, ERR_ARG_1_WRONG_TYPE);
- Touch_In_Primitive(Vector_Ref(Ptr, CONS_CDR), Ptr);
- }
- }
- if (Ptr != NIL) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- return Make_Non_Pointer(TC_FIXNUM, Do_Hash(String, Length));
-}
-\f
-Boolean String_Equal(String1, String2)
-Pointer String1, String2;
-{ char *S1, *S2;
- long Length1, Length2, i;
-
- 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));
- 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;
-}
-
-Pointer Make_String(Orig_List)
-Pointer Orig_List;
-{ char *Next;
- long Length;
- Pointer Result;
-
- Result = Make_Pointer(TC_CHARACTER_STRING, Free);
- Next = (char *) Nth_Vector_Loc(Result, STRING_CHARS);
- Length = 0;
- Touch_In_Primitive(Orig_List, Orig_List);
- while (Type_Code(Orig_List) == TC_LIST)
- { Pointer This_Char;
- long The_Character;
-
- Primitive_GC_If_Needed(Free - ((Pointer *) Next));
- Touch_In_Primitive(Vector_Ref(Orig_List, CONS_CAR), This_Char);
- if (Type_Code(This_Char) != TC_CHARACTER)
- Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- Range_Check(The_Character, This_Char,
- 0, MAX_CHAR, ERR_ARG_1_BAD_RANGE);
- *Next++ = (char) The_Character;
- Touch_In_Primitive(Vector_Ref(Orig_List, CONS_CDR), Orig_List);
- Length += 1;
- }
- if (Orig_List != NIL) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- *Next++ = '\0'; /* Add the null */
- Free += 2 + (Length+sizeof(Pointer))/sizeof(Pointer);
- Vector_Set(Result, STRING_LENGTH, FIXNUM_0+Length);
- Vector_Set(Result, STRING_HEADER,
- Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, (Free-Get_Pointer(Result))-1));
- return Result;
-}
-\f
-/* Interning involves hashing the input string and either returning
- an existing symbol with that name from the ObArray or creating a
- new symbol and installing it in the ObArray. The resulting interned
- symbol is stored in *Un_Interned.
-*/
-
-long Intern(Un_Interned)
-Pointer *Un_Interned;
-{ long Hashed_Value;
- Pointer Ob_Array, *Bucket, String, Temp;
-
- String = Fast_Vector_Ref(*Un_Interned, SYMBOL_NAME);
- Temp = Hash(String);
- Hashed_Value = Get_Integer(Temp);
- Ob_Array = Get_Fixed_Obj_Slot(OBArray);
- Hashed_Value %= Vector_Length(Ob_Array);
- Bucket = Nth_Vector_Loc(Ob_Array, Hashed_Value + 1);
-
- if (Intern_Debug)
- { char *C;
- int i, String_Length;
- String_Length = Get_Integer(Fast_Vector_Ref(String, STRING_LENGTH));
- C = (char *) Nth_Vector_Loc(String, STRING_CHARS);
- printf("\nInterning ");
- for (i=0; i < String_Length; i++, C++) print_char(*C);
- }
-
-/* Intern continues on the next page */
-\f
-/* Intern, continued */
-
- while (*Bucket != NIL)
- { if (Intern_Debug)
- printf(" Bucket #%o (0x%x) ...\n",
- Address(*Bucket), Address(*Bucket));
- if (String_Equal(String,
- Fast_Vector_Ref(
- Vector_Ref(*Bucket, CONS_CAR),
- SYMBOL_NAME)))
- { if (Intern_Debug) printf(" found\n");
- *Un_Interned = Vector_Ref(*Bucket, CONS_CAR);
- return;
- }
- Bucket = Nth_Vector_Loc(*Bucket, CONS_CDR);
- }
-
-/* Symbol does not exist yet in ObArray. Bucket points to the
- cell containing the final #!NULL in the list. Replace this
- with the CONS of the new symbol and #!NULL (i.e. extend the
- list in the bucket by 1 new element).
-*/
-
- Store_Type_Code(*Un_Interned, TC_INTERNED_SYMBOL);
- if (Intern_Debug) printf(" adding at #%o (0x%x)\n",
- (long) Free, (long) Free);
- *Bucket = Make_Pointer(TC_LIST, Free);
- Free[CONS_CAR] = *Un_Interned;
- Free[CONS_CDR] = NIL;
- Free += 2;
-}
-\f
+void
Load_File(Name)
-Pointer Name;
-{ char *Char;
+ Pointer Name;
+{
+ char *Char;
long N, i;
Boolean File_Opened;
- File_Opened = Open_Dump_File(Name, OPEN_FLAG);
- if (Per_File) Handle_Debug_Flags();
- if (!File_Opened) Primitive_Error(ERR_ARG_1_BAD_RANGE);
-/* Load_File continues on next page */
-\f
-/* Load_File, continued */
+ File_Opened = Open_Dump_File(Name, OPEN_FLAG);
+ if (Per_File)
+ Handle_Debug_Flags();
+ if (!File_Opened)
+ Primitive_Error(ERR_ARG_1_BAD_RANGE);
if (!Read_Header())
{ fprintf(stderr,
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,
+
+ {
+ fprintf(stderr,
"\nLoad_File: FASL File Version %4d Subversion %4d Machine Type %4d.\n",
Version, Sub_Version , Machine_Type);
fprintf(stderr,
Primitive_Error(ERR_FASL_FILE_BAD_DATA);
}
if (!Test_Pure_Space_Top(Free_Constant+Const_Count))
- { fclose(File_Handle);
+ {
+ fclose(File_Handle);
Primitive_Error(ERR_FASL_FILE_TOO_BIG);
}
if (GC_Check(Heap_Count))
- { fclose(File_Handle);
+ {
+ fclose(File_Handle);
Request_GC(Heap_Count);
Primitive_Interrupt();
}
Align_Float(Free);
*/
fclose(File_Handle);
+ return;
}
\f
/* Statics used by Relocate, below */
#ifdef ENABLE_DEBUGGING_TOOLS
static Boolean Warned = false;
-Pointer *Relocate(P)
-long P;
-{ Pointer *Result;
+Pointer *
+Relocate(P)
+ long P;
+{
+ Pointer *Result;
+
if ((P >= Heap_Base) && (P < Dumped_Heap_Top))
Result = (Pointer *) (P + Heap_Relocation);
else if ((P >= Const_Base) && (P < Dumped_Constant_Top))
else if (P < Dumped_Stack_Top)
Result = (Pointer *) (P + Stack_Relocation);
else
- { printf("Pointer out of range: 0x%x\n", P, P);
+ {
+ printf("Pointer out of range: 0x%x\n", P, P);
if (!Warned)
- { printf("Heap: %x-%x, Constant: %x-%x, Stack: ?-0x%x\n",
+ {
+ printf("Heap: %x-%x, Constant: %x-%x, Stack: ?-0x%x\n",
Heap_Base, Dumped_Heap_Top,
Const_Base, Dumped_Constant_Top, Dumped_Stack_Top);
Warned = true;
}
Result = (Pointer *) 0;
}
- if (Reloc_Debug) printf("0x%06x -> 0x%06x\n", P, Result);
+ if (Reloc_Debug)
+ printf("0x%06x -> 0x%06x\n", P, Result);
return Result;
}
block of memory.
*/
-long Relocate_Block(Next_Pointer, Stop_At)
-fast Pointer *Next_Pointer, *Stop_At;
-{ if (Reloc_Debug)
+long
+Relocate_Block(Next_Pointer, Stop_At)
+ fast Pointer *Next_Pointer, *Stop_At;
+{
+ 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);
while (Next_Pointer < Stop_At)
- { fast Pointer Temp = *Next_Pointer;
+ {
+ fast Pointer Temp;
+ Temp = *Next_Pointer;
Switch_by_GC_Type(Temp)
{ case TC_BROKEN_HEART:
case TC_MANIFEST_SPECIAL_NM_VECTOR:
case_compiled_entry_point:
/* Compiled entry points work automagically. */
default:
- { fast long Next = Datum(Temp);
+ {
+ fast long Next;
+
+ Next = Datum(Temp);
*Next_Pointer++ = Make_Pointer(Type_Code(Temp), Relocate(Next));
}
}
}
}
\f
+extern void Intern();
+
+void
Intern_Block(Next_Pointer, Stop_At)
-Pointer *Next_Pointer, *Stop_At;
-{ if (Reloc_Debug) printf("Interning a block.\n");
+ Pointer *Next_Pointer, *Stop_At;
+{
+ if (Reloc_Debug)
+ printf("Interning a block.\n");
+
while (Next_Pointer <= Stop_At) /* BBN has < for <= */
- { switch (Type_Code(*Next_Pointer))
+ {
+ switch (Type_Code(*Next_Pointer))
{ case TC_MANIFEST_NM_VECTOR:
Next_Pointer += Get_Integer(*Next_Pointer)+1;
break;
case TC_INTERNED_SYMBOL:
if (Type_Code(Vector_Ref(*Next_Pointer, SYMBOL_GLOBAL_VALUE)) ==
TC_BROKEN_HEART)
- { Pointer Old_Symbol = *Next_Pointer;
+ {
+ 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,
+ {
+ 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 =
+ {
+ *Next_Pointer =
Make_New_Pointer(Type_Code(*Next_Pointer),
Fast_Vector_Ref(*Next_Pointer,
SYMBOL_NAME));
default: Next_Pointer += 1;
}
}
- if (Reloc_Debug) printf("Done interning block.\n");
+ if (Reloc_Debug)
+ printf("Done interning block.\n");
return;
}
\f
is ignored and a completely new one will be built.
*/
+void
Install_Ext_Prims(Normal_FASLoad)
-Boolean Normal_FASLoad;
-{ long i;
+ 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++);
+ 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;
-{ for ( ; Next_Pointer < Stop_At; Next_Pointer++)
+ 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 = Address(*Next_Pointer);
+ {
+ long Which;
+
+ Which = Address(*Next_Pointer);
+
if (Which > Ext_Prim_Count)
- printf("External Primitive 0x%x out of range.\n", Which);
+ fprintf(stderr, "\nExternal Primitive 0x%x out of range.\n", Which);
else
- { Pointer New_Value = User_Vector_Ref(Ext_Prim_Vector, Which);
+ {
+ Pointer New_Value;
+
+ New_Value = User_Vector_Ref(Ext_Prim_Vector, Which);
if (Type_Code(New_Value) == TC_INTERNED_SYMBOL)
- { New_Value = (Pointer) Get_Ext_Number(New_Value, TRUTH);
+ {
+ New_Value = ((Pointer) make_external_primitive(New_Value, TRUTH));
User_Vector_Set(Ext_Prim_Vector, Which, New_Value);
}
Store_Address(*Next_Pointer, New_Value);
default: break;
}
}
+ return;
}
\f
-Pointer Fasload(FileName, Not_From_Band_Load)
-Pointer FileName;
-Boolean Not_From_Band_Load;
-{ Pointer *Heap_End, *Constant_End, *Orig_Heap, *Orig_Constant, *Xtemp;
+Pointer
+Fasload(FileName, Not_From_Band_Load)
+ Pointer FileName;
+ Boolean Not_From_Band_Load;
+{
+ Pointer *Heap_End, *Constant_End, *Orig_Heap, *Orig_Constant, *Xtemp;
#ifdef ENABLE_DEBUGGING_TOOLS
Warned = false;
#ifdef BYTE_INVERSION
Finish_String_Inversion();
#endif
-
-/* Fasload continues on the next page */
\f
-/* Fasload, continued */
-
- /* Intern */
-
if (Not_From_Band_Load)
- { Intern_Block(Orig_Constant, Constant_End);
+ {
+ Intern_Block(Orig_Constant, Constant_End);
Intern_Block(Orig_Heap, Heap_End);
}
/* Update External Primitives */
if ((Ext_Prim_Vector != NIL) && Found_Ext_Prims)
- { Relocate_Into(Xtemp, Address(Ext_Prim_Vector));
+ {
+ Relocate_Into(Xtemp, Address(Ext_Prim_Vector));
Ext_Prim_Vector = *Xtemp;
Ext_Prim_Count = Vector_Length(Ext_Prim_Vector);
Install_Ext_Prims(Not_From_Band_Load);
}
\f
/* (BINARY-FASLOAD FILE-NAME)
- [Primitive number 0x57]
Load the contents of FILE-NAME into memory. The file was
- presumably made by a call to PRIMITIVE_FASDUMP, and may contain
+ presumably made by a call to PRIMITIVE-FASDUMP, and may contain
data for the heap and/or the pure area. The value returned is
the object which was dumped. Typically (but not always) this
will be a piece of SCode which is then evaluated to perform
definitions in some environment.
*/
-Built_In_Primitive(Prim_Binary_Fasload, 1, "BINARY-FASLOAD")
-{ /* The code for Fasload, which does all the work, is found in the
- file FASLOAD.C
- */
+Built_In_Primitive(Prim_Binary_Fasload, 1, "BINARY-FASLOAD", 0x57)
+{
Primitive_1_Arg();
return Fasload(Arg1, true);
}
Returns the filename (as a Scheme string) from which the runtime system
was band loaded (load-band'ed ?), or NIL if the system was fasl'ed.
*/
-Built_In_Primitive(Prim_reload_band_name, 0, "RELOAD-BAND-NAME")
+Built_In_Primitive(Prim_reload_band_name, 0, "RELOAD-BAND-NAME", 0x1A3)
{
Primitive_0_Args();
which is typically a file created by DUMP-BAND. The file can,
however, be any file which can be loaded with BINARY-FASLOAD.
*/
-Built_In_Primitive(Prim_Band_Load, 1, "LOAD-BAND")
-{ Pointer Save_FO, *Save_Free, *Save_Free_Constant, Save_Undefined,
- *Save_Stack_Pointer, *Save_Stack_Guard, Result;
+Built_In_Primitive(Prim_Band_Load, 1, "LOAD-BAND", 0xB9)
+{
+ Pointer Save_FO, *Save_Free, *Save_Free_Constant,
+ Save_Undefined, *Save_Stack_Pointer,
+ *Save_Stack_Guard, Result;
+
long Jump_Value;
jmp_buf Swapped_Buf, *Saved_Buf;
Pointer scheme_band_name;
}
}
\f
-/* (CHARACTER-LIST-HASH LIST)
- [Primitive number 0x65]
- Takes a list of ASCII codes for characters and returns a hash
- code for them. This uses the hashing function used to intern
- symbols in Fasload, and is really intended only for that
- purpose.
-*/
-Built_In_Primitive(Prim_Character_List_Hash, 1, "CHARACTER-LIST-HASH")
-{ /* The work is done in Hash_Chars.
- A gross breach of modularity allows Hash_Chars to do the argument
- type checking.
- */
- Primitive_1_Arg();
- return Hash_Chars(Arg1);
-}
-\f
-/* (INTERN-CHARACTER-LIST LIST)
- [Primitive number 0xAB]
- LIST should consist of the ASCII codes for characters. Returns
- a new (interned) symbol made out of these characters. Notice
- that this is a fairly low-level primitive, and no checking is
- done on the characters except that they are in the range 0 to
- 255. Thus non-printing, lower-case, and special characters can
- be put into symbols this way.
-*/
-Built_In_Primitive(Prim_Intern_Character_List, 1, "INTERN-CHARACTER-LIST")
-{ Primitive_1_Arg();
- return String_To_Symbol(Make_String(Arg1));
-}
-
-/* (SYMBOL->STRING STRING)
- [Primitive number 0x07]
- Similar to INTERN-CHARACTER-LIST, except this one takes a string
- instead of a list of ascii values as argument.
- */
-Built_In_Primitive(Prim_String_To_Symbol, 1, "STRING->SYMBOL")
-{ Primitive_1_Arg();
- Arg_1_Type(TC_CHARACTER_STRING);
- return String_To_Symbol(Arg1);
-}
-
-Pointer String_To_Symbol(String)
-Pointer String;
-{ Pointer New_Symbol, Interned_Symbol, *Orig_Free;
- Orig_Free = Free;
- New_Symbol = Make_Pointer(TC_UNINTERNED_SYMBOL, Free);
- Free[SYMBOL_NAME] = String;
- Free[SYMBOL_GLOBAL_VALUE] = UNBOUND_OBJECT;
- Free += 2;
- Interned_Symbol = New_Symbol;
- /* The work is done by Intern which returns in Interned_Symbol
- either the same symbol we gave it (in which case we need to check
- for GC) or an existing symbol (in which case we have to release
- the heap space acquired to hold New_Symbol).
- */
- Intern(&Interned_Symbol);
- if (Address(Interned_Symbol) == Address(New_Symbol))
- { Primitive_GC_If_Needed(0);
- }
- else Free = Orig_Free;
- return Interned_Symbol;
-}
-\f
#ifdef BYTE_INVERSION
-#define MAGIC_OFFSET TC_FIXNUM+1
+#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;
+{
+ if (!Byte_Invert_Fasl_Files)
+ return;
String_Chain = NIL;
Last_String = NIL;
}
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, FIXNUM_0+Count);
+ Fast_Vector_Set(String_Chain, STRING_LENGTH, Make_Unsigned_Fixnum(Count));
String_Chain = Next;
}
}
\f
+#define print_char(C) printf(((C < ' ') || (C > '|')) ? \
+ "\\%03o" : "%c", (C && MAX_CHAR));
+
String_Inversion(Orig_Pointer)
Pointer *Orig_Pointer;
{ Pointer *Pointer_Address;
}
if (Reloc_Debug) printf("\n");
}
-#endif
-
+#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/fixnum.c,v 9.21 1987/01/22 14:25:24 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fixnum.c,v 9.22 1987/04/16 02:22:24 jinx Exp $
*
* Support for fixed point arithmetic (24 bit). Mostly superceded
* by generic arithmetic.
return NIL.
*/
-Built_In_Primitive(Prim_One_Plus_Fixnum, 1, "ONE-PLUS-FIXNUM")
-{ fast long A, Result;
+Built_In_Primitive(Prim_One_Plus_Fixnum, 1, "ONE-PLUS-FIXNUM", 0x42)
+{
+ fast long A, Result;
Primitive_1_Arg();
+
Arg_1_Type(TC_FIXNUM);
Sign_Extend(Arg1, A);
Result = A + 1;
- if (Fixnum_Fits(Result)) return Make_Non_Pointer(TC_FIXNUM, Result);
- else return NIL;
+ if (Fixnum_Fits(Result))
+ return Make_Non_Pointer(TC_FIXNUM, Result);
+ else
+ return NIL;
}
-Built_In_Primitive(Prim_M_1_Plus_Fixnum, 1, "MINUS-ONE-PLUS-FIXNUM")
-{ fast long A, Result;
+Built_In_Primitive(Prim_M_1_Plus_Fixnum, 1, "MINUS-ONE-PLUS-FIXNUM", 0x43)
+{
+ fast long A, Result;
Primitive_1_Arg();
+
Arg_1_Type(TC_FIXNUM);
Sign_Extend(Arg1, A);
Result = A - 1;
- if (Fixnum_Fits(Result)) return Make_Non_Pointer(TC_FIXNUM, Result);
- else return NIL;
+ if (Fixnum_Fits(Result))
+ return Make_Non_Pointer(TC_FIXNUM, Result);
+ else
+ return NIL;
}
\f
/****************************/
fixnum, 1 if the predicate is true, or 0 if the predicate is false.
*/
-#define Binary_Predicate_Fixnum(Op) \
- fast long A, B; \
- Primitive_2_Args(); \
- Arg_1_Type(TC_FIXNUM); \
- Arg_2_Type(TC_FIXNUM); \
- Sign_Extend(Arg1, A); Sign_Extend(Arg2, B); \
- return FIXNUM_0+ ((A Op B) ? 1 : 0);
+#define Binary_Predicate_Fixnum(Op) \
+{ \
+ fast long A, B; \
+ Primitive_2_Args(); \
+ \
+ Arg_1_Type(TC_FIXNUM); \
+ Arg_2_Type(TC_FIXNUM); \
+ Sign_Extend(Arg1, A); \
+ Sign_Extend(Arg2, B); \
+ return Make_Unsigned_Fixnum(((A Op B) ? 1 : 0)); \
+}
-Built_In_Primitive(Prim_Equal_Fixnum, 2, "EQUAL-FIXNUM?")
-{ Binary_Predicate_Fixnum(==);
+Built_In_Primitive(Prim_Equal_Fixnum, 2, "EQUAL-FIXNUM?", 0x3F)
+{
+ Binary_Predicate_Fixnum(==);
}
-Built_In_Primitive(Prim_Greater_Fixnum, 2, "LESS-FIXNUM?")
-{ Binary_Predicate_Fixnum(>);
+Built_In_Primitive(Prim_Greater_Fixnum, 2, "LESS-THAN-FIXNUM?", 0x40)
+{
+ Binary_Predicate_Fixnum(>);
}
-Built_In_Primitive(Prim_Less_Fixnum, 2, "GREATER-FIXNUM?")
-{ Binary_Predicate_Fixnum(<);
+Built_In_Primitive(Prim_Less_Fixnum, 2, "GREATER-THAN-FIXNUM?", 0x81)
+{
+ Binary_Predicate_Fixnum(<);
}
\f
/****************************/
result will not fit as a fixnum, NIL is returned.
*/
-#define Binary_Fixnum(Op) \
- fast long A, B, Result; \
- Primitive_2_Args(); \
- Arg_1_Type(TC_FIXNUM); \
- Arg_2_Type(TC_FIXNUM); \
- Sign_Extend(Arg1, A); Sign_Extend(Arg2, B); \
- Result = A Op B; \
- if (Fixnum_Fits(Result)) \
- return Make_Non_Pointer(TC_FIXNUM, Result); \
- else return NIL; \
-
-Built_In_Primitive(Prim_Minus_Fixnum, 2, "MINUS-FIXNUM")
-{ Binary_Fixnum(-);
+#define Binary_Fixnum(Op) \
+{ \
+ fast long A, B, Result; \
+ Primitive_2_Args(); \
+ \
+ Arg_1_Type(TC_FIXNUM); \
+ Arg_2_Type(TC_FIXNUM); \
+ Sign_Extend(Arg1, A); \
+ Sign_Extend(Arg2, B); \
+ Result = A Op B; \
+ if (Fixnum_Fits(Result)) \
+ return Make_Non_Pointer(TC_FIXNUM, Result); \
+ else \
+ return NIL; \
}
-Built_In_Primitive(Prim_Plus_Fixnum, 2, "PLUS-FIXNUM")
-{ Binary_Fixnum(+);
+Built_In_Primitive(Prim_Plus_Fixnum, 2, "PLUS-FIXNUM", 0x3B)
+{
+ Binary_Fixnum(+);
}
-Built_In_Primitive(Prim_Multiply_Fixnum, 2, "MULTIPLY-FIXNUM")
-{ /* Mul, which does the multiplication with overflow handling is
- machine dependent. Therefore, it is in OS.C
+Built_In_Primitive(Prim_Minus_Fixnum, 2, "MINUS-FIXNUM", 0x3C)
+{
+ Binary_Fixnum(-);
+}
+
+Built_In_Primitive(Prim_Multiply_Fixnum, 2, "MULTIPLY-FIXNUM", 0x3D)
+{
+ /* Mul, which does the multiplication with overflow handling is
+ machine dependent. Therefore, it is in os.c
*/
+ extern Pointer Mul();
Primitive_2_Args();
+
Arg_1_Type(TC_FIXNUM);
Arg_2_Type(TC_FIXNUM);
return Mul(Arg1, Arg2);
}
\f
-Built_In_Primitive(Prim_Divide_Fixnum, 2, "DIVIDE-FIXNUM")
-{ fast long A, B, Quotient, Remainder;
+Built_In_Primitive(Prim_Divide_Fixnum, 2, "DIVIDE-FIXNUM", 0x3E)
+{
+
/* Returns the CONS of quotient and remainder */
+ fast long A, B, Quotient, Remainder;
Primitive_2_Args();
+
Arg_1_Type(TC_FIXNUM);
Arg_2_Type(TC_FIXNUM);
Sign_Extend(Arg1, A); Sign_Extend(Arg2, B);
- if (B==0) Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ if (B == 0)
+ Primitive_Error(ERR_ARG_2_BAD_RANGE);
Primitive_GC_If_Needed(2);
Quotient = A/B;
Remainder = A%B;
return NIL;
}
-Built_In_Primitive(Prim_Gcd_Fixnum, 2, "GCD-FIXNUM")
-{ fast long A, B, C;
+Built_In_Primitive(Prim_Gcd_Fixnum, 2, "GCD-FIXNUM", 0x66)
+{
/* Returns the Greatest Common Divisor */
+ fast long A, B, C;
Primitive_2_Args();
+
Arg_1_Type(TC_FIXNUM);
Arg_2_Type(TC_FIXNUM);
Sign_Extend(Arg1, A); Sign_Extend(Arg2, B);
return Make_Non_Pointer(TC_FIXNUM, A);
}
\f
-/* (NEGATIVE_FIXNUM NUMBER)
- [Primitive number 0x7F]
+/* (NEGATIVE-FIXNUM? NUMBER)
Returns NIL if NUMBER isn't a fixnum. Returns 0 if NUMBER < 0, 1
if NUMBER >= 0.
*/
-Built_In_Primitive(Prim_Negative_Fixnum, 1, "NEGATIVE-FIXNUM?")
-{ long Value;
+Built_In_Primitive(Prim_Negative_Fixnum, 1, "NEGATIVE-FIXNUM?", 0x7F)
+{
+ long Value;
Primitive_1_Arg();
+
Arg_1_Type(TC_FIXNUM);
Sign_Extend(Arg1, Value);
- return FIXNUM_0 + ((Value < 0) ? 1 : 0);
+ return Make_Unsigned_Fixnum(((Value < 0) ? 1 : 0));
}
-/* (POSITIVE_FIXNUM NUMBER)
- [Primitive number 0x41]
+/* (POSITIVE-FIXNUM? NUMBER)
Returns 1 if NUMBER is a positive fixnum, 0 for other fixnums,
or NIL.
*/
-Built_In_Primitive(Prim_Positive_Fixnum, 1, "POSITIVE-FIXNUM?")
-{ long Value;
+Built_In_Primitive(Prim_Positive_Fixnum, 1, "POSITIVE-FIXNUM?", 0x41)
+{
+ long Value;
Primitive_1_Arg();
+
Arg_1_Type(TC_FIXNUM);
Sign_Extend(Arg1, Value);
- return FIXNUM_0 + ((Value > 0) ? 1 : 0);
+ return Make_Unsigned_Fixnum(((Value > 0) ? 1 : 0));
}
-/* (ZERO_FIXNUM NUMBER)
- [Primitive number 0x46]
+/* (ZERO-FIXNUM? NUMBER)
Returns NIL if NUMBER isn't a fixnum. Otherwise, returns 0 if
NUMBER is 0 or 1 if it is.
*/
-Built_In_Primitive(Prim_Zero_Fixnum, 1, "ZERO-FIXNUM?")
-{ Primitive_1_Arg();
+Built_In_Primitive(Prim_Zero_Fixnum, 1, "ZERO-FIXNUM?", 0x46)
+{
+ Primitive_1_Arg();
+
Arg_1_Type(TC_FIXNUM);
- return FIXNUM_0+((Get_Integer(Arg1) == 0) ? 1 : 0);
+ return Make_Unsigned_Fixnum(((Get_Integer(Arg1) == 0) ? 1 : 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/flonum.c,v 9.21 1987/01/22 14:25:41 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/flonum.c,v 9.22 1987/04/16 02:22:34 jinx Rel $
*
* This file contains support for floating point arithmetic. Most
* of these primitives have been superceded by generic arithmetic.
*/
-\f
+
#include "scheme.h"
#include "primitive.h"
#include "flonum.h"
#include "zones.h"
-
+\f
/************************************/
/* BINARY FLOATING POINT OPERATIONS */
/************************************/
-/* See flohead.c for floating point macros. */
-
/* The binary floating point operations return NIL if either argument
is not a floating point number. Otherwise they return the
appropriate result.
*/
-Built_In_Primitive(Prim_Divide_Flonum, 2, "DIVIDE-FLONUM")
-{ Primitive_2_Args();
+Built_In_Primitive(Prim_Plus_Flonum, 2, "PLUS-FLONUM", 0x69)
+{
+ Primitive_2_Args();
+
Arg_1_Type(TC_BIG_FLONUM);
Arg_2_Type(TC_BIG_FLONUM);
Set_Time_Zone(Zone_Math);
- if (Get_Float(Arg2) == 0) Primitive_Error(ERR_ARG_2_BAD_RANGE);
- Flonum_Result(Get_Float(Arg1) / Get_Float(Arg2));
+ Flonum_Result(Get_Float(Arg1) + Get_Float(Arg2));
}
-\f
-Built_In_Primitive(Prim_Minus_Flonum, 2, "MINUS-FLONUM")
-{ Primitive_2_Args();
+
+Built_In_Primitive(Prim_Minus_Flonum, 2, "MINUS-FLONUM", 0x6A)
+{
+ Primitive_2_Args();
+
Arg_1_Type(TC_BIG_FLONUM);
Arg_2_Type(TC_BIG_FLONUM);
Set_Time_Zone(Zone_Math);
Flonum_Result(Get_Float(Arg1) - Get_Float(Arg2));
}
-Built_In_Primitive(Prim_Multiply_Flonum, 2, "MULTIPLY-FLONUM")
-{ Primitive_2_Args();
+Built_In_Primitive(Prim_Multiply_Flonum, 2, "MULTIPLY-FLONUM", 0x6B)
+{
+ Primitive_2_Args();
+
Arg_1_Type(TC_BIG_FLONUM);
Arg_2_Type(TC_BIG_FLONUM);
Set_Time_Zone(Zone_Math);
Flonum_Result(Get_Float(Arg1) * Get_Float(Arg2));
}
-Built_In_Primitive(Prim_Plus_Flonum, 2, "PLUS-FLONUM")
-{ Primitive_2_Args();
+Built_In_Primitive(Prim_Divide_Flonum, 2, "DIVIDE-FLONUM", 0x6C)
+{
+ Primitive_2_Args();
+
Arg_1_Type(TC_BIG_FLONUM);
Arg_2_Type(TC_BIG_FLONUM);
Set_Time_Zone(Zone_Math);
- Flonum_Result(Get_Float(Arg1) + Get_Float(Arg2));
+ if (Get_Float(Arg2) == 0)
+ Primitive_Error(ERR_ARG_2_BAD_RANGE);
+ Flonum_Result(Get_Float(Arg1) / Get_Float(Arg2));
}
\f
/************************************/
true, or a fixnum 0 if it is false.
*/
-Built_In_Primitive(Prim_Equal_Flonum, 2, "EQUAL-FLONUM?")
-{ Primitive_2_Args();
+Built_In_Primitive(Prim_Equal_Flonum, 2, "EQUAL-FLONUM?", 0x6D)
+{
+ Primitive_2_Args();
+
Arg_1_Type(TC_BIG_FLONUM);
Arg_2_Type(TC_BIG_FLONUM);
Set_Time_Zone(Zone_Math);
- return FIXNUM_0+
- (((Get_Float(Arg1)) == (Get_Float(Arg2))) ? 1 : 0);
+ return
+ Make_Unsigned_Fixnum(((Get_Float(Arg1)) == (Get_Float(Arg2))) ? 1 : 0);
}
-Built_In_Primitive(Prim_Greater_Flonum, 2, "GREATER-FLONUM?")
-{ Primitive_2_Args();
+Built_In_Primitive(Prim_Greater_Flonum, 2, "GREATER-THAN-FLONUM?", 0xAA)
+{
+ Primitive_2_Args();
+
Arg_1_Type(TC_BIG_FLONUM);
Arg_2_Type(TC_BIG_FLONUM);
Set_Time_Zone(Zone_Math);
- return FIXNUM_0+
- (((Get_Float(Arg1)) > (Get_Float(Arg2))) ? 1 : 0);
+ return
+ Make_Unsigned_Fixnum(((Get_Float(Arg1)) > (Get_Float(Arg2))) ? 1 : 0);
}
-Built_In_Primitive(Prim_Less_Flonum, 2, "LESS-FLONUM?")
-{ Primitive_2_Args();
+Built_In_Primitive(Prim_Less_Flonum, 2, "LESS-THAN-FLONUM?", 0x6E)
+{
+ Primitive_2_Args();
+
Arg_1_Type(TC_BIG_FLONUM);
Arg_2_Type(TC_BIG_FLONUM);
Set_Time_Zone(Zone_Math);
- return FIXNUM_0+(((Get_Float(Arg1)) < (Get_Float(Arg2))) ? 1 : 0);
+ return
+ Make_Unsigned_Fixnum(((Get_Float(Arg1)) < (Get_Float(Arg2))) ? 1 : 0);
}
\f
/***********************************/
not a flonum. Otherwise, they return the appropriate result.
*/
-Built_In_Primitive(Prim_Arctan_Flonum, 1, "ARCTAN-FLONUM")
-{ double atan();
+Built_In_Primitive(Prim_Sine_Flonum, 1, "SINE-FLONUM", 0x73)
+{
+ extern double sin();
Primitive_1_Arg();
+
Arg_1_Type(TC_BIG_FLONUM);
Set_Time_Zone(Zone_Math);
- Flonum_Result(atan(Get_Float(Arg1)));
+ Flonum_Result(sin(Get_Float(Arg1)));
}
-Built_In_Primitive(Prim_Cosine_Flonum, 1, "COSINE-FLONUM")
-{ double cos();
+Built_In_Primitive(Prim_Cosine_Flonum, 1, "COSINE-FLONUM", 0x74)
+{
+ extern double cos();
Primitive_1_Arg();
+
Arg_1_Type(TC_BIG_FLONUM);
Set_Time_Zone(Zone_Math);
Flonum_Result(cos(Get_Float(Arg1)));
}
-Built_In_Primitive(Prim_Exp_Flonum, 1, "EXP-FLONUM")
-{ double exp();
+Built_In_Primitive(Prim_Arctan_Flonum, 1, "ARCTAN-FLONUM", 0x75)
+{
+ extern double atan();
Primitive_1_Arg();
+
Arg_1_Type(TC_BIG_FLONUM);
Set_Time_Zone(Zone_Math);
- Flonum_Result(exp(Get_Float(Arg1)));
+ Flonum_Result(atan(Get_Float(Arg1)));
}
\f
-Built_In_Primitive(Prim_Ln_Flonum, 1, "LN-FLONUM")
-{ double log();
+Built_In_Primitive(Prim_Exp_Flonum, 1, "EXP-FLONUM", 0x76)
+{
+ extern double exp();
Primitive_1_Arg();
+
Arg_1_Type(TC_BIG_FLONUM);
Set_Time_Zone(Zone_Math);
- if (Arg1 <= 0.0)
- Primitive_Error(ERR_ARG_1_BAD_RANGE);
- Flonum_Result(log(Get_Float(Arg1)));
+ Flonum_Result(exp(Get_Float(Arg1)));
}
-Built_In_Primitive(Prim_Sine_Flonum, 1, "SINE-FLONUM")
-{ double sin();
+Built_In_Primitive(Prim_Ln_Flonum, 1, "LN-FLONUM", 0x77)
+{
+ extern double log();
Primitive_1_Arg();
+
Arg_1_Type(TC_BIG_FLONUM);
Set_Time_Zone(Zone_Math);
- Flonum_Result(sin(Get_Float(Arg1)));
+ if (Arg1 <= 0.0)
+ Primitive_Error(ERR_ARG_1_BAD_RANGE);
+ Flonum_Result(log(Get_Float(Arg1)));
}
-\f
-Built_In_Primitive(Prim_Sqrt_Flonum, 1, "SQRT-FLONUM")
-{ double sqrt(), Arg;
+
+Built_In_Primitive(Prim_Sqrt_Flonum, 1, "SQRT-FLONUM", 0x78)
+{
+ extern double sqrt();
+ double Arg;
Primitive_1_Arg();
+
Arg_1_Type(TC_BIG_FLONUM);
Set_Time_Zone(Zone_Math);
Arg = Get_Float(Arg1);
- if (Arg < 0) return NIL;
+ if (Arg < 0)
+ return NIL;
Flonum_Result(sqrt(Arg));
}
+\f
+Built_In_Primitive(Prim_Zero_Flonum, 1, "ZERO-FLONUM?", 0xA7)
+{
+ Primitive_1_Arg();
-Built_In_Primitive(Prim_Negative_Flonum, 1, "NEGATIVE-FLONUM?")
-{ Primitive_1_Arg();
Arg_1_Type(TC_BIG_FLONUM);
Set_Time_Zone(Zone_Math);
- return FIXNUM_0+ ((Get_Float(Arg1) < 0.0) ? 1 : 0);
+ return Make_Unsigned_Fixnum((Get_Float(Arg1) == 0.0) ? 1 : 0);
}
-Built_In_Primitive(Prim_Positive_Flonum, 1, "POSITIVE-FLONUM?")
-{ Primitive_1_Arg();
+Built_In_Primitive(Prim_Positive_Flonum, 1, "POSITIVE-FLONUM?", 0xA8)
+{
+ Primitive_1_Arg();
+
Arg_1_Type(TC_BIG_FLONUM);
Set_Time_Zone(Zone_Math);
- return FIXNUM_0+ ((Get_Float(Arg1) > 0.0) ? 1 : 0);
+ return Make_Unsigned_Fixnum((Get_Float(Arg1) > 0.0) ? 1 : 0);
}
-Built_In_Primitive(Prim_Zero_Flonum, 1, "ZERO-FLONUM?")
-{ Primitive_1_Arg();
+Built_In_Primitive(Prim_Negative_Flonum, 1, "NEGATIVE-FLONUM?", 0xA9)
+{
+ Primitive_1_Arg();
+
Arg_1_Type(TC_BIG_FLONUM);
Set_Time_Zone(Zone_Math);
- return FIXNUM_0+ ((Get_Float(Arg1) == 0.0) ? 1 : 0);
+ return Make_Unsigned_Fixnum((Get_Float(Arg1) < 0.0) ? 1 : 0);
}
\f
-/* (INT_TO_FLOAT FIXNUM-OR-BIGNUM)
- [Primitive number 0x72]
+/* (COERCE-INTEGER-TO-FLONUM FIXNUM-OR-BIGNUM)
Returns the floating point number (flonum) corresponding to
either a bignum or a fixnum. If the bignum is too large or small
to be converted to floating point, or if the argument isn't of
the correct type, FIXNUM-OR-BIGNUM is returned unchanged.
*/
-Built_In_Primitive(Prim_Int_To_Float, 1, "INT->FLOAT")
-{ Primitive_1_Arg();
+Built_In_Primitive(Prim_Int_To_Float, 1, "COERCE-INTEGER-TO-FLONUM", 0x72)
+{
+ Primitive_1_Arg();
+
Set_Time_Zone(Zone_Math);
if (Type_Code(Arg1)==TC_FIXNUM)
- { long Int;
+ {
+ long Int;
+
Sign_Extend(Arg1, Int);
return Allocate_Float((double) Int);
}
- if (Type_Code(Arg1)==TC_BIG_FIXNUM) return Big_To_Float(Arg1);
+ if (Type_Code(Arg1) == TC_BIG_FIXNUM)
+ return Big_To_Float(Arg1);
return Arg1;
}
\f
-/* (ROUND_FLONUM FLONUM)
- [Primitive number 0x71]
- Returns the integer found by rounding off FLONUM (upward), if
- FLONUM is a floating point number. Otherwise returns FLONUM.
+/* (TRUNCATE-FLONUM FLONUM)
+ Returns the integer corresponding to FLONUM when truncated.
+ Returns NIL if FLONUM isn't a floating point number
*/
-Built_In_Primitive(Prim_Round_Flonum, 1, "ROUND-FLONUM")
-{ fast double A;
+Built_In_Primitive(Prim_Truncate_Flonum, 1, "TRUNCATE-FLONUM", 0x70)
+{
+ fast double A;
long Answer; /* Faulty VAX/UNIX C optimizer */
Primitive_1_Arg();
+
+ Arg_1_Type(TC_BIG_FLONUM);
Set_Time_Zone(Zone_Math);
- if (Type_Code(Arg1) != TC_BIG_FLONUM) return Arg1;
A = Get_Float(Arg1);
- if (A >= 0) A += 0.5; else A -= 0.5;
- if (flonum_exceeds_fixnum(A)) return Float_To_Big(A);
+ if (flonum_exceeds_fixnum(A))
+ return Float_To_Big(A);
Answer = (long) A;
return Make_Non_Pointer(TC_FIXNUM, Answer);
}
-\f
-/* (TRUNCATE_FLONUM FLONUM)
- [Primitive number 0x70]
- Returns the integer corresponding to FLONUM when truncated.
- Returns NIL if FLONUM isn't a floating point number
+
+/* (ROUND-FLONUM FLONUM)
+ Returns the integer found by rounding off FLONUM (upward), if
+ FLONUM is a floating point number. Otherwise returns FLONUM.
*/
-Built_In_Primitive(Prim_Truncate_Flonum, 1, "TRUNCATE-FLONUM")
-{ fast double A;
+Built_In_Primitive(Prim_Round_Flonum, 1, "ROUND-FLONUM", 0x71)
+{
+ fast double A;
long Answer; /* Faulty VAX/UNIX C optimizer */
Primitive_1_Arg();
- Arg_1_Type(TC_BIG_FLONUM);
+
Set_Time_Zone(Zone_Math);
+ if (Type_Code(Arg1) != TC_BIG_FLONUM) return Arg1;
A = Get_Float(Arg1);
- if (flonum_exceeds_fixnum(A)) return Float_To_Big(A);
+ if (A >= 0)
+ A += 0.5;
+ else
+ A -= 0.5;
+ if (flonum_exceeds_fixnum(A))
+ return Float_To_Big(A);
Answer = (long) A;
return Make_Non_Pointer(TC_FIXNUM, Answer);
}
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.21 1987/01/22 14:25:56 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/future.c,v 9.22 1987/04/16 02:22:53 jinx Exp $
Support code for futures
*/
*/
{ Primitive_1_Arg();
Arg_1_Type(TC_FUTURE);
- return FIXNUM_0+Vector_Length(Arg1);
+ return Make_Unsigned_Fixnum(Vector_Length(Arg1));
}
Define_Primitive(Prim_Lock_Future, 1, "LOCK-FUTURE!")
IO_String=Make_Pointer(TC_CHARACTER_STRING,Free);
*Free++=Make_Non_Pointer(TC_MANIFEST_NM_VECTOR,1);
- *Free++=FIXNUM_0;
+ *Free++=Make_Unsigned_Fixnum(0);
IO_Cons=Make_Pointer(TC_LIST,Free);
- *Free++=FIXNUM_0;
+ *Free++=Make_Unsigned_Fixnum(0);
*Free++=IO_String;
IO_Hunk3=Make_Pointer(TC_HUNK3,Free);
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/gccode.h,v 9.22 1987/04/03 00:13:28 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/gccode.h,v 9.23 1987/04/16 02:23:06 jinx Exp $
*
* 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
if (Old >= Low_Constant) \
continue; \
BH_Code; \
-New_Address = (BROKEN_HEART_0 + C_To_Scheme(To)); \
+New_Address = (Make_Broken_Heart(C_To_Scheme(To))); \
Extra_Code; \
continue
#ifdef FLOATING_ALIGNMENT
#define Transport_Flonum() \
Align_Float(To); \
- New_Address = (BROKEN_HEART_0 + C_To_Scheme(To)); \
+ New_Address = (Make_Broken_Heart(C_To_Scheme(To))); \
Real_Transport_Vector(); \
Pointer_End()
#endif
*/
+extern Pointer Weak_Chain;
+
#define Transport_Weak_Cons() \
{ long Car_Type = Type_Code(*Old); \
*To++ = Make_New_Pointer(TC_NULL, *Old); \
#define Fasdump_Setup_Pointer(Extra_Code, BH_Code) \
BH_Code; \
/* It must be transported to New Space */ \
-New_Address = (BROKEN_HEART_0 + C_To_Scheme(To)); \
+New_Address = (Make_Broken_Heart(C_To_Scheme(To))); \
if ((Fixes - To) < FASDUMP_FIX_BUFFER) \
{ NewFree = To; \
Fixup = Fixes; \
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.21 1987/01/22 14:26:43 jinx Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/generic.c,v 9.22 1987/04/16 02:23:19 jinx Rel $ */
#include "scheme.h"
#include "primitive.h"
#include "flonum.h"
#include "zones.h"
\f
-Pointer C_Integer_To_Scheme_Integer(C)
-long C;
-{ fast bigdigit *Answer, *SCAN, *size;
+Built_In_Primitive(Prim_Zero, 1, "ZERO?", 0xE6)
+{
+ Primitive_1_Arg();
+
+ Set_Time_Zone(Zone_Math);
+ switch (Type_Code(Arg1))
+ { case TC_FIXNUM: if (Get_Integer(Arg1) == 0) return TRUTH;
+ else return NIL;
+ case TC_BIG_FLONUM: if (Get_Float(Arg1) == 0.0) return TRUTH;
+ else return NIL;
+ case TC_BIG_FIXNUM: if (ZERO_BIGNUM(Fetch_Bignum(Arg1))) return TRUTH;
+ else return NIL;
+ default: Primitive_Error(ERR_ARG_1_WRONG_TYPE);
+ }
+ /*NOTREACHED*/
+}
+
+Pointer
+C_Integer_To_Scheme_Integer(C)
+ long C;
+{
+ fast bigdigit *Answer, *SCAN, *size;
long Length;
+
if (Fixnum_Fits(C))
return Make_Non_Pointer(TC_FIXNUM, C);
Length = Align(C_INTEGER_LENGTH_AS_BIGNUM);
Answer = BIGNUM(Free);
Prepare_Header(Answer, 0, (C >= 0) ? POSITIVE : NEGATIVE);
size = &LEN(Answer);
- if (C < 0) C = - C;
+ if (C < 0)
+ C = - C;
for (SCAN = Bignum_Bottom(Answer); C != 0; *size += 1)
- { *SCAN++ = Rem_Radix(C);
- C = Div_Radix(C);
+ {
+ *SCAN++ = Rem_Radix(C);
+ C = Div_Radix(C);
}
*((Pointer *) Answer) = Make_Header(Align(*size));
- Free += Length;
+ Free += Length;
Debug_Test(Free-Length);
return Make_Pointer(TC_BIG_FIXNUM, Free-Length);
}
-
-int Scheme_Integer_To_C_Integer(Arg1, C)
-Pointer Arg1;
-long *C;
-{ int type = Type_Code(Arg1);
+\f
+int
+Scheme_Integer_To_C_Integer(Arg1, C)
+ Pointer Arg1;
+ long *C;
+{
+ int type = Type_Code(Arg1);
fast bigdigit *SCAN, *ARG1;
fast long Answer, i;
long Length;
+
if (type == TC_FIXNUM)
- { Sign_Extend(Arg1, *C);
- return PRIM_DONE;
- }
- if (type != TC_BIG_FIXNUM) return ERR_ARG_1_WRONG_TYPE;
+ {
+ Sign_Extend(Arg1, *C);
+ return PRIM_DONE;
+ }
+ if (type != TC_BIG_FIXNUM)
+ return ERR_ARG_1_WRONG_TYPE;
ARG1 = BIGNUM(Get_Pointer(Arg1));
Length = LEN(ARG1);
- if (Length==0) Answer = 0;
+ if (Length == 0)
+ Answer = 0;
else if (Length > C_INTEGER_LENGTH_AS_BIGNUM)
return ERR_ARG_1_BAD_RANGE;
else if (Length < C_INTEGER_LENGTH_AS_BIGNUM)
for (SCAN=Bignum_Top(ARG1), i=0, Answer=0; i< Length; i++)
/* Attempting to take care of overflow problems */
{ Answer = Mul_Radix(Answer);
- if (Answer < 0) return ERR_ARG_1_BAD_RANGE;
+ if (Answer < 0)
+ return ERR_ARG_1_BAD_RANGE;
Answer = Answer + *SCAN--;
- if (Answer < 0) return ERR_ARG_1_BAD_RANGE;
+ if (Answer < 0)
+ return ERR_ARG_1_BAD_RANGE;
}
- if NEG_BIGNUM(ARG1) Answer = - Answer;
+ if NEG_BIGNUM(ARG1)
+ Answer = - Answer;
*C = Answer;
return PRIM_DONE;
}
-Pointer Fetch_Bignum_One()
-{ return Get_Fixed_Obj_Slot(Bignum_One);
-}
-
-Built_In_Primitive(Prim_Zero, 1, "ZERO?")
-{ Primitive_1_Arg();
- Set_Time_Zone(Zone_Math);
- switch (Type_Code(Arg1))
- { case TC_FIXNUM: if (Get_Integer(Arg1) == 0) return TRUTH;
- else return NIL;
- case TC_BIG_FLONUM: if (Get_Float(Arg1) == 0.0) return TRUTH;
- else return NIL;
- case TC_BIG_FIXNUM: if (ZERO_BIGNUM(Fetch_Bignum(Arg1))) return TRUTH;
- else return NIL;
- default: Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- } /*NOTREACHED*/
+Pointer
+Fetch_Bignum_One()
+{
+ return Get_Fixed_Obj_Slot(Bignum_One);
}
\f
-#define Sign_Check(C_Name, S_Name, Normal_Op, Big_Op) \
-Built_In_Primitive(C_Name, 1, S_Name) \
-{ Primitive_1_Arg(); \
+#define Sign_Check(Normal_Op, Big_Op) \
+ Primitive_1_Arg(); \
Set_Time_Zone(Zone_Math); \
switch (Type_Code(Arg1)) \
{ case TC_FIXNUM: { long Value; \
else return NIL; \
default: Primitive_Error(ERR_ARG_1_WRONG_TYPE); \
}
-/* } deliberately omitted to make LINT understand about longjmp */
-Sign_Check(Prim_Positive, "POSITIVE?", >, POS_BIGNUM)
-/*NOTREACHED*/ }
-Sign_Check(Prim_Negative, "NEGATIVE?", <, NEG_BIGNUM)
-/*NOTREACHED*/ }
+
+Built_In_Primitive(Prim_Positive, 1, "POSITIVE?", 0xE7)
+{
+ Sign_Check(>, POS_BIGNUM);
+ /*NOTREACHED*/
+}
+
+Built_In_Primitive(Prim_Negative, 1, "NEGATIVE?", 0xE8)
+{
+ Sign_Check(<, NEG_BIGNUM);
+ /*NOTREACHED*/
+}
\f
-#define Inc_Dec(C_Name, S_Name, Normal_Op, Big_Op) \
-Built_In_Primitive(C_Name, 1, S_Name) \
-{ Primitive_1_Arg(); \
+#define Inc_Dec(Normal_Op, Big_Op) \
+ Primitive_1_Arg(); \
Set_Time_Zone(Zone_Math); \
switch (Type_Code(Arg1)) \
{ case TC_FIXNUM: \
} \
default: Primitive_Error(ERR_ARG_1_WRONG_TYPE); \
}
-/* } deliberately omitted to make LINT understand about longjmp */
-Inc_Dec(Prim_One_Plus, "ONE-PLUS", +, plus_signed_bignum)
-/*NOTREACHED*/ }
-Inc_Dec(Prim_M_1_Plus, "MINUS-ONE-PLUS", -, minus_signed_bignum)
-/*NOTREACHED*/ }
+Built_In_Primitive(Prim_One_Plus, 1, "1+", 0xF1)
+{
+ Inc_Dec(+, plus_signed_bignum);
+ /*NOTREACHED*/
+}
+
+Built_In_Primitive(Prim_M_1_Plus, 1, "-1+", 0xF2)
+{
+ Inc_Dec(-, minus_signed_bignum);
+ /*NOTREACHED*/
+}
\f
-#define Two_Op_Comparator(C_Name, S_Name, GENERAL_OP, BIG_OP) \
-Built_In_Primitive(C_Name, 2, S_Name) \
-{ Primitive_2_Args(); \
+#define Two_Op_Comparator(GENERAL_OP, BIG_OP) \
+ Primitive_2_Args(); \
Set_Time_Zone(Zone_Math); \
switch (Type_Code(Arg1)) \
{ case TC_FIXNUM: \
} \
default: Primitive_Error(ERR_ARG_1_WRONG_TYPE); \
}
-/* } deliberately omitted to make LINT understand about longjmp */
-
-Two_Op_Comparator(Prim_Equal_Number, "NUMBER-EQUAL?", ==, EQUAL)
-/*NOTREACHED*/ }
-Two_Op_Comparator(Prim_Less, "NUMBER-LESS?", <, TWO_BIGGER)
-/*NOTREACHED*/ }
-Two_Op_Comparator(Prim_Greater, "NUMBER-GREATER?", >, ONE_BIGGER)
-/*NOTREACHED*/ }
+
+Built_In_Primitive(Prim_Equal_Number, 2, "&=", 0xE9)
+{
+ Two_Op_Comparator(==, EQUAL);
+ /*NOTREACHED*/
+}
+
+Built_In_Primitive(Prim_Less, 2, "&<", 0xEA)
+{
+ Two_Op_Comparator(<, TWO_BIGGER);
+ /*NOTREACHED*/
+}
+
+Built_In_Primitive(Prim_Greater, 2, "&>", 0xEB)
+{
+ Two_Op_Comparator(>, ONE_BIGGER);
+ /*NOTREACHED*/
+}
\f
-#define Two_Op_Operator(C_Name, S_Name, GENERAL_OP, BIG_OP) \
-Built_In_Primitive(C_Name, 2, S_Name) \
-{ Primitive_2_Args(); \
+#define Two_Op_Operator(GENERAL_OP, BIG_OP) \
+ Primitive_2_Args(); \
Set_Time_Zone(Zone_Math); \
switch (Type_Code(Arg1)) \
{ case TC_FIXNUM: \
} \
default: Primitive_Error(ERR_ARG_1_WRONG_TYPE); \
}
-/* } deliberately omitted to make LINT understand about longjmp */
-Two_Op_Operator(Prim_Plus, "PLUS", +, plus_signed_bignum)
-/*NOTREACHED*/ }
-Two_Op_Operator(Prim_Minus, "MINUS", -, minus_signed_bignum)
-/*NOTREACHED*/ }
+Built_In_Primitive(Prim_Plus, 2, "&+", 0xEC)
+{
+ Two_Op_Operator(+, plus_signed_bignum);
+ /*NOTREACHED*/
+}
+
+Built_In_Primitive(Prim_Minus, 2, "&-", 0xED)
+{
+ Two_Op_Operator(-, minus_signed_bignum);
+ /*NOTREACHED*/
+}
\f
-Built_In_Primitive(Prim_Multiply, 2, "MULTIPLY")
-{ Primitive_2_Args();
+Built_In_Primitive(Prim_Multiply, 2, "&*", 0xEE)
+{
+ /* Mul is machine dependent and lives in os.c */
+ extern Pointer Mul();
+ Primitive_2_Args();
+
Set_Time_Zone(Zone_Math);
switch (Type_Code(Arg1))
{ case TC_FIXNUM:
}
default:
Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- } /*NOTREACHED*/
+ }
+ /*NOTREACHED*/
}
case TC_BIG_FLONUM:
{ switch (Type_Code(Arg2))
{ Reduced_Flonum_Result(Get_Float(Arg1) * Get_Float(B));
}
Primitive_Error(ERR_ARG_2_FAILED_COERCION);
- } /*NOTREACHED*/
+ }
+ /*NOTREACHED*/
default:
Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- } /*NOTREACHED*/
+ }
+ /*NOTREACHED*/
}
/* Prim_Multiply continues on the next page */
{ Reduced_Flonum_Result(Get_Float(A) * Get_Float(Arg2));
}
Primitive_Error(ERR_ARG_1_FAILED_COERCION);
- } /*NOTREACHED*/
+ }
+ /*NOTREACHED*/
case TC_BIG_FIXNUM:
{ Pointer Ans;
Bignum_Operation(multiply_signed_bignum(Fetch_Bignum(Arg1),
}
default:
Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- } /*NOTREACHED*/
+ }
+ /*NOTREACHED*/
}
default: Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- } /*NOTREACHED*/
+ }
+ /*NOTREACHED*/
}
\f
-Built_In_Primitive(Prim_Divide, 2, "DIVIDE")
-{ Primitive_2_Args();
+Built_In_Primitive(Prim_Divide, 2, "&/", 0xEF)
+{
+ Primitive_2_Args();
+
Set_Time_Zone(Zone_Math);
switch (Type_Code(Arg1))
{ case TC_FIXNUM:
Divide_Bignum_Operation(div_signed_bignum(Fetch_Bignum(Big_Arg1),
Fetch_Bignum(Arg2)),
Result);
- if (Vector_Ref(Result, CONS_CDR) == FIXNUM_0)
+ if (Vector_Ref(Result, CONS_CDR) == Make_Unsigned_Fixnum(0))
return (Vector_Ref(Result, CONS_CAR));
Sign_Extend(Arg1, A);
{ B = Big_To_Float(Arg2);
{ Reduced_Flonum_Result(A / Get_Float(B));
}
Primitive_Error(ERR_ARG_2_FAILED_COERCION);
- } /*NOTREACHED*/
+ }
+ /*NOTREACHED*/
}
default:
Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- } /*NOTREACHED*/
+ }
+ /*NOTREACHED*/
}
case TC_BIG_FLONUM:
{ switch (Type_Code(Arg2))
{ Reduced_Flonum_Result(Get_Float(Arg1) / Get_Float(B));
}
Primitive_Error(ERR_ARG_2_FAILED_COERCION);
- } /*NOTREACHED*/
+ }
+ /*NOTREACHED*/
default:
Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- } /*NOTREACHED*/
+ }
+ /*NOTREACHED*/
}
/* Prim_Divide continues on the next page */
Divide_Bignum_Operation(div_signed_bignum(Fetch_Bignum(Arg1),
Fetch_Bignum(Big_Arg2)),
Result);
- if (Vector_Ref(Result, CONS_CDR) == FIXNUM_0)
+ if (Vector_Ref(Result, CONS_CDR) == Make_Unsigned_Fixnum(0))
return (Vector_Ref(Result, CONS_CAR));
A = Big_To_Float(Arg1);
if (Type_Code(A) == TC_BIG_FLONUM)
Reduced_Flonum_Result(Get_Float(A) / ((double) B));
}
Primitive_Error(ERR_ARG_1_FAILED_COERCION);
- } /*NOTREACHED*/
+ }
+ /*NOTREACHED*/
case TC_BIG_FLONUM:
{ Pointer A;
if (Get_Float(Arg2) == 0.0)
{ Reduced_Flonum_Result(Get_Float(A) / Get_Float(Arg2));
}
Primitive_Error(ERR_ARG_1_FAILED_COERCION);
- } /*NOTREACHED*/
+ }
+ /*NOTREACHED*/
/* Prim_Divide continues on the next page */
\f
Divide_Bignum_Operation(div_signed_bignum(Fetch_Bignum(Arg1),
Fetch_Bignum(Arg2)),
Result);
- if (Vector_Ref(Result, CONS_CDR) == FIXNUM_0)
+ if (Vector_Ref(Result, CONS_CDR) == Make_Unsigned_Fixnum(0))
return (Vector_Ref(Result, CONS_CAR));
A = Big_To_Float(Arg1);
if (Type_Code(A) == TC_BIG_FLONUM)
}
}
Primitive_Error(ERR_ARG_2_FAILED_COERCION);
- } /*NOTREACHED*/
+ }
+ /*NOTREACHED*/
Primitive_Error(ERR_ARG_1_FAILED_COERCION);
}
default:
Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- } /*NOTREACHED*/
+ }
+ /*NOTREACHED*/
}
default: Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- } /*NOTREACHED*/
+ }
+ /*NOTREACHED*/
}
\f
-Built_In_Primitive(Prim_Integer_Divide, 2, "INTEGER-DIVIDE")
-{ Primitive_2_Args();
+Built_In_Primitive(Prim_Integer_Divide, 2, "INTEGER-DIVIDE", 0xF0)
+{
+ Primitive_2_Args();
+
Set_Time_Zone(Zone_Math);
switch (Type_Code(Arg1))
{ case TC_FIXNUM:
}
default:
Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- } /*NOTREACHED*/
+ }
+ /*NOTREACHED*/
}
/* Prim_Integer_Divide continues on the next page */
}
default:
Primitive_Error(ERR_ARG_2_WRONG_TYPE);
- } /*NOTREACHED*/
+ }
+ /*NOTREACHED*/
}
default: Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- } /*NOTREACHED*/
+ }
+ /*NOTREACHED*/
}
\f
/* Generic sqrt and transcendental functions are created by generalizing
their floating point counterparts.
*/
-#define Generic_Function(Prim_Name, S_Name, Routine) \
-Built_In_Primitive(Prim_Name, 1, S_Name) \
-{ double Routine(); \
+#define Generic_Function(Routine) \
+ double Routine(); \
Primitive_1_Arg(); \
+ \
Set_Time_Zone(Zone_Math); \
switch (Type_Code(Arg1)) \
{ case TC_FIXNUM: \
} \
default: Primitive_Error(ERR_ARG_1_WRONG_TYPE); \
}
-/* } deliberately omitted to make LINT understand about longjmp */
/* This horrible hack because there are no lambda-expressions in C. */
-#define Restricted_Generic(C_Name, S_Name, Routine, Lambda, Restriction)\
-double Lambda(arg) \
-fast double arg; \
-{ double Routine(); \
- if (arg Restriction 0.0) Primitive_Error(ERR_ARG_1_BAD_RANGE); \
+#define Generic_Restriction(Lambda, Routine, Restriction) \
+double \
+Lambda(arg) \
+ fast double arg; \
+{ \
+ double Routine(); \
+ \
+ if (arg Restriction 0.0) \
+ Primitive_Error(ERR_ARG_1_BAD_RANGE); \
return Routine(arg); \
-} \
-Generic_Function(C_Name, S_Name, Lambda)
+}
\f
/* And here the functions themselves */
-Restricted_Generic(Prim_Sqrt, "SQRT", sqrt, Scheme_Sqrt, <)
-/*NOTREACHED*/ }
-Generic_Function(Prim_Exp, "EXP", exp)
-/*NOTREACHED*/ }
-Restricted_Generic(Prim_Ln, "LN", log, Scheme_Ln, <=)
-/*NOTREACHED*/ }
-Generic_Function(Prim_Sine, "SINE", sin)
-/*NOTREACHED*/ }
-Generic_Function(Prim_Cosine, "COSINE", cos)
-/*NOTREACHED*/ }
-Generic_Function(Prim_Arctan, "ARCTAN", atan)
-/*NOTREACHED*/ }
+Generic_Restriction(Scheme_Sqrt, sqrt, <)
+Generic_Restriction(Scheme_Ln, log, <=)
+
+Built_In_Primitive(Prim_Sqrt, 1, "SQRT", 0xF7)
+{
+ Generic_Function(Scheme_Sqrt);
+ /*NOTREACHED*/
+}
+
+Built_In_Primitive(Prim_Exp, 1, "EXP", 0xF8)
+{
+ Generic_Function(exp);
+ /*NOTREACHED*/
+}
+
+Built_In_Primitive(Prim_Ln, 1, "LOG", 0xF9)
+{
+ Generic_Function(Scheme_Ln);
+ /*NOTREACHED*/
+}
+
+Built_In_Primitive(Prim_Sine, 1, "SIN", 0xFA)
+{
+ Generic_Function(sin);
+ /*NOTREACHED*/
+}
+
+Built_In_Primitive(Prim_Cosine, 1, "COS", 0xFB)
+{
+ Generic_Function(cos);
+ /*NOTREACHED*/
+}
+
+Built_In_Primitive(Prim_Arctan, 1, "&ATAN", 0xFC)
+{
+ Generic_Function(atan);
+ /*NOTREACHED*/
+}
\f
/* Coercions from Floating point to integers.
*/
#define Truncate_Mapping(arg) arg
-#define Round_Mapping(arg) ((arg) >= 0.0 ? (arg)+0.5 : (arg)-0.5)
+#define Round_Mapping(arg) ((arg) >= 0.0 ? ((arg) + 0.5) : ((arg) - 0.5))
#ifdef HAS_FLOOR
+
extern double floor(), ceil();
#define Floor_Mapping(arg) floor(arg)
#define Ceiling_Mapping(arg) ceil(arg)
+
#else
-#define Floor_Mapping(arg) ((arg) >= 0.0 ? (arg) : (arg)-1.0)
-#define Ceiling_Mapping(arg) ((arg) >= 0.0 ? (arg)+1.0 : (arg))
+
+#define Floor_Mapping(arg) ((arg) >= 0.0 ? (arg) : ((arg) - 1.0))
+#define Ceiling_Mapping(arg) ((arg) >= 0.0 ? ((arg) + 1.0) : (arg))
+
#endif
\f
-#define Flonum_To_Integer(Prim_Name, S_Name, How_To_Do_It) \
-Built_In_Primitive(Prim_Name, 1, S_Name) \
-{ Primitive_1_Arg(); \
+#define Flonum_To_Integer(How_To_Do_It) \
+ Primitive_1_Arg(); \
Set_Time_Zone(Zone_Math); \
switch (Type_Code(Arg1)) \
{ case TC_FIXNUM : \
} \
default: Primitive_Error(ERR_ARG_1_WRONG_TYPE); \
}
-/* } deliberately omitted to make LINT understand about longjmp */
-
-Flonum_To_Integer(Prim_Truncate, "TRUNCATE", Truncate_Mapping)
-/*NOTREACHED*/ }
-Flonum_To_Integer(Prim_Round, "ROUND", Round_Mapping)
-/*NOTREACHED*/ }
-Flonum_To_Integer(Prim_Floor, "FLOOR", Floor_Mapping)
-/*NOTREACHED*/ }
-Flonum_To_Integer(Prim_Ceiling, "CEILING", Ceiling_Mapping)
-/*NOTREACHED*/ }
+
+Built_In_Primitive(Prim_Truncate, 1, "TRUNCATE", 0xF3)
+{
+ Flonum_To_Integer(Truncate_Mapping);
+ /*NOTREACHED*/
+}
+
+Built_In_Primitive(Prim_Round, 1, "ROUND", 0xF4)
+{
+ Flonum_To_Integer(Round_Mapping);
+ /*NOTREACHED*/
+}
+
+Built_In_Primitive(Prim_Floor, 1, "FLOOR", 0xF5)
+{
+ Flonum_To_Integer(Floor_Mapping);
+ /*NOTREACHED*/
+}
+
+Built_In_Primitive(Prim_Ceiling, 1, "CEILING", 0xF6)
+{
+ 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/history.h,v 9.21 1987/01/22 14:26:55 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/history.h,v 9.22 1987/04/16 02:23:38 jinx Rel $
*
* History maintenance data structures and support.
*
* NIL and the offset is 0.
*/
-#define Save_History(Return_Code) \
-if (Previous_Restore_History_Stacklet == NULL) Push(NIL); \
-else \
- Push(Make_Pointer(TC_CONTROL_POINT, \
- Previous_Restore_History_Stacklet)); \
-Push(Make_Non_Pointer(TC_FIXNUM, \
- Previous_Restore_History_Offset)); \
-Store_Expression(Make_Pointer(TC_HUNK3, History)); \
-Store_Return((Return_Code)); \
-Save_Cont(); \
-History = Get_Pointer(Get_Fixed_Obj_Slot(Dummy_History))
+#define Save_History(Return_Code) \
+{ \
+ if (Prev_Restore_History_Stacklet == NULL) \
+ Push(NIL); \
+ else \
+ Push(Make_Pointer(TC_CONTROL_POINT, \
+ Prev_Restore_History_Stacklet)); \
+ Push(Make_Non_Pointer(TC_FIXNUM, Prev_Restore_History_Offset)); \
+ Store_Expression(Make_Pointer(TC_HUNK3, History)); \
+ Store_Return((Return_Code)); \
+ Save_Cont(); \
+ History = Get_Pointer(Get_Fixed_Obj_Slot(Dummy_History)); \
+}
\f
/* History manipulation in the interpreter. */
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.22 1987/04/03 00:14:25 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/hooks.c,v 9.23 1987/04/16 02:23:49 jinx Exp $
*
* This file contains various hooks and handles which connect the
* primitives with the main interpreter.
#include "winder.h"
\f
/* (APPLY FN LIST-OF-ARGUMENTS)
- Calls the function FN on the arguments specified in the list
+ Calls the function FN to the arguments specified in the list
LIST-OF-ARGUMENTS. FN must be a primitive procedure, compound
procedure, or control point. */
-Built_In_Primitive( Prim_Apply, 2, "APPLY")
+Built_In_Primitive(Prim_Apply, 2, "APPLY", 0x5)
{
fast Pointer scan_list, *scan_stack;
fast long number_of_args, i;
Push( (STACK_FRAME_HEADER + number_of_args));
Pushed();
longjmp( *Back_To_Eval, PRIM_APPLY);
+ /*NOTREACHED*/
}
\f
/* This code used to be in the middle of Make_Control_Point, replaced
Pushed(); \
/* There is no history to use since the last control point was formed. \
*/ \
- Previous_Restore_History_Stacklet = NULL; \
- Previous_Restore_History_Offset = 0; \
+ Prev_Restore_History_Stacklet = NULL; \
+ Prev_Restore_History_Offset = 0; \
CWCC_2(); \
/* Will_Push(3); -- we just cleared the stack so there MUST be room */ \
Push(Control_Point); \
}
#endif
\f
-/* (CATCH PROCEDURE)
- Creates a control point (a pointer to the current stack) and
- passes it to PROCEDURE as its only argument. The inverse
- operation, typically called THROW, is performed by using the
- control point as you would a procedure. A control point accepts
- one argument which is then returned as the value of the CATCH
- which created the control point. If the dangerous bit of the
- unused length word in the stacklet is clear then the control
- point may be reused as often as desired since the stack will be
- copied on every throw. The user level CATCH is built on this
- primitive but is not the same, since it handles dynamic-wind
- while the primitive does not; it assumes that the microcode
- sets and clears the appropriate danger bits for copying.
+/* (CALL-WITH-CURRENT-CONTINUATION PROCEDURE)
+ Creates a control point (a pointer to the current stack) and
+ passes it to PROCEDURE as its only argument. The inverse
+ operation, typically called THROW, is performed by using the
+ control point as you would a procedure. A control point accepts
+ one argument which is then returned as the value of the CATCH
+ which created the control point. If the dangerous bit of the
+ unused length word in the stacklet is clear then the control
+ point may be reused as often as desired since the stack will be
+ copied on every throw. The user level CATCH is built on this
+ primitive but is not the same, since it handles dynamic-wind
+ while the primitive does not; it assumes that the microcode
+ sets and clears the appropriate danger bits for copying.
*/
-Built_In_Primitive(Prim_Catch, 1, "CALL-WITH-CURRENT-CONTINUATION")
-{ fast Pointer Control_Point;
+Built_In_Primitive(Prim_Catch, 1, "CALL-WITH-CURRENT-CONTINUATION", 0x3)
+{
+ fast Pointer Control_Point;
+
CWCC(RC_RESTORE_HISTORY);
Clear_Danger_Bit((Get_Pointer(Control_Point))[STACKLET_UNUSED_LENGTH]);
longjmp(*Back_To_Eval, PRIM_APPLY);
+ /*NOTREACHED*/
}
+Built_In_Primitive(Prim_Non_Reentrant_Catch, 1,
+ "NON-REENTRANT-CALL-WITH-CURRENT-CONTINUATION", 0x9)
+{
+ Pointer Control_Point;
+
#ifdef USE_STACKLETS
-Built_In_Primitive(Prim_Non_Reentrant_Catch, 1, "FAST-CALL-WITH-CURRENT-CONTINUATION")
-{ Pointer Control_Point;
+
CWCC(RC_RESTORE_DONT_COPY_HISTORY);
- longjmp(*Back_To_Eval, PRIM_APPLY);
-}
-#else /* Without stacklets, the two catches are identical */
+#else
+ /* When there are no stacklets, it is identical to the reentrant version. */
-Built_In_Primitive(Prim_Non_Reentrant_Catch, 1, "FAST-CALL-WITH-CURRENT-CONTINUATION")
-{ Pointer Control_Point;
CWCC(RC_RESTORE_HISTORY);
Clear_Danger_Bit((Get_Pointer(Control_Point))[STACKLET_UNUSED_LENGTH]);
- longjmp(*Back_To_Eval, PRIM_APPLY);
-}
+
#endif
+
+ longjmp(*Back_To_Eval, PRIM_APPLY);
+ /*NOTREACHED*/
+}
\f
/* (ENABLE-INTERRUPTS! INTERRUPTS)
- Changes the enabled interrupt bits to bitwise-or of INTERRUPTS
- and previous value of interrupts. Returns the previous value.
- See MASK_INTERRUPT_ENABLES for more information on interrupts.
+ Changes the enabled interrupt bits to bitwise-or of INTERRUPTS
+ and previous value of interrupts. Returns the previous value.
+ See MASK_INTERRUPT_ENABLES for more information on interrupts.
*/
-Built_In_Primitive(Prim_Enable_Interrupts, 1, "ENABLE-INTERRUPTS!")
-{ Pointer Result;
+Built_In_Primitive(Prim_Enable_Interrupts, 1, "ENABLE-INTERRUPTS!", 0x1E)
+{
+ Pointer Result;
Primitive_1_Arg();
+
Arg_1_Type(TC_FIXNUM);
Result = Make_Non_Pointer(TC_FIXNUM, IntEnb);
IntEnb = Get_Integer(Arg1) | INT_Mask;
}
/* (ERROR-PROCEDURE arg1 arg2 arg3)
- Passes its arguments along to the appropriate Scheme error handler
- after turning off history, etc.
+ Passes its arguments along to the appropriate Scheme error handler
+ after turning off history, etc.
*/
-Built_In_Primitive(Prim_Error_Procedure, 3, "ERROR-PROCEDURE")
-{ Primitive_3_Args();
+Built_In_Primitive(Prim_Error_Procedure, 3, "ERROR-PROCEDURE", 0x18E)
+{
+ Primitive_3_Args();
+
Will_Push(CONTINUATION_SIZE+HISTORY_SIZE+STACK_ENV_EXTRA_SLOTS+4);
Back_Out_Of_Primitive();
Save_Cont();
Push(STACK_FRAME_HEADER+3);
Pushed();
longjmp(*Back_To_Eval, PRIM_APPLY);
+ /*NOTREACHED*/
}
/* (GET-FIXED-OBJECTS-VECTOR)
- Returns the current fixed objects vector. This vector is used
- for communication between the interpreter and the runtime
- system. See the file UTABCSCM.SCM in the runtime system for the
- names of the slots in the vector.
+ Returns the current fixed objects vector. This vector is used
+ for communication between the interpreter and the runtime
+ system. See the file UTABCSCM.SCM in the runtime system for the
+ names of the slots in the vector.
*/
Built_In_Primitive(Prim_Get_Fixed_Objects_Vector, 0,
- "GET-FIXED-OBJECTS-VECTOR")
-{ Primitive_0_Args();
+ "GET-FIXED-OBJECTS-VECTOR", 0x7A)
+{
+ Primitive_0_Args();
+
if (Valid_Fixed_Obj_Vector())
return Get_Fixed_Obj_Slot(Me_Myself);
else return NIL;
}
\f
/* (FORCE DELAYED-OBJECT)
- Returns the memoized value of the DELAYED-OBJECT (created by a
- DELAY special form) if it has already been calculated.
- Otherwise, it calculates the value and memoizes it for future
- use.
+ Returns the memoized value of the DELAYED-OBJECT (created by a
+ DELAY special form) if it has already been calculated.
+ Otherwise, it calculates the value and memoizes it for future
+ use.
*/
-Built_In_Primitive(Prim_Force, 1, "FORCE")
-{ Primitive_1_Arg();
+Built_In_Primitive(Prim_Force, 1, "FORCE", 0xAF)
+{
+ Primitive_1_Arg();
+
Arg_1_Type(TC_DELAYED);
if (Vector_Ref(Arg1, THUNK_SNAPPED) == TRUTH)
return Vector_Ref(Arg1, THUNK_VALUE);
Pushed();
Store_Env(Fast_Vector_Ref(Arg1, THUNK_ENVIRONMENT));
Store_Expression(Fast_Vector_Ref(Arg1, THUNK_PROCEDURE));
- longjmp(*Back_To_Eval, PRIM_DO_EXPRESSION); /*NOTREACHED*/
+ longjmp(*Back_To_Eval, PRIM_DO_EXPRESSION);
+ /*NOTREACHED*/
}
\f
/* (EXECUTE-AT-NEW-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.
+ 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")
-{ Pointer New_Point, Old_Point;
+Built_In_Primitive(Prim_Execute_At_New_Point, 4, "EXECUTE-AT-NEW-POINT", 0xE2)
+{
+ Pointer New_Point, Old_Point;
Primitive_4_Args();
+
guarantee_state_point();
if (Arg1 == NIL) Old_Point = Current_State_Point;
else
}
\f
/* (MAKE-STATE-SPACE MUTABLE?)
- Creates a new state space for the dynamic winder. Used only
- internally to the dynamic wind operations. If the arugment
- is #!TRUE, then a real, mutable state space is created.
- Otherwise a (actually, THE) immutable space is created and
- the microcode will track motions in this space.
+ Creates a new state space for the dynamic winder. Used only
+ internally to the dynamic wind operations. If the arugment
+ is #!TRUE, then a real, mutable state space is created.
+ Otherwise a (actually, THE) immutable space is created and
+ the microcode will track motions in this space.
*/
-Built_In_Primitive(Prim_Make_State_Space, 1, "MAKE-STATE-SPACE")
-{ Pointer New_Point;
+Built_In_Primitive(Prim_Make_State_Space, 1, "MAKE-STATE-SPACE", 0xE1)
+{
+ Pointer New_Point;
Primitive_1_Arg();
+
Primitive_GC_If_Needed(STATE_POINT_SIZE+STATE_SPACE_SIZE);
New_Point = Make_Pointer(TC_VECTOR, Free);
Free[STATE_POINT_HEADER] =
Free[STATE_POINT_BEFORE_THUNK] = NIL;
Free[STATE_POINT_AFTER_THUNK] = NIL;
Free[STATE_POINT_NEARER_POINT] = NIL;
- Free[STATE_POINT_DISTANCE_TO_ROOT] = FIXNUM_0;
+ Free[STATE_POINT_DISTANCE_TO_ROOT] = Make_Unsigned_Fixnum(0);
Free += STATE_POINT_SIZE;
if (Arg1 == NIL)
{ Current_State_Point = New_Point;
}
}
\f
-Built_In_Primitive(Prim_Current_Dynamic_State, 1, "CURRENT-DYNAMIC-STATE")
-{ Primitive_1_Arg();
+Built_In_Primitive(Prim_Current_Dynamic_State, 1, "CURRENT-DYNAMIC-STATE", 0xA)
+{
+ Primitive_1_Arg();
+
guarantee_state_point();
if (Arg1 == NIL) return Current_State_Point;
Arg_1_Type(TC_VECTOR);
return Vector_Ref(Arg1, STATE_SPACE_NEAREST_POINT);
}
-Built_In_Primitive(Prim_Set_Dynamic_State, 1, "SET-CURRENT-DYNAMIC-STATE!")
-{ Pointer State_Space, Result;
+Built_In_Primitive(Prim_Set_Dynamic_State, 1, "SET-CURRENT-DYNAMIC-STATE!", 0xB)
+{
+ Pointer State_Space, Result;
Primitive_1_Arg();
+
Arg_1_Type(TC_VECTOR);
if (Fast_Vector_Ref(Arg1, STATE_POINT_TAG) !=
Get_Fixed_Obj_Slot(State_Point_Tag))
Primitive_Error(ERR_ARG_1_WRONG_TYPE);
State_Space = Find_State_Space(Arg1);
if (State_Space==NIL)
- { guarantee_state_point();
+ {
+ guarantee_state_point();
Result = Current_State_Point;
Current_State_Point = Arg1;
}
else
- { Result = Vector_Ref(State_Space, STATE_SPACE_NEAREST_POINT);
+ {
+ Result = Vector_Ref(State_Space, STATE_SPACE_NEAREST_POINT);
Vector_Set(State_Space, STATE_SPACE_NEAREST_POINT, Arg1);
}
return Result;
}
\f
/* (SCODE-EVAL SCODE-EXPRESSION ENVIRONMENT)
- Evaluate the piece of SCode (SCODE-EXPRESSION) in the
- ENVIRONMENT. This is like Eval, except that it expects its input
- to be syntaxed into SCode rather than just a list.
+ Evaluate the piece of SCode (SCODE-EXPRESSION) in the
+ ENVIRONMENT. This is like Eval, except that it expects its input
+ to be syntaxed into SCode rather than just a list.
*/
-Built_In_Primitive(Prim_Scode_Eval, 2, "SCODE-EVAL")
-{ Primitive_2_Args();
- if (Type_Code(Arg2) != GLOBAL_ENV) Arg_2_Type(TC_ENVIRONMENT);
+Built_In_Primitive(Prim_Scode_Eval, 2, "SCODE-EVAL", 0x4)
+{
+ Primitive_2_Args();
+
+ if (Type_Code(Arg2) != GLOBAL_ENV)
+ Arg_2_Type(TC_ENVIRONMENT);
Pop_Primitive_Frame(2);
Store_Env(Arg2);
Store_Expression(Arg1);
longjmp(*Back_To_Eval, PRIM_DO_EXPRESSION);
+ /*NOTREACHED*/
}
/* (SET-INTERRUPT-ENABLES! NEW-INT-ENABLES)
- Changes the enabled interrupt bits to NEW-INT-ENABLES and
- returns the previous value. See MASK_INTERRUPT_ENABLES for more
- information on interrupts.
+ Changes the enabled interrupt bits to NEW-INT-ENABLES and
+ returns the previous value. See MASK_INTERRUPT_ENABLES for more
+ information on interrupts.
*/
-Built_In_Primitive(Prim_Set_Interrupt_Enables, 1, "SET-INTERRUPT-ENABLES!")
-{ Pointer Result;
+Built_In_Primitive(Prim_Set_Interrupt_Enables, 1, "SET-INTERRUPT-ENABLES!", 0x6)
+{
+ Pointer Result;
Primitive_1_Arg();
+
Arg_1_Type(TC_FIXNUM);
- Result = FIXNUM_0+IntEnb;
+ Result = Make_Unsigned_Fixnum(IntEnb);
IntEnb = Get_Integer(Arg1) & INT_Mask;
New_Compiler_MemTop();
return Result;
}
\f
/* (SET-CURRENT-HISTORY! TRIPLE)
- Begins recording history into TRIPLE. The history structure is
- somewhat complex and should be understood before trying to use
- this primitive. It is used in the Read-Eval-Print loop in the
- Scheme runtime system.
+ Begins recording history into TRIPLE. The history structure is
+ somewhat complex and should be understood before trying to use
+ this primitive. It is used in the Read-Eval-Print loop in the
+ Scheme runtime system.
- This primitive pops its own frame and escapes back to the interpreter
- because it modifies one of the registers that the interpreter caches
- (History).
+ This primitive pops its own frame and escapes back to the interpreter
+ because it modifies one of the registers that the interpreter caches
+ (History).
- The longjmp forces the interpreter to recache.
+ The longjmp forces the interpreter to recache.
*/
-Built_In_Primitive(Prim_Set_Current_History, 1, "SET-CURRENT-HISTORY!")
+Built_In_Primitive(Prim_Set_Current_History, 1, "SET-CURRENT-HISTORY!", 0x2F)
{
Primitive_1_Arg();
}
/* (SET-FIXED-OBJECTS-VECTOR! VECTOR)
- Replace the current fixed objects vector with VECTOR. The fixed
- objects vector is used for communication between the Scheme
- runtime system and the interpreter. The file UTABCSCM.SCM
- contains the names of the slots in the vector. Returns (bad
- style to depend on this) the previous fixed objects vector.
+ Replace the current fixed objects vector with VECTOR. The fixed
+ objects vector is used for communication between the Scheme
+ runtime system and the interpreter. The file UTABCSCM.SCM
+ contains the names of the slots in the vector. Returns (bad
+ style to depend on this) the previous fixed objects vector.
*/
Built_In_Primitive(Prim_Set_Fixed_Objects_Vector, 1,
- "SET-FIXED-OBJECTS-VECTOR!")
-{ Pointer Result;
+ "SET-FIXED-OBJECTS-VECTOR!", 0x7B)
+{
+ Pointer Result;
Primitive_1_Arg();
- Arg_1_Type(TC_VECTOR);
+ Arg_1_Type(TC_VECTOR);
if (Valid_Fixed_Obj_Vector())
Result = Get_Fixed_Obj_Slot(Me_Myself);
else Result = NIL;
}
\f
/* (TRANSLATE-TO-STATE-POINT STATE_POINT)
- Move to a new dynamic wind environment by performing all of the
- necessary enter and exit forms to get from the current state to
- the new state as specified by STATE_POINT.
+ Move to a new dynamic wind environment by performing all of the
+ necessary enter and exit forms to get from the current state to
+ the new state as specified by STATE_POINT.
*/
-Built_In_Primitive(Prim_Translate_To_Point, 1, "TRANSLATE-TO-STATE-POINT")
-{ Primitive_1_Arg();
+Built_In_Primitive(Prim_Translate_To_Point, 1,
+ "TRANSLATE-TO-STATE-POINT", 0xE3)
+{
+ Primitive_1_Arg();
+
Arg_1_Type(TC_VECTOR);
if (Vector_Ref(Arg1, STATE_POINT_TAG) != Get_Fixed_Obj_Slot(State_Point_Tag))
Primitive_Error(ERR_ARG_1_WRONG_TYPE);
Pop_Primitive_Frame(1);
Translate_To_Point(Arg1);
/* This ends by longjmp-ing back to the interpreter */
+ /*NOTREACHED*/
}
/* (WITH-HISTORY-DISABLED THUNK)
- THUNK must be a procedure or primitive procedure which takes no
- arguments. Turns off the history collection mechanism. Removes
- the most recent reduction (the expression which called the
- primitive) from the current history and saves the history. Then
- it calls the THUNK. When (if) the THUNK returns, the history is
- restored back and collection resumes. The net result is that the
- THUNK is called with history collection turned off.
+ THUNK must be a procedure or primitive procedure which takes no
+ arguments. Turns off the history collection mechanism. Removes
+ the most recent reduction (the expression which called the
+ primitive) from the current history and saves the history. Then
+ it calls the THUNK. When (if) the THUNK returns, the history is
+ restored back and collection resumes. The net result is that the
+ THUNK is called with history collection turned off.
*/
-Built_In_Primitive(Prim_With_History_Disabled, 1, "WITH-HISTORY-DISABLED")
-{ Pointer *First_Rib, *Rib, *Second_Rib;
+Built_In_Primitive(Prim_With_History_Disabled, 1,
+ "WITH-HISTORY-DISABLED", 0x9C)
+{
+ Pointer *First_Rib, *Rib, *Second_Rib;
Primitive_1_Arg();
+
/* Remove one reduction from the history before saving it */
First_Rib = Get_Pointer(History[HIST_RIB]);
Second_Rib = Get_Pointer(First_Rib[RIB_NEXT_REDUCTION]);
Push(STACK_FRAME_HEADER);
Pushed();
longjmp(*Back_To_Eval, PRIM_APPLY);
+ /*NOTREACHED*/
}
\f
/* Called with a mask and a thunk */
-Built_In_Primitive(Prim_With_Interrupt_Mask, 2, "WITH-INTERRUPT-MASK")
-{ Primitive_2_Args();
+Built_In_Primitive(Prim_With_Interrupt_Mask, 2,
+ "WITH-INTERRUPT-MASK", 0x137)
+{
+ Primitive_2_Args();
+
Arg_1_Type(TC_FIXNUM);
Pop_Primitive_Frame(2);
Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+2));
Store_Return(RC_RESTORE_INT_MASK);
- Store_Expression(FIXNUM_0+IntEnb);
+ Store_Expression(Make_Unsigned_Fixnum(IntEnb));
Save_Cont();
- Push(FIXNUM_0 + IntEnb); /* Current interrupt mask */
+ Push(Make_Unsigned_Fixnum(IntEnb)); /* Current interrupt mask */
Push(Arg2); /* Function to call */
Push(STACK_FRAME_HEADER+1);
Pushed();
IntEnb = INT_Mask & Get_Integer(Arg1);
longjmp(*Back_To_Eval, PRIM_APPLY);
+ /*NOTREACHED*/
}
/* Called with a mask and a thunk */
-Built_In_Primitive(Prim_With_Interrupts_Reduced, 2, "WITH-INTERRUPTS-REDUCED")
+Built_In_Primitive(Prim_With_Interrupts_Reduced, 2,
+ "WITH-INTERRUPTS-REDUCED", 0xC9)
{
long new_interrupt_mask;
Primitive_2_Args();
Pop_Primitive_Frame(2);
Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+2));
Store_Return(RC_RESTORE_INT_MASK);
- Store_Expression(FIXNUM_0+IntEnb);
+ Store_Expression(Make_Unsigned_Fixnum(IntEnb));
Save_Cont();
- Push(FIXNUM_0 + IntEnb); /* Current interrupt mask */
+ Push(Make_Unsigned_Fixnum(IntEnb)); /* Current interrupt mask */
Push(Arg2); /* Function to call */
Push(STACK_FRAME_HEADER+1);
Pushed();
else
IntEnb = (new_interrupt_mask & IntEnb);
longjmp(*Back_To_Eval, PRIM_APPLY);
+ /*NOTREACHED*/
}
\f
/* (WITHIN-CONTROL-POINT CONTROL-POINT THUNK)
- THUNK must be a procedure or primitive procedure which takes no
- arguments. Restores the state of the machine from the control
- point, and then calls the THUNK in this new state.
+ THUNK must be a procedure or primitive procedure which takes no
+ arguments. Restores the state of the machine from the control
+ point, and then calls the THUNK in this new state.
*/
-Built_In_Primitive(Prim_Within_Control_Point, 2, "WITHIN-CONTROL-POINT")
-{ Primitive_2_Args();
+Built_In_Primitive(Prim_Within_Control_Point, 2,
+ "WITHIN-CONTROL-POINT", 0xBF)
+{
+ Primitive_2_Args();
+
Arg_1_Type(TC_CONTROL_POINT);
Our_Throw(false, Arg1);
Within_Stacklet_Backout();
Push(STACK_FRAME_HEADER);
Pushed();
longjmp(*Back_To_Eval, PRIM_APPLY);
+ /*NOTREACHED*/
}
-/* (WITH-THREADED-STACK PROCEDURE THUNK)
- THUNK must be a procedure or primitive procedure which takes no
- arguments. PROCEDURE must expect one argument. Basically this
- primitive does (PROCEDURE (THUNK)) ... it calls the THUNK and
- passes the result on as an argument to PROCEDURE. However, it
- leaves a "well-known continuation code" on the stack for use by
- the continuation parser in the Scheme runtime system.
+
+/* (WITH-THREADED-CONTINUATION PROCEDURE THUNK)
+ THUNK must be a procedure or primitive procedure which takes no
+ arguments. PROCEDURE must expect one argument. Basically this
+ primitive does (PROCEDURE (THUNK)) ... it calls the THUNK and
+ passes the result on as an argument to PROCEDURE. However, it
+ leaves a "well-known continuation code" on the stack for use by
+ the continuation parser in the Scheme runtime system.
*/
-Built_In_Primitive(Prim_With_Threaded_Stack, 2, "WITH-THREADED-STACK")
-{ Primitive_2_Args();
+Built_In_Primitive(Prim_With_Threaded_Stack, 2,
+ "WITH-THREADED-CONTINUATION", 0xBE)
+{
+ Primitive_2_Args();
+
Pop_Primitive_Frame(2);
Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+1));
Store_Expression(Arg1); /* Save procedure to call later */
Push(STACK_FRAME_HEADER);
Pushed();
longjmp(*Back_To_Eval, PRIM_APPLY);
+ /*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/hunk.c,v 9.21 1987/01/22 14:27:14 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/hunk.c,v 9.22 1987/04/16 02:24:07 jinx Rel $
*
* Support for Hunk3s (triples)
*/
#include "scheme.h"
#include "primitive.h"
-/* (HUNK3_CONS FIRST SECOND THIRD)
- [Primitive number 0x28]
+/* (HUNK3-CONS FIRST SECOND THIRD)
Returns a triple consisting of the specified values.
*/
-Built_In_Primitive(Prim_Hunk3_Cons, 3, "HUNK3-CONS")
-{ Primitive_3_Args();
+Built_In_Primitive(Prim_Hunk3_Cons, 3, "HUNK3-CONS", 0x28)
+{
+ Primitive_3_Args();
+
Primitive_GC_If_Needed(3);
*Free++ = Arg1;
*Free++ = Arg2;
return Make_Pointer(TC_HUNK3, Free-3);
}
\f
-/* (HUNK3_CXR TRIPLE N)
- [Primitive number 0x29]
+/* (HUNK3-CXR TRIPLE N)
Returns the Nth item from the TRIPLE. N must be 0, 1, or 2.
*/
-Built_In_Primitive(Prim_Hunk3_Cxr, 2, "HUNK3-CXR")
-{ long Offset;
+Built_In_Primitive(Prim_Hunk3_Cxr, 2, "HUNK3-CXR", 0x29)
+{
+ long Offset;
Primitive_2_Args();
+
Arg_1_Type(TC_HUNK3);
Arg_2_Type(TC_FIXNUM);
Range_Check(Offset, Arg2, 0, 2, ERR_ARG_2_BAD_RANGE);
return Vector_Ref(Arg1, Offset);
}
-/* (HUNK3_SET_CXR TRIPLE N VALUE)
- [Primitive number 0x2A]
+/* (HUNK3-SET-CXR! TRIPLE N VALUE)
Stores VALUE in the Nth item of TRIPLE. N must be 0, 1, or 2.
Returns (not good style to count on this) the previous contents.
*/
-Built_In_Primitive(Prim_Hunk3_Set_Cxr, 3, "HUNK3-SET-CXR!")
-{ long Offset;
-
+Built_In_Primitive(Prim_Hunk3_Set_Cxr, 3, "HUNK3-SET-CXR!", 0x2A)
+{
+ long Offset;
Primitive_3_Args();
+
Arg_1_Type(TC_HUNK3);
Arg_2_Type(TC_FIXNUM);
Range_Check(Offset, Arg2, 0, 2, ERR_ARG_2_BAD_RANGE);
return Swap_Pointers(Nth_Vector_Loc(Arg1, Offset), Arg3);
}
\f
-/* (SYS_H3_0 GC-TRIPLE)
- [Primitive number 0x8E]
+/* (SYSTEM-HUNK3-CXR0 GC-TRIPLE)
Returns item 0 (the first item) from any object with a GC type
of triple. For example, this would access the operator slot of
a COMBINATION_2_OPERAND SCode item.
*/
-Built_In_Primitive(Prim_Sys_H3_0, 1, "SYSTEM-HUNK3-CXR0")
-{ Primitive_1_Arg();
+Built_In_Primitive(Prim_Sys_H3_0, 1, "SYSTEM-HUNK3-CXR0", 0x8E)
+{
+ Primitive_1_Arg();
+
Arg_1_GC_Type(GC_Triple);
return Vector_Ref(Arg1, 0);
}
-/* (SYS_H3_1 GC-TRIPLE)
- [Primitive number 0x91]
+/* (SYSTEM-HUNK3-CXR1 GC-TRIPLE)
Returns item 1 (the second item) from any object with a GC type
of triple. For example, this would access the first operand
slot of a COMBINATION_2_OPERAND SCode item.
*/
-Built_In_Primitive(Prim_Sys_H3_1, 1, "SYSTEM-HUNK3-CXR1")
-{ Primitive_1_Arg();
+Built_In_Primitive(Prim_Sys_H3_1, 1, "SYSTEM-HUNK3-CXR1", 0x91)
+{
+ Primitive_1_Arg();
+
Arg_1_GC_Type(GC_Triple);
return Vector_Ref(Arg1, 1);
}
-/* (SYS_H3_2 GC-TRIPLE)
- [Primitive number 0x94]
+/* (SYSTEM-HUNK3-CXR2 GC-TRIPLE)
Returns item 2 (the third item) from any object with a GC type
of triple. For example, this would access the second operand
slot of a COMBINATION_2_OPERAND SCode item.
*/
-Built_In_Primitive(Prim_Sys_H3_2, 1, "SYSTEM-HUNK3-CXR2")
-{ Primitive_1_Arg();
+Built_In_Primitive(Prim_Sys_H3_2, 1, "SYSTEM-HUNK3-CXR2", 0x94)
+{
+ Primitive_1_Arg();
+
Arg_1_GC_Type(GC_Triple);
return Vector_Ref(Arg1, 2);
}
\f
-/* (SYS_H3_SET_0 GC-TRIPLE NEW-CONTENTS)
- [Primitive number 0x8F]
+/* (SYSTEM-HUNK3-SET-CXR0! GC-TRIPLE NEW-CONTENTS)
Replaces item 0 (the first item) in any object with a GC type of
triple with NEW-CONTENTS. For example, this would modify the
operator slot of a COMBINATION_2_OPERAND SCode item. Returns
(bad style to rely on this) the previous contents.
*/
-Built_In_Primitive(Prim_SH3_Set_0, 2, "SYSTEM-HUNK3-SET-CXR0!")
-{ Primitive_2_Args();
+Built_In_Primitive(Prim_SH3_Set_0, 2, "SYSTEM-HUNK3-SET-CXR0!", 0x8F)
+{
+ Primitive_2_Args();
Arg_1_GC_Type(GC_Triple);
Side_Effect_Impurify(Arg1, Arg2);
return Swap_Pointers(Nth_Vector_Loc(Arg1, 0), Arg2);
}
-/* (SYS_H3_SET_1 GC-TRIPLE NEW-CONTENTS)
- [Primitive number 0x92]
+/* (SYSTEM-HUNK3-SET-CXR1! GC-TRIPLE NEW-CONTENTS)
Replaces item 1 (the second item) in any object with a GC type
of triple with NEW-CONTENTS. For example, this would modify the
first operand slot of a COMBINATION_2_OPERAND SCode item.
Returns (bad style to rely on this) the previous contents.
*/
-Built_In_Primitive(Prim_SH3_Set_1, 2, "SYSTEM-HUNK3-SET-CXR1!")
-{ Primitive_2_Args();
+Built_In_Primitive(Prim_SH3_Set_1, 2, "SYSTEM-HUNK3-SET-CXR1!", 0x92)
+{
+ Primitive_2_Args();
Arg_1_GC_Type(GC_Triple);
Side_Effect_Impurify(Arg1, Arg2);
return Swap_Pointers(Nth_Vector_Loc(Arg1, 1), Arg2);
}
\f
-/* (SYS_H3_SET_2 GC-TRIPLE NEW-CONTENTS)
- [Primitive number 0x95]
+/* (SYSTEM-HUNK3-SET-CXR2! GC-TRIPLE NEW-CONTENTS)
Replaces item 2 (the third item) in any object with a GC type of
triple with NEW-CONTENTS. For example, this would modify the
second operand slot of a COMBINATION_2_OPERAND SCode item.
Returns (bad style to rely on this) the previous contents.
*/
-Built_In_Primitive(Prim_SH3_Set_2, 2, "SYSTEM-HUNK3-SET-CXR2!")
-{ Primitive_2_Args();
+Built_In_Primitive(Prim_SH3_Set_2, 2, "SYSTEM-HUNK3-SET-CXR2!", 0x95)
+{
+ Primitive_2_Args();
Arg_1_GC_Type(GC_Triple);
Side_Effect_Impurify(Arg1, Arg2);
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/intercom.c,v 9.21 1987/01/22 14:27:43 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/intercom.c,v 9.22 1987/04/16 02:24:17 jinx Exp $
*
* Single-processor simulation of locking, propagating, and
* communicating stuff.
\f
#include "scheme.h"
#include "primitive.h"
-#include "prims.h"
#include "locks.h"
#include "zones.h"
*/
\f
Define_Primitive(Prim_Send_Global_Interrupt, 3, "GLOBAL-INTERRUPT")
-{ long Saved_Zone, Which_Level;
+{
+ long Saved_Zone, Which_Level;
Primitive_3_Args();
Arg_1_Type(TC_FIXNUM);
Pushed();
Restore_Time_Zone();
longjmp(*Back_To_Eval, PRIM_APPLY);
+ /*NOTREACHED*/
}
-Pointer Global_Int_Part_2(Which_Level, Do_It)
-Pointer Do_It, Which_Level;
-{ return Do_It;
+Pointer
+Global_Int_Part_2(Which_Level, Do_It)
+ Pointer Do_It, Which_Level;
+{
+ return Do_It;
}
\f
Define_Primitive(Prim_Put_Work, 1, "PUT-WORK")
-{ Pointer The_Queue, Queue_Tail, New_Entry;
+{
+ Pointer The_Queue, Queue_Tail, New_Entry;
Primitive_1_Arg();
The_Queue = Get_Fixed_Obj_Slot(The_Work_Queue);
- if (The_Queue==NIL)
- { Primitive_GC_If_Needed(4);
+ if (The_Queue == NIL)
+ {
+ Primitive_GC_If_Needed(4);
The_Queue = Make_Pointer(TC_LIST, Free);
Set_Fixed_Obj_Slot(The_Work_Queue, The_Queue);
*Free++ = NIL;
*Free++ = NIL;
}
- else Primitive_GC_If_Needed(2);
+ else
+ Primitive_GC_If_Needed(2);
Queue_Tail = Vector_Ref(The_Queue, CONS_CDR);
New_Entry = Make_Pointer(TC_WEAK_CONS, Free);
*Free++ = Arg1;
*Free++ = NIL;
Vector_Set(The_Queue, CONS_CDR, New_Entry);
- if (Queue_Tail==NIL) Vector_Set(The_Queue, CONS_CAR, New_Entry);
+ if (Queue_Tail == NIL)
+ Vector_Set(The_Queue, CONS_CAR, New_Entry);
else Vector_Set(Queue_Tail, CONS_CDR, New_Entry);
return TRUTH;
}
Define_Primitive(Prim_Drain_Queue, 0, "DRAIN-WORK-QUEUE!")
-{ Pointer The_Queue;
+{
+ Pointer The_Queue;
Primitive_0_Args();
The_Queue = Get_Fixed_Obj_Slot(The_Work_Queue);
Set_Fixed_Obj_Slot(The_Work_Queue, NIL);
- return (The_Queue != NIL) ? Vector_Ref(The_Queue, CONS_CAR) : NIL;
+ return ((The_Queue != NIL) ?
+ Vector_Ref(The_Queue, CONS_CAR) :
+ NIL);
}
\f
Define_Primitive(Prim_Await_Sync, 1, "AWAIT-SYNCHRONY")
-{ Primitive_1_Arg();
+{
+ Primitive_1_Arg();
Arg_1_Type(TC_LIST);
if (Type_Code(Vector_Ref(Arg1, CONS_CDR)) != TC_FIXNUM)
}
Define_Primitive(Prim_N_Interps, 0, "N-INTERPRETERS")
-{ Primitive_0_Args();
- return FIXNUM_0 + 1;
+{
+ Primitive_0_Args();
+
+ return Make_Unsigned_Fixnum(1);
}
Define_Primitive(Prim_My_Proc, 0, "MY-PROCESSOR-NUMBER")
-{ Primitive_0_Args();
- return FIXNUM_0;
+{
+ Primitive_0_Args();
+
+ return Make_Unsigned_Fixnum(0);
}
Define_Primitive(Prim_My_Interp_Number, 0, "MY-INTERPRETER-NUMBER")
-{ Primitive_0_Args();
- return FIXNUM_0;
+{
+ Primitive_0_Args();
+
+ return Make_Unsigned_Fixnum(0);
}
Define_Primitive(Prim_Zero_Zones, 0, "ZERO-ZONES")
-{ long i;
+{
+ long i;
Primitive_0_Args();
+
#ifdef METERING
- for (i=0; i < Max_Meters; i++) Time_Meters[i]=0;
+ for (i=0; i < Max_Meters; i++)
+ Time_Meters[i]=0;
+
Old_Time=Sys_Clock();
#endif
return TRUTH;
/* These are really used by GC on a true parallel machine */
Define_Primitive(Prim_GC_Needed, 0, "GC-NEEDED?")
-{ Primitive_0_Args();
+{
+ Primitive_0_Args();
+
if ((Free+GC_Space_Needed) >= MemTop) return TRUTH;
else return NIL;
}
Define_Primitive(Prim_Slave_Before, 0, "SLAVE-GC-BEFORE-SYNC")
-{ Primitive_0_Args();
+{
+ Primitive_0_Args();
+
return TRUTH;
}
Define_Primitive(Prim_Slave_After, 0, "SLAVE-GC-AFTER-SYNC")
-{ Primitive_0_Args();
+{
+ Primitive_0_Args();
+
return TRUTH;
}
Define_Primitive(Prim_Master_Before, 0, "MASTER-GC-BEFORE-SYNC")
-{ Primitive_0_Args();
+{
+ Primitive_0_Args();
+
return TRUTH;
}
+/* This primitive caches the Scheme object for the garbage collector
+ primitive so that it does not have to perform an expensive search
+ each time.
+*/
+
Define_Primitive(Prim_Master_GC, 1, "MASTER-GC-LOOP")
-{ Primitive_1_Arg();
+{
+ static Pointer gc_prim = NIL;
+ extern Pointer make_primitive();
+ Primitive_1_Arg();
+
+ if (gc_prim == NIL)
+ {
+ gc_prim = make_primitive("GARBAGE-COLLECT");
+ }
Pop_Primitive_Frame(1);
Will_Push(STACK_ENV_EXTRA_SLOTS + 2);
Push(Arg1);
- Push(Make_Non_Pointer(TC_PRIMITIVE, PC_GARBAGE_COLLECT));
+ Push(gc_prim);
Push(STACK_FRAME_HEADER + 1);
Pushed();
longjmp(*Back_To_Eval, PRIM_APPLY);
}
-
-
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/interp.c,v 9.22 1987/04/03 00:14:51 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/interp.c,v 9.23 1987/04/16 02:24:28 jinx Exp $
*
* This file contains the heart of the Scheme Scode
* interpreter
primitive_code = Get_Integer(Fetch_Expression());
- Export_Registers_Before_Primitive();
+ Export_Regs_Before_Primitive();
Metering_Apply_Primitive(Val, primitive_code);
- Import_Registers_After_Primitive();
+ Import_Regs_After_Primitive();
Pop_Primitive_Frame(N_Args_Primitive(primitive_code));
if (Must_Report_References())
{ Store_Expression(Val);
goto return_from_compiled_code; \
}
- define_compiler_restart( RC_COMPILER_INTERRUPT_RESTART,
- compiler_interrupt_restart)
+ define_compiler_restart( RC_COMP_INTERRUPT_RESTART,
+ comp_interrupt_restart)
- define_compiler_restart( RC_COMPILER_LEXPR_INTERRUPT_RESTART,
- compiler_lexpr_interrupt_restart)
+ define_compiler_restart( RC_COMP_LEXPR_INTERRUPT_RESTART,
+ comp_lexpr_interrupt_restart)
- define_compiler_restart( RC_COMPILER_LOOKUP_APPLY_RESTART,
- compiler_lookup_apply_restart)
+ define_compiler_restart( RC_COMP_LOOKUP_APPLY_RESTART,
+ comp_lookup_apply_restart)
- define_compiler_restart( RC_COMPILER_REFERENCE_RESTART,
- compiler_reference_restart)
+ define_compiler_restart( RC_COMP_REFERENCE_RESTART,
+ comp_reference_restart)
- define_compiler_restart( RC_COMPILER_ACCESS_RESTART,
- compiler_access_restart)
+ define_compiler_restart( RC_COMP_ACCESS_RESTART,
+ comp_access_restart)
- define_compiler_restart( RC_COMPILER_UNASSIGNED_P_RESTART,
- compiler_unassigned_p_restart)
+ define_compiler_restart( RC_COMP_UNASSIGNED_P_RESTART,
+ comp_unassigned_p_restart)
- define_compiler_restart( RC_COMPILER_UNBOUND_P_RESTART,
- compiler_unbound_p_restart)
+ define_compiler_restart( RC_COMP_UNBOUND_P_RESTART,
+ comp_unbound_p_restart)
- define_compiler_restart( RC_COMPILER_ASSIGNMENT_RESTART,
- compiler_assignment_restart)
+ define_compiler_restart( RC_COMP_ASSIGNMENT_RESTART,
+ comp_assignment_restart)
- define_compiler_restart( RC_COMPILER_DEFINITION_RESTART,
- compiler_definition_restart)
+ define_compiler_restart( RC_COMP_DEFINITION_RESTART,
+ comp_definition_restart)
case RC_REENTER_COMPILED_CODE:
compiled_code_restart();
{
Apply_Error(ERR_UNDEFINED_PRIMITIVE);
}
- NArgs = Ext_Prim_Desc[Proc].arity;
+ NArgs = N_Args_External(Proc);
if (Get_Integer(Stack_Ref(STACK_ENV_HEADER)) !=
(NArgs + (STACK_ENV_FIRST_ARG - 1)))
{
/* Reinitialize Proc in case we "goto Repeat_External..." */
Proc = Get_Integer(Fetch_Expression());
- Export_Registers_Before_Primitive();
- Val = (*(Ext_Prim_Desc[Proc].proc))();
+ Export_Regs_Before_Primitive();
+ Val = Apply_External(Proc);
Set_Time_Zone(Zone_Working);
- Import_Registers_After_Primitive();
- Pop_Primitive_Frame(Ext_Prim_Desc[Proc].arity);
+ Import_Regs_After_Primitive();
+ Pop_Primitive_Frame(N_Args_External(Proc));
goto Pop_Return;
}
Pointer Thunk, New_Location;
if (From_Count != 0)
{ Pointer Current = Stack_Ref(TRANSLATE_FROM_POINT);
- Stack_Ref(TRANSLATE_FROM_DISTANCE) = FIXNUM_0+(From_Count-1);
+ Stack_Ref(TRANSLATE_FROM_DISTANCE) = Make_Unsigned_Fixnum((From_Count - 1));
Thunk = Fast_Vector_Ref(Current, STATE_POINT_AFTER_THUNK);
New_Location = Fast_Vector_Ref(Current, STATE_POINT_NEARER_POINT);
Stack_Ref(TRANSLATE_FROM_POINT) = New_Location;
if ((From_Count == 1) &&
- (Stack_Ref(TRANSLATE_TO_DISTANCE) == FIXNUM_0))
+ (Stack_Ref(TRANSLATE_TO_DISTANCE) == Make_Unsigned_Fixnum(0)))
Stack_Pointer = Simulate_Popping(4);
else Save_Cont();
}
To_Location = Fast_Vector_Ref(To_Location, STATE_POINT_NEARER_POINT);
Thunk = Fast_Vector_Ref(To_Location, STATE_POINT_BEFORE_THUNK);
New_Location = To_Location;
- Stack_Ref(TRANSLATE_TO_DISTANCE) = FIXNUM_0+To_Count;
+ Stack_Ref(TRANSLATE_TO_DISTANCE) = Make_Unsigned_Fixnum(To_Count);
if (To_Count==0)
Stack_Pointer = Simulate_Popping(4);
else Save_Cont();
case RC_RESTORE_DONT_COPY_HISTORY:
{ Pointer Stacklet;
- Previous_Restore_History_Offset = Get_Integer(Pop());
+ Prev_Restore_History_Offset = Get_Integer(Pop());
Stacklet = Pop();
History = Get_Pointer(Fetch_Expression());
- if (Previous_Restore_History_Offset == 0)
- Previous_Restore_History_Stacklet = NULL;
+ if (Prev_Restore_History_Offset == 0)
+ Prev_Restore_History_Stacklet = NULL;
else if (Stacklet == NIL)
- Previous_Restore_History_Stacklet = NULL;
+ Prev_Restore_History_Stacklet = NULL;
else
- Previous_Restore_History_Stacklet = Get_Pointer(Stacklet);
+ Prev_Restore_History_Stacklet = Get_Pointer(Stacklet);
break;
}
Immediate_GC((Free > MemTop) ? 0 : ((MemTop-Free)+1));
}
Import_Registers();
- Previous_Restore_History_Offset = Get_Integer(Pop());
+ Prev_Restore_History_Offset = Get_Integer(Pop());
Stacklet = Pop();
- if (Previous_Restore_History_Offset == 0)
- Previous_Restore_History_Stacklet = NULL;
+ if (Prev_Restore_History_Offset == 0)
+ Prev_Restore_History_Stacklet = NULL;
else
{ if (Stacklet == NIL)
- { Previous_Restore_History_Stacklet = NULL;
- Get_End_Of_Stacklet()[-Previous_Restore_History_Offset] =
+ { Prev_Restore_History_Stacklet = NULL;
+ Get_End_Of_Stacklet()[-Prev_Restore_History_Offset] =
Make_Non_Pointer(TC_RETURN_CODE, RC_RESTORE_HISTORY);
}
else
- { Previous_Restore_History_Stacklet = Get_Pointer(Stacklet);
- Previous_Restore_History_Stacklet[-Previous_Restore_History_Offset] =
+ { Prev_Restore_History_Stacklet = Get_Pointer(Stacklet);
+ Prev_Restore_History_Stacklet[-Prev_Restore_History_Offset] =
Make_Non_Pointer(TC_RETURN_CODE, RC_RESTORE_HISTORY);
}
}
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/interp.h,v 9.22 1987/04/03 00:15:49 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/interp.h,v 9.23 1987/04/16 02:25:05 jinx Rel $
*
* Macros used by the interpreter and some utilities.
*
/* Move from register to static storage and back */
-#if defined(In_Main_Interpreter) && !defined(ENABLE_DEBUGGING_TOOLS)
+/* Note defined() cannot be used because VMS does not understand it. */
+
+#ifdef In_Main_Interpreter
+#ifndef ENABLE_DEBUGGING_TOOLS
+#define Cache_Registers
+#endif
+#endif
+
+#ifdef Cache_Registers
#define Regs Reg_Block
#define Stack_Pointer Reg_Stack_Pointer
#define Import_Val()
#define Import_Registers_Except_Val() Import_Registers()
-#define Import_Registers_After_Primitive()
-#define Export_Registers_Before_Primitive() Export_Registers()
+#define Import_Regs_After_Primitive()
+#define Export_Regs_Before_Primitive() Export_Registers()
#define Env Regs[REGBLOCK_ENV]
#define Val Regs[REGBLOCK_VAL]
CONT_PRINT_EXPR_MESSAGE); \
CRLF(); \
}
-\f
-/* Random utility macros */
-
-#define Pop_Primitive_Frame(NArgs) \
- Stack_Pointer = Simulate_Popping(NArgs)
-
-#define N_Args_Primitive(primitive_code) \
- ((int) Arg_Count_Table[primitive_code])
#define Stop_Trapping() \
{ Trapping = false; \
Return_Hook_Address = NULL; \
}
\f
+/* Primitive utility macros */
+
+#define Internal_Apply_Primitive(primitive_code) \
+ ((*(Primitive_Procedure_Table[primitive_code]))())
+
+#define N_Args_Primitive(primitive_code) \
+ (Primitive_Arity_Table[primitive_code])
+
+#define Internal_Apply_External(external_code) \
+ ((*(External_Procedure_Table[external_code]))())
+
+#define N_Args_External(external_code) \
+ (External_Arity_Table[external_code])
+
+#define Apply_External(N) \
+ Internal_Apply_External(N)
+
+#define Pop_Primitive_Frame(NArgs) \
+ Stack_Pointer = Simulate_Popping(NArgs)
+\f
/* Compiled code utility macros */
/* Going from interpreted code to compiled code */
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/list.c,v 9.22 1987/04/03 00:16:13 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/list.c,v 9.23 1987/04/16 02:25:19 jinx Rel $
*
* List creation and manipulation primitives.
*/
#include "primitive.h"
\f
/* (CONS LEFT RIGHT)
- Creates a pair with left component LEFT and right component
- RIGHT.
+ Creates a pair with left component LEFT and right component
+ RIGHT.
*/
-Built_In_Primitive(Prim_Cons, 2, "CONS")
-{ Primitive_2_Args();
+Built_In_Primitive(Prim_Cons, 2, "CONS", 0x20)
+{
+ Primitive_2_Args();
+
Primitive_GC_If_Needed(2);
*Free++ = Arg1;
*Free++ = Arg2;
}
/* (CDR PAIR)
- Returns the second element in the pair. By convention, (CAR
- NIL) is NIL.
+ Returns the second element in the pair.
*/
-Built_In_Primitive(Prim_Cdr, 1, "CDR")
-{ Primitive_1_Arg();
- if (Arg1 == NIL) return NIL;
- Arg_1_Type(TC_LIST);
- return Vector_Ref(Arg1, CONS_CDR);
+Built_In_Primitive(Prim_Cdr, 1, "CDR", 0x22)
+{
+ Primitive_1_Arg();
+
+ Arg_1_Type(TC_LIST);
+ return Vector_Ref(Arg1, CONS_CDR);
}
/* (CAR PAIR)
- Returns the first element in the pair. By convention, (CAR NIL)
- is NIL.
+ Returns the first element in the pair.
*/
-Built_In_Primitive(Prim_Car, 1, "CAR")
-{ Primitive_1_Arg();
- if (Arg1 == NIL) return NIL;
+Built_In_Primitive(Prim_Car, 1, "CAR", 0x21)
+{
+ Primitive_1_Arg();
+
Arg_1_Type(TC_LIST);
return Vector_Ref(Arg1, CONS_CAR);
}
\f
-/* (GENERAL_CAR_CDR LIST DIRECTIONS)
- DIRECTIONS encodes a string of CAR and CDR operations to be
- performed on LIST as follows:
- 1 = NOP 101 = CDAR
- 10 = CDR 110 = CADR
- 11 = CAR 111 = CAAR
- 100 = CDDR ...
+/* (GENERAL-CAR-CDR LIST DIRECTIONS)
+ DIRECTIONS encodes a string of CAR and CDR operations to be
+ performed on LIST as follows:
+ 1 = NOP 101 = CDAR
+ 10 = CDR 110 = CADR
+ 11 = CAR 111 = CAAR
+ 100 = CDDR ...
*/
-Built_In_Primitive(Prim_General_Car_Cdr, 2, "GENERAL-CAR-CDR")
-{ fast long CAR_CDR_Pattern;
+Built_In_Primitive(Prim_General_Car_Cdr, 2, "GENERAL-CAR-CDR", 0x27)
+{
+ fast long CAR_CDR_Pattern;
Primitive_2_Args();
+
Arg_2_Type(TC_FIXNUM);
CAR_CDR_Pattern = Get_Integer(Arg2);
while (CAR_CDR_Pattern > 1)
- { Touch_In_Primitive(Arg1, Arg1);
- if (Arg1 == NIL) return NIL;
+ {
+ Touch_In_Primitive(Arg1, Arg1);
if (Type_Code(Arg1) != TC_LIST)
Primitive_Error(ERR_ARG_1_WRONG_TYPE);
Arg1 =
}
\f
/* (ASSQ ITEM A-LIST)
- Searches the association list A-LIST for ITEM, using EQ? for
- testing equality. Returns NIL if ITEM is not found, or the tail
- of the list whose CAAR is ITEM.
+ Searches the association list A-LIST for ITEM, using EQ? for
+ testing equality. Returns NIL if ITEM is not found, or the tail
+ of the list whose CAAR is ITEM.
*/
-Built_In_Primitive(Prim_Assq, 2, "ASSQ")
-{ Pointer This_Assoc_Pair, Key;
+Built_In_Primitive(Prim_Assq, 2, "ASSQ", 0x5E)
+{
+ Pointer This_Assoc_Pair, Key;
Primitive_2_Args();
Touch_In_Primitive(Arg1, Arg1);
Touch_In_Primitive(Arg2, Arg2);
while (Type_Code(Arg2) == TC_LIST)
- { Touch_In_Primitive(Vector_Ref(Arg2, CONS_CAR), This_Assoc_Pair);
+ {
+ Touch_In_Primitive(Vector_Ref(Arg2, CONS_CAR), This_Assoc_Pair);
if (Type_Code(This_Assoc_Pair) != TC_LIST)
Primitive_Error(ERR_ARG_2_WRONG_TYPE);
Touch_In_Primitive(Vector_Ref(This_Assoc_Pair, CONS_CAR), Key);
- if (Key == Arg1) return This_Assoc_Pair;
+ if (Key == Arg1)
+ return This_Assoc_Pair;
Touch_In_Primitive(Vector_Ref(Arg2, CONS_CDR), Arg2);
}
- if (Arg2 != NIL) Primitive_Error(ERR_ARG_2_WRONG_TYPE);
+ if (Arg2 != NIL)
+ Primitive_Error(ERR_ARG_2_WRONG_TYPE);
return NIL;
}
/* (LENGTH LIST)
- Returns the number of items in the list. By convention, (LENGTH
- NIL) is 0. LENGTH will loop forever if given a circular
- structure.
+ Returns the number of items in the list.
+ LENGTH will loop forever if given a circular structure.
*/
-Built_In_Primitive(Prim_Length, 1, "LENGTH")
-{ fast long i;
+Built_In_Primitive(Prim_Length, 1, "LENGTH", 0x5D)
+{
+ fast long i;
Primitive_1_Arg();
+
i = 0;
Touch_In_Primitive(Arg1, Arg1);
while (Type_Code(Arg1) == TC_LIST)
- { i += 1;
+ {
+ i += 1;
Touch_In_Primitive(Vector_Ref(Arg1, CONS_CDR), Arg1);
}
- if (Arg1 != NIL) Primitive_Error(ERR_ARG_1_WRONG_TYPE);
- return FIXNUM_0+i;
+ if (Arg1 != NIL)
+ Primitive_Error(ERR_ARG_1_WRONG_TYPE);
+ return Make_Unsigned_Fixnum(i);
}
\f
/* (MEMQ ITEM LIST)
- Searches LIST for ITEM, using EQ? as a test. Returns NIL if it
- is not found, or the [first] tail of LIST whose CAR is ITEM.
+ Searches LIST for ITEM, using EQ? as a test. Returns NIL if it
+ is not found, or the sublist of LIST whose CAR is ITEM.
*/
-Built_In_Primitive(Prim_Memq, 2, "MEMQ")
-{ fast Pointer Key;
+Built_In_Primitive(Prim_Memq, 2, "MEMQ", 0x1C)
+{
+ fast Pointer Key;
Primitive_2_Args();
+
Touch_In_Primitive(Arg1, Arg1);
Touch_In_Primitive(Arg2, Arg2);
while (Type_Code(Arg2) == TC_LIST)
- { Touch_In_Primitive(Vector_Ref(Arg2, CONS_CAR), Key);
- if (Arg1 == Key) return Arg2;
- else Touch_In_Primitive(Vector_Ref(Arg2, CONS_CDR), Arg2);
+ {
+ Touch_In_Primitive(Vector_Ref(Arg2, CONS_CAR), Key);
+ if (Arg1 == Key)
+ return Arg2;
+ else
+ Touch_In_Primitive(Vector_Ref(Arg2, CONS_CDR), Arg2);
}
- if (Arg2 != NIL) Primitive_Error(ERR_ARG_2_WRONG_TYPE);
+ if (Arg2 != NIL)
+ Primitive_Error(ERR_ARG_2_WRONG_TYPE);
return NIL;
}
-/* (SET_CAR PAIR VALUE)
- Stores VALUE in the CAR of PAIR. Returns (bad style to count on
- this) the previous CAR of PAIR.
+/* (SET-CAR! PAIR VALUE)
+ Stores VALUE in the CAR of PAIR. Returns the previous CAR of PAIR.
*/
-Built_In_Primitive(Prim_Set_Car, 2, "SET-CAR!")
-{ Primitive_2_Args();
+Built_In_Primitive(Prim_Set_Car, 2, "SET-CAR!", 0x23)
+{
+ Primitive_2_Args();
+
Arg_1_Type(TC_LIST);
Side_Effect_Impurify(Arg1, Arg2);
return Swap_Pointers(Nth_Vector_Loc(Arg1, CONS_CAR), Arg2);
}
-/* (SET_CDR PAIR VALUE)
- Stores VALUE in the CDR of PAIR. Returns (bad style to count on
- this) the previous CDR of PAIR.
+/* (SET-CDR! PAIR VALUE)
+ Stores VALUE in the CDR of PAIR. Returns the previous CDR of PAIR.
*/
-Built_In_Primitive(Prim_Set_Cdr, 2, "SET-CDR!")
-{ Primitive_2_Args();
+Built_In_Primitive(Prim_Set_Cdr, 2, "SET-CDR!", 0x24)
+{
+ Primitive_2_Args();
+
Arg_1_Type(TC_LIST);
Side_Effect_Impurify(Arg1, Arg2);
return Swap_Pointers(Nth_Vector_Loc(Arg1, CONS_CDR), Arg2);
}
\f
/* (PAIR? OBJECT)
- Returns #!TRUE if OBJECT has the type-code LIST (ie if it was
- created by CONS). Return NIL otherwise.
+ Returns #!TRUE if OBJECT has the type-code LIST (ie if it was
+ created by CONS). Returns NIL otherwise.
*/
-Built_In_Primitive(Prim_Pair, 1, "PAIR?")
-{ Primitive_1_Arg();
+Built_In_Primitive(Prim_Pair, 1, "PAIR?", 0x7E)
+{
+ Primitive_1_Arg();
+
Touch_In_Primitive(Arg1, Arg1);
- if (Type_Code(Arg1) == TC_LIST) return TRUTH;
- else return NIL;
+ if (Type_Code(Arg1) == TC_LIST)
+ return TRUTH;
+ else
+ return NIL;
}
/* (SYSTEM-PAIR? OBJECT)
- Returns #!TRUE if the garbage collector type of OBJECT is PAIR.
+ Returns #!TRUE if the garbage collector type of OBJECT is PAIR.
*/
-Built_In_Primitive(Prim_Sys_Pair, 1, "SYSTEM-PAIR?")
+Built_In_Primitive(Prim_Sys_Pair, 1, "SYSTEM-PAIR?", 0x85)
{
Primitive_1_Arg();
}
\f
/* (SYSTEM-PAIR-CAR GC-PAIR)
- Same as CAR, but for anything of GC type PAIR.
+ Same as CAR, but for anything of GC type PAIR.
*/
-Built_In_Primitive(Prim_Sys_Pair_Car, 1, "SYSTEM-PAIR-CAR")
-{ Primitive_1_Arg();
+Built_In_Primitive(Prim_Sys_Pair_Car, 1, "SYSTEM-PAIR-CAR", 0x86)
+{
+ Primitive_1_Arg();
+
Arg_1_GC_Type(GC_Pair);
return Vector_Ref(Arg1, CONS_CAR);
}
/* (SYSTEM-PAIR-CDR GC-PAIR)
- Same as CDR, but for anything of GC type PAIR.
+ Same as CDR, but for anything of GC type PAIR.
*/
-Built_In_Primitive(Prim_Sys_Pair_Cdr, 1, "SYSTEM-PAIR-CDR")
-{ Primitive_1_Arg();
+Built_In_Primitive(Prim_Sys_Pair_Cdr, 1, "SYSTEM-PAIR-CDR", 0x87)
+{
+ Primitive_1_Arg();
+
Arg_1_GC_Type(GC_Pair);
return Vector_Ref(Arg1, CONS_CDR);
}
/* (SYSTEM-PAIR-CONS TYPE-CODE OBJECT-1 OBJECT-2)
- Like CONS, but returns an object with the specified type code
- (not limited to type code LIST).
+ Like CONS, but returns an object with the specified type code
+ (not limited to type code LIST).
*/
-Built_In_Primitive(Prim_Sys_Pair_Cons, 3, "SYSTEM-PAIR-CONS")
-{ long Type;
+Built_In_Primitive(Prim_Sys_Pair_Cons, 3, "SYSTEM-PAIR-CONS", 0x84)
+{
+ long Type;
Primitive_3_Args();
+
Arg_1_Type(TC_FIXNUM);
Range_Check(Type, Arg1, 0, MAX_SAFE_TYPE,
ERR_ARG_1_BAD_RANGE);
if (GC_Type_Code(Type) == GC_Pair)
- { Primitive_GC_If_Needed(2);
+ {
+ Primitive_GC_If_Needed(2);
*Free++ = Arg2;
*Free++ = Arg3;
return Make_Pointer(Type, Free-2);
}
- else Primitive_Error(ERR_ARG_1_BAD_RANGE); /*NOTREACHED*/
+ else
+ Primitive_Error(ERR_ARG_1_BAD_RANGE);
+ /*NOTREACHED*/
}
\f
/* (SYSTEM-PAIR-SET-CAR! GC-PAIR NEW_CAR)
- Same as SET_CAR, but for anything of GC type PAIR.
+ Same as SET-CAR!, but for anything of GC type PAIR.
*/
-Built_In_Primitive(Prim_Sys_Set_Car, 2, "SYSTEM-PAIR-SET-CAR!")
-{ Primitive_2_Args();
+Built_In_Primitive(Prim_Sys_Set_Car, 2, "SYSTEM-PAIR-SET-CAR!", 0x88)
+{
+ Primitive_2_Args();
+
Arg_1_GC_Type(GC_Pair);
Side_Effect_Impurify(Arg1, Arg2);
return Swap_Pointers(Nth_Vector_Loc(Arg1, CONS_CAR), Arg2);
}
/* (SYSTEM-PAIR-SET-CDR! GC-PAIR NEW_CDR)
- Same as SET_CDR, but for anything of GC type PAIR.
+ Same as SET-CDR!, but for anything of GC type PAIR.
*/
-Built_In_Primitive(Prim_Sys_Set_Cdr, 2, "SYSTEM-PAIR-SET-CDR!")
-{ Primitive_2_Args();
+Built_In_Primitive(Prim_Sys_Set_Cdr, 2, "SYSTEM-PAIR-SET-CDR!", 0x89)
+{
+ Primitive_2_Args();
+
Arg_1_GC_Type(GC_Pair);
Side_Effect_Impurify(Arg1, Arg2);
return Swap_Pointers(Nth_Vector_Loc(Arg1, CONS_CDR), Arg2);
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.21 1987/01/22 14:28:35 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/load.c,v 9.22 1987/04/16 02:25:31 jinx Exp $
*
* This file contains common code for reading internal
* format binary files.
Pointer Ext_Prim_Vector;
Boolean Found_Ext_Prims, Byte_Invert_Fasl_Files;
-Boolean Read_Header()
-{ Pointer Buffer[FASL_HEADER_LENGTH];
+Boolean
+Read_Header()
+{
+ Pointer Buffer[FASL_HEADER_LENGTH];
Pointer Pointer_Heap_Base, Pointer_Const_Base;
+
Load_Data(FASL_OLD_LENGTH, (char *) Buffer);
- if (Buffer[FASL_Offset_Marker] != FASL_FILE_MARKER) 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]);
+ Byte_Invert_Header(Buffer,
+ (sizeof(Buffer) / sizeof(Pointer)),
+ Buffer[FASL_Offset_Heap_Base],
+ Buffer[FASL_Offset_Heap_Count]);
#endif
Heap_Count = Get_Integer(Buffer[FASL_Offset_Heap_Count]);
Pointer_Heap_Base = Buffer[FASL_Offset_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 (Sub_Version >= FASL_LONG_HEADER)
- { Load_Data(FASL_HEADER_LENGTH-FASL_OLD_LENGTH,
- (char *) &(Buffer[FASL_OLD_LENGTH]));
-#if BYTE_INVERSION
- Byte_Invert_Region((char *) &(Buffer[FASL_OLD_LENGTH]),
- FASL_HEADER_LENGTH-FASL_OLD_LENGTH);
+ Load_Data((FASL_HEADER_LENGTH - FASL_OLD_LENGTH),
+ ((char *) &(Buffer[FASL_OLD_LENGTH])));
+#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]));
- }
- else Ext_Prim_Vector = NIL;
+ Ext_Prim_Vector =
+ Make_Non_Pointer(TC_CELL, Datum(Buffer[FASL_Offset_Ext_Loc]));
if (Reloc_or_Load_Debug)
- { printf("\nHeap_Count = %d; Heap_Base = %x; Dumped_Heap_Top = %x\n",
+ {
+ printf("\nHeap_Count = %d; Heap_Base = %x; Dumped_Heap_Top = %x\n",
Heap_Count, Heap_Base, Dumped_Heap_Top);
printf("C_Count = %d; C_Base = %x, Dumped_C_Top = %x\n",
Const_Count, Const_Base, Dumped_Constant_Top);
}
#ifdef BYTE_INVERSION
+
Byte_Invert_Header(Header, Headsize, Test1, Test2)
-long *Header, Headsize, Test1, Test2;
-{ Byte_Invert_Fasl_Files = false;
+ long *Header, Headsize, Test1, Test2;
+{
+ Byte_Invert_Fasl_Files = false;
if ((Test1 & 0xff) == TC_BROKEN_HEART &&
(Test2 & 0xff) == TC_BROKEN_HEART &&
(Type_Code(Test1) != TC_BROKEN_HEART ||
- Type_Code(Test2) != TC_BROKEN_HEART)) {
+ Type_Code(Test2) != TC_BROKEN_HEART))
+ {
Byte_Invert_Fasl_Files = true;
- Byte_Invert_Region(Header,Headsize); }
+ Byte_Invert_Region(Header, Headsize);
+ }
}
Byte_Invert_Region(Region, Size)
-long *Region, Size;
-{ register long word, 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); } }
+ for (size = Size; size > 0; size--, Region++)
+ {
+ word = (*Region);
+ *Region = (((word>>24)&0xff) | ((word>>8)&0xff00) |
+ ((word<<8)&0xff0000) | ((word<<24)&0xff000000));
+ }
+}
+
#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.h,v 9.35 1987/04/03 00:47:02 jinx Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/lookup.h,v 9.36 1987/04/16 02:26:04 jinx Exp $ */
/* Macros and declarations for the variable lookup code. */
#define AUX_LIST_TYPE TC_VECTOR
#define AUX_CHUNK_SIZE 20
-#define AUX_LIST_COUNT ENVIRONMENT_EXTENSION_COUNT
-#define AUX_LIST_FIRST ENVIRONMENT_EXTENSION_MIN_SIZE
+#define AUX_LIST_COUNT ENV_EXTENSION_COUNT
+#define AUX_LIST_FIRST ENV_EXTENSION_MIN_SIZE
#define AUX_LIST_INITIAL_SIZE (AUX_LIST_FIRST + AUX_CHUNK_SIZE)
/* Variable compilation types. */
\f
/* The code below depends on the following. */
-#if ((VARIABLE_OFFSET == VARIABLE_COMPILED_TYPE) || \
- (VARIABLE_FRAME_NO != VARIABLE_COMPILED_TYPE))
-#include "error: trap.h inconsistency detected."
+/* Done as follows because of VMS. */
+
+#define lookup_inconsistency_p \
+ ((VARIABLE_OFFSET == VARIABLE_COMPILED_TYPE) || \
+ (VARIABLE_FRAME_NO != VARIABLE_COMPILED_TYPE))
+
+#if (lookup_inconsistency_p)
+#include "error: lookup.h inconsistency detected."
#endif
#define get_offset(hunk) Lexical_Offset(Fetch(hunk[VARIABLE_OFFSET]))
/* Unlike Lock_Cell, cell must be (Pointer *). This currently does
not matter, but might on a machine with address mapping.
*/
+
#define setup_lock(handle, cell) handle = Lock_Cell(cell)
#define remove_lock(handle) Unlock_Cell(handle)
break; \
\
case FORMAL_REF: \
- { \
- fast long depth; \
- \
- verify(FORMAL_REF, offset, get_offset(hunk), label); \
+ lookup_formal(cell, env, hunk, label); \
\
- depth = Get_Integer(frame); \
- frame = env; \
- while(--depth >= 0) \
- { \
- frame = Fast_Vector_Ref(Vector_Ref(frame, ENVIRONMENT_FUNCTION), \
- PROCEDURE_ENVIRONMENT); \
- } \
- \
- cell = Nth_Vector_Loc(frame, \
- verified_offset(offset, get_offset(hunk))); \
- \
- break; \
- } \
-\f \
case AUX_REF: \
- { \
- fast long depth; \
- \
- verify(AUX_REF, offset, get_offset(hunk), label); \
- \
- depth = Get_Integer(frame); \
- frame = env; \
- while(--depth >= 0) \
- { \
- frame = Fast_Vector_Ref(Vector_Ref(frame, ENVIRONMENT_FUNCTION), \
- PROCEDURE_ENVIRONMENT); \
- } \
- \
- frame = Vector_Ref(frame, ENVIRONMENT_FUNCTION); \
- if (Type_Code(frame) != AUX_LIST_TYPE) \
- { \
- cell = uncompiled_trap_object; \
- break; \
- } \
- depth = verified_offset(offset, get_offset(hunk)); \
- if (depth > Vector_Length(frame)) \
- { \
- cell = uncompiled_trap_object; \
- break; \
- } \
- frame = Vector_Ref(frame, depth); \
- if ((frame == NIL) || \
- (Fast_Vector_Ref(frame, CONS_CAR) != hunk[VARIABLE_SYMBOL])) \
- { \
- cell = uncompiled_trap_object; \
- break; \
- } \
- cell = Nth_Vector_Loc(frame, CONS_CDR); \
- break; \
- } \
+ lookup_aux(cell, env, hunk, label); \
\
default: \
/* Done here rather than in a separate case because of \
} \
}
\f
+#define lookup_formal(cell, env, hunk, label) \
+{ \
+ fast long depth; \
+ \
+ verify(FORMAL_REF, offset, get_offset(hunk), label); \
+ depth = Get_Integer(frame); \
+ frame = env; \
+ while(--depth >= 0) \
+ { \
+ frame = Fast_Vector_Ref(Vector_Ref(frame, ENVIRONMENT_FUNCTION), \
+ PROCEDURE_ENVIRONMENT); \
+ } \
+ \
+ cell = Nth_Vector_Loc(frame, \
+ verified_offset(offset, get_offset(hunk))); \
+ \
+ break; \
+}
+
+#define lookup_aux(cell, env, hunk, label) \
+{ \
+ fast long depth; \
+ \
+ verify(AUX_REF, offset, get_offset(hunk), label); \
+ depth = Get_Integer(frame); \
+ frame = env; \
+ while(--depth >= 0) \
+ { \
+ frame = Fast_Vector_Ref(Vector_Ref(frame, ENVIRONMENT_FUNCTION), \
+ PROCEDURE_ENVIRONMENT); \
+ } \
+ \
+ frame = Vector_Ref(frame, ENVIRONMENT_FUNCTION); \
+ if (Type_Code(frame) != AUX_LIST_TYPE) \
+ { \
+ cell = uncompiled_trap_object; \
+ break; \
+ } \
+ depth = verified_offset(offset, get_offset(hunk)); \
+ if (depth > Vector_Length(frame)) \
+ { \
+ cell = uncompiled_trap_object; \
+ break; \
+ } \
+ frame = Vector_Ref(frame, depth); \
+ if ((frame == NIL) || \
+ (Fast_Vector_Ref(frame, CONS_CAR) != hunk[VARIABLE_SYMBOL])) \
+ { \
+ cell = uncompiled_trap_object; \
+ break; \
+ } \
+ cell = Nth_Vector_Loc(frame, CONS_CDR); \
+ break; \
+}
+\f
#define lookup_primitive_type_test() \
{ \
if (Type_Code(Arg1) != GLOBAL_ENV) Arg_1_Type(TC_ENVIRONMENT); \
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.27 1987/04/03 00:17:25 jinx Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/memmag.c,v 9.28 1987/04/16 02:26:14 jinx Exp $ */
/* Memory management top level.
void
Clear_Memory(Our_Heap_Size, Our_Stack_Size, Our_Constant_Size)
-int Our_Heap_Size, Our_Stack_Size, Our_Constant_Size;
-{ Heap_Top = Heap_Bottom + Our_Heap_Size;
+ int Our_Heap_Size, Our_Stack_Size, Our_Constant_Size;
+{
+ 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);
void
Setup_Memory(Our_Heap_Size, Our_Stack_Size, Our_Constant_Size)
-int Our_Heap_Size, Our_Stack_Size, Our_Constant_Size;
+ int Our_Heap_Size, Our_Stack_Size, Our_Constant_Size;
{
/* Consistency check 1 */
if (Our_Heap_Size == 0)
- { printf("Configuration won't hold initial data.\n");
+ {
+ fprintf(stderr, "Configuration won't hold initial data.\n");
exit(1);
}
/* Consistency check 2 */
if (Heap == NULL)
- { fprintf(stderr, "Not enough memory for this configuration.\n");
+ {
+ fprintf(stderr, "Not enough memory for this configuration.\n");
exit(1);
}
/* Consistency check 3 */
if (((C_To_Scheme(Highest_Allocated_Address)) & TYPE_CODE_MASK) != 0)
- { fprintf(stderr,
+ {
+ fprintf(stderr,
"Largest address does not fit in datum field of Pointer.\n");
fprintf(stderr,
"Allocate less space or re-compile without Heap_In_Low_Memory.\n");
}
/* In this version, this does nothing. */
+
void
Reset_Memory()
-{ return;
+{
+ return;
}
\f
/* Utilities for the garbage collector top level.
/* Flip into unused heap */
-void GCFlip()
-{ Pointer *Temp;
+void
+GCFlip()
+{
+ Pointer *Temp;
+
Temp = Unused_Heap;
Unused_Heap = Heap_Bottom;
Heap_Bottom = Temp;
collector, which looks at both old and new space.
*/
-void Fix_Weak_Chain()
-{ fast Pointer *Old_Weak_Cell, *Scan, Old_Car, Temp, *Old, *Low_Constant;
+Pointer Weak_Chain;
+
+void
+Fix_Weak_Chain()
+{
+ fast Pointer *Old_Weak_Cell, *Scan, Old_Car, Temp, *Old, *Low_Constant;
+
Low_Constant = Constant_Space;
while (Weak_Chain != NIL)
- { Old_Weak_Cell = Get_Pointer(Weak_Chain);
+ {
+ Old_Weak_Cell = Get_Pointer(Weak_Chain);
Scan = Get_Pointer(*Old_Weak_Cell++);
Weak_Chain = *Old_Weak_Cell;
Old_Car = *Scan;
case GC_Vector:
Old = Get_Pointer(Old_Car);
if (Old >= Low_Constant)
- { *Scan = Temp;
+ {
+ *Scan = Temp;
continue;
}
Normal_BH(false, continue);
case GC_Compiled:
Old = Get_Pointer(Old_Car);
if (Old >= Low_Constant)
- { *Scan = Temp;
+ {
+ *Scan = Temp;
continue;
}
Compiled_BH(false, continue);
*Free++ = Make_Pointer(TC_HUNK3, History);
*Free++ = Undefined_Externals;
*Free++ = Get_Current_Stacklet();
- *Free++ = ((Previous_Restore_History_Stacklet == NULL) ?
+ *Free++ = ((Prev_Restore_History_Stacklet == NULL) ?
NIL :
- Make_Pointer(TC_CONTROL_POINT, Previous_Restore_History_Stacklet));
+ Make_Pointer(TC_CONTROL_POINT, Prev_Restore_History_Stacklet));
*Free++ = Current_State_Point;
*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");
+ {
+ 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");
+ {
+ fprintf(stderr, "\nGC-1: Heap Scan ended too early.\n");
Microcode_Termination(TERM_BROKEN_HEART);
}
Root2 = Free;
*Free++ = The_Precious_Objects;
Result = GCLoop(Root2, &Free);
if (Free != Result)
- { fprintf(stderr, "\nGC-2: Heap Scan ended too early.\n");
+ {
+ fprintf(stderr, "\nGC-2: Heap Scan ended too early.\n");
Microcode_Termination(TERM_BROKEN_HEART);
}
Fix_Weak_Chain();
Set_Current_Stacklet(*Root);
Root += 1; /* Set_Current_Stacklet is sometimes a No-Op! */
if (*Root == NIL)
- { Previous_Restore_History_Stacklet = NULL;
+ {
+ Prev_Restore_History_Stacklet = NULL;
Root += 1;
}
- else Previous_Restore_History_Stacklet = Get_Pointer(*Root++);
+ else
+ Prev_Restore_History_Stacklet = Get_Pointer(*Root++);
Current_State_Point = *Root++;
Fluid_Bindings = *Root++;
Free_Stacklets = NULL;
}
\f
/* (GARBAGE-COLLECT SLACK)
- Requests a garbage collection leaving the specified amount of slack
- for the top of heap check on the next GC. The primitive ends by invoking
- the GC daemon if there is one.
+ Requests a garbage collection leaving the specified amount of slack
+ for the top of heap check on the next GC. The primitive ends by invoking
+ the GC daemon if there is one.
- This primitive never returns normally. It always escapes into
- the interpreter because some of its cached registers (eg. History)
- have changed.
+ This primitive never returns normally. It always escapes into
+ the interpreter because some of its cached registers (eg. History)
+ have changed.
*/
-Built_In_Primitive(Prim_Garbage_Collect, 1, "GARBAGE-COLLECT")
-{ Pointer GC_Daemon_Proc;
+Built_In_Primitive(Prim_Garbage_Collect, 1, "GARBAGE-COLLECT", 0x3A)
+{
+ Pointer GC_Daemon_Proc;
Primitive_1_Arg();
Arg_1_Type(TC_FIXNUM);
if (Free > Heap_Top)
- { fprintf(stderr,
+ {
+ fprintf(stderr,
"\nGC has been delayed too long, and you are out of room!\n");
fprintf(stderr,
"Free = 0x%x; MemTop = 0x%x; Heap_Top = 0x%x\n",
GC();
IntCode &= ~INT_GC;
if (GC_Check(GC_Space_Needed))
- { fprintf(stderr,
+ {
+ fprintf(stderr,
"\nGC just ended. The free pointer is at 0x%x, the top of this heap\n",
Free);
fprintf(stderr,
}
Will_Push(CONTINUATION_SIZE + (STACK_ENV_EXTRA_SLOTS+1));
Store_Return(RC_NORMAL_GC_DONE);
- Store_Expression(FIXNUM_0 + (MemTop - Free));
+ Store_Expression(Make_Unsigned_Fixnum(MemTop - Free));
Save_Cont();
Push(GC_Daemon_Proc);
Push(STACK_FRAME_HEADER);
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/mul.c,v 9.21 1987/01/22 14:29:18 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/mul.c,v 9.22 1987/04/16 02:26:41 jinx Rel $
*
* This file contains the portable fixnum multiplication procedure.
* Returns NIL if the result does not fit in a fixnum.
#define MAX_FIXNUM (1<<ADDRESS_LENGTH)
#define ABS(x) (((x) < 0) ? -(x) : (x))
-Pointer Mul(Arg1, Arg2)
-long Arg1, Arg2;
-{ long A, B, C;
+Pointer
+Mul(Arg1, Arg2)
+ long Arg1, Arg2;
+{
+ long A, B, C;
fast long Hi_A, Hi_B, Lo_A, Lo_B, Lo_C, Middle_C;
Boolean Sign;
- Sign_Extend(Arg1, A); Sign_Extend(Arg2, B);
+
+ Sign_Extend(Arg1, A);
+ Sign_Extend(Arg2, B);
Sign = ((A < 0) == (B < 0));
- A = ABS(A); B = ABS(B);
- Hi_A = (A >> HALF_WORD_SIZE) & HALF_WORD_MASK;
- Hi_B = (B >> HALF_WORD_SIZE) & HALF_WORD_MASK;
- Lo_A = A & HALF_WORD_MASK; Lo_B = B & HALF_WORD_MASK;
- Lo_C = Lo_A * Lo_B;
- if (Lo_C > FIXNUM_SIGN_BIT) return NIL;
- Middle_C = Lo_A * Hi_B + Hi_A * Lo_B;
- if (Middle_C >= MAX_MIDDLE) return NIL;
- if ((Hi_A * Hi_B) > 0) return NIL;
+ A = ABS(A);
+ B = ABS(B);
+ Hi_A = ((A >> HALF_WORD_SIZE) & HALF_WORD_MASK);
+ Hi_B = ((B >> HALF_WORD_SIZE) & HALF_WORD_MASK);
+ Lo_A = (A & HALF_WORD_MASK);
+ Lo_B = (B & HALF_WORD_MASK);
+ Lo_C = (Lo_A * Lo_B);
+ if (Lo_C > FIXNUM_SIGN_BIT)
+ return NIL;
+ Middle_C = (Lo_A * Hi_B) + (Hi_A * Lo_B);
+ if (Middle_C >= MAX_MIDDLE)
+ return NIL;
+ if ((Hi_A > 0) && (Hi_B > 0))
+ return NIL;
C = Lo_C + (Middle_C << HALF_WORD_SIZE);
if (Fixnum_Fits(C))
- { if (Sign || (C == 0)) return FIXNUM_0 + C;
- else return FIXNUM_0 + (MAX_FIXNUM - C);
+ {
+ if (Sign || (C == 0))
+ return Make_Unsigned_Fixnum(C);
+ else
+ return Make_Unsigned_Fixnum(MAX_FIXNUM - C);
}
return 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/object.h,v 9.21 1987/04/03 00:18:15 jinx Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/object.h,v 9.22 1987/04/16 02:27:09 jinx Exp $ */
/* This file contains definitions pertaining to the C view of
Scheme pointers: widths of fields, extraction macros, pre-computed
\f
#define Make_Pointer(TC, A) Make_Object((TC), C_To_Scheme(A))
#define Make_Non_Pointer(TC, D) Make_Object(TC, ((Pointer) (D)))
-#define Make_Unsigned_Fixnum(N) (FIXNUM_0 + (N))
-#define Make_Signed_Fixnum(N) Make_Non_Pointer( TC_FIXNUM, (N))
/* (Make_New_Pointer (TC, A)) may be more efficient than
(Make_Pointer (TC, (Get_Pointer (A)))) */
#define User_Vector_Ref(P, N) Vector_Ref(P, (N)+1)
#define User_Vector_Set(P, N, S) Vector_Set(P, (N)+1, S)
\f
+#define Make_Broken_Heart(N) (BROKEN_HEART_ZERO + (N))
+#define Make_Unsigned_Fixnum(N) (FIXNUM_ZERO + (N))
+#define Make_Signed_Fixnum(N) Make_Non_Pointer( TC_FIXNUM, (N))
#define fixnum_p(P) ((pointer_type (P)) == TC_FIXNUM)
#define Get_Float(P) (* ((double *) (Nth_Vector_Loc ((P), 1))))
#define Get_Integer(P) (pointer_datum (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/prim.c,v 9.23 1987/04/03 00:18:31 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/prim.c,v 9.24 1987/04/16 02:27:21 jinx Exp $
*
* The leftovers ... primitives that don't seem to belong elsewhere.
*
\f
/* Random predicates: */
-/* (NULL OBJECT)
- Returns #!TRUE if OBJECT is NIL. Otherwise returns NIL. This is
- the primitive known as NOT, NIL?, and NULL? in Scheme.
+/* (NULL? OBJECT)
+ Returns #!TRUE if OBJECT is NIL. Otherwise returns NIL. This is
+ the primitive known as NOT, NIL?, and NULL? in Scheme.
*/
-Built_In_Primitive(Prim_Null, 1, "NULL?")
+Built_In_Primitive(Prim_Null, 1, "NULL?", 0xC)
{
Primitive_1_Arg();
}
/* (EQ? OBJECT-1 OBJECT-2)
- Returns #!TRUE if the two objects have the same type code
- and datum. Returns NIL otherwise.
+ Returns #!TRUE if the two objects have the same type code
+ and datum. Returns NIL otherwise.
*/
-Built_In_Primitive(Prim_Eq, 2, "EQ?")
+Built_In_Primitive(Prim_Eq, 2, "EQ?", 0xD)
{
Primitive_2_Args();
- if (Arg1 == Arg2) return TRUTH;
+ if (Arg1 == Arg2)
+ return TRUTH;
Touch_In_Primitive(Arg1, Arg1);
Touch_In_Primitive(Arg2, Arg2);
- return (Arg1 == Arg2) ? TRUTH : NIL;
+ return ((Arg1 == Arg2) ? TRUTH : NIL);
}
\f
/* Pointer manipulation */
-/* (MAKE-NON-POINTER NUMBER)
- Returns an (extended) fixnum with the same value as NUMBER. In
- the CScheme interpreter this is basically a no-op, since fixnums
- already store 24 bits.
+/* (MAKE-NON-POINTER-OBJECT NUMBER)
+ Returns an (extended) fixnum with the same value as NUMBER. In
+ the CScheme interpreter this is basically a no-op, since fixnums
+ already store 24 bits.
*/
-Built_In_Primitive(Prim_Make_Non_Pointer, 1, "MAKE-NON-POINTER")
+Built_In_Primitive(Prim_Make_Non_Pointer, 1,
+ "MAKE-NON-POINTER-OBJECT", 0xB1)
{
Primitive_1_Arg();
}
/* (PRIMITIVE-DATUM OBJECT)
- Returns the datum part of OBJECT.
+ Returns the datum part of OBJECT.
*/
-Built_In_Primitive(Prim_Primitive_Datum, 1, "PRIMITIVE-DATUM")
+Built_In_Primitive(Prim_Primitive_Datum, 1, "PRIMITIVE-DATUM", 0xB0)
{
Primitive_1_Arg();
}
/* (PRIMITIVE-TYPE OBJECT)
- Returns the type code of OBJECT as a number.
- Note: THE OBJECT IS TOUCHED FIRST.
+ Returns the type code of OBJECT as a number.
+ Note: THE OBJECT IS TOUCHED FIRST.
*/
-Built_In_Primitive(Prim_Prim_Type, 1, "PRIMITIVE-TYPE")
+Built_In_Primitive(Prim_Prim_Type, 1, "PRIMITIVE-TYPE", 0x10)
{
Primitive_1_Arg();
return Make_Unsigned_Fixnum(Type_Code(Arg1));
}
-/* (GC_TYPE OBJECT)
- Returns a fixnum indicating the GC type of the object. The object
- is NOT touched first.
+/* (PRIMITIVE-GC-TYPE OBJECT)
+ Returns a fixnum indicating the GC type of the object. The object
+ is NOT touched first.
*/
-Built_In_Primitive(Prim_Gc_Type, 1, "GC-TYPE")
+Built_In_Primitive(Prim_Gc_Type, 1, "PRIMITIVE-GC-TYPE", 0xBC)
{
Primitive_1_Arg();
}
\f
/* (PRIMITIVE-TYPE? TYPE-CODE OBJECT)
- Return #!TRUE if the type code of OBJECT is TYPE-CODE, NIL
- otherwise.
- Note: THE OBJECT IS TOUCHED FIRST.
+ Return #!TRUE if the type code of OBJECT is TYPE-CODE, NIL
+ otherwise.
+ Note: THE OBJECT IS TOUCHED FIRST.
*/
-Built_In_Primitive(Prim_Prim_Type_QM, 2, "PRIMITIVE-TYPE?")
+Built_In_Primitive(Prim_Prim_Type_QM, 2, "PRIMITIVE-TYPE?", 0xF)
{
Primitive_2_Args();
}
/* (PRIMITIVE-SET-TYPE TYPE-CODE OBJECT)
- Returns a new object with TYPE-CODE and the datum part of
- OBJECT.
- Note : IT TOUCHES ITS SECOND ARGUMENT (for completeness sake).
- This is a "gc-safe" (paranoid) operation.
+ Returns a new object with TYPE-CODE and the datum part of
+ OBJECT.
+ Note : IT TOUCHES ITS SECOND ARGUMENT (for completeness sake).
+ This is a "gc-safe" (paranoid) operation.
*/
-Built_In_Primitive(Prim_Primitive_Set_Type, 2, "PRIMITIVE-SET-TYPE")
+Built_In_Primitive(Prim_Primitive_Set_Type, 2, "PRIMITIVE-SET-TYPE", 0x11)
{
long New_GC_Type, New_Type;
Primitive_2_Args();
if ((GC_Type(Arg2) == New_GC_Type) ||
(New_GC_Type == GC_Non_Pointer))
return Make_New_Pointer(New_Type, Arg2);
- else Primitive_Error(ERR_ARG_1_BAD_RANGE); /*NOTREACHED*/
+ else
+ Primitive_Error(ERR_ARG_1_BAD_RANGE);
+ /*NOTREACHED*/
}
\f
/* Subprimitives.
OBJECT, and whose type code is TYPE-CODE. It does not touch.
*/
-Built_In_Primitive(Prim_And_Make_Object, 2, "&MAKE-OBJECT")
+Built_In_Primitive(Prim_And_Make_Object, 2, "&MAKE-OBJECT", 0x8D)
{
long New_Type;
Primitive_2_Args();
Performs no type checking in object.
*/
-Built_In_Primitive(Prim_System_Memory_Ref, 2, "SYSTEM-MEMORY-REF")
+Built_In_Primitive(Prim_System_Memory_Ref, 2, "SYSTEM-MEMORY-REF", 0x195)
{
Primitive_2_Args();
Performs no type checking in object.
*/
-Built_In_Primitive(Prim_System_Memory_Set, 3, "SYSTEM-MEMORY-SET!")
+Built_In_Primitive(Prim_System_Memory_Set, 3, "SYSTEM-MEMORY-SET!", 0x196)
{
long index;
Primitive_3_Args();
\f
/* Playing with the danger bit */
-/* (DANGEROUS? OBJECT)
- Returns #!TRUE if OBJECT has the danger bit set, NIL otherwise.
+/* (OBJECT-DANGEROUS? OBJECT)
+ Returns #!TRUE if OBJECT has the danger bit set, NIL otherwise.
*/
-Built_In_Primitive(Prim_Dangerous_QM, 1, "DANGEROUS?")
+Built_In_Primitive(Prim_Dangerous_QM, 1, "OBJECT-DANGEROUS?", 0x49)
{
Primitive_1_Arg();
}
/* (MAKE-OBJECT-DANGEROUS OBJECT)
- Returns OBJECT, but with the danger bit set.
+ Returns OBJECT, but with the danger bit set.
*/
-Built_In_Primitive(Prim_Dangerize, 1, "MAKE-OBJECT-DANGEROUS")
+Built_In_Primitive(Prim_Dangerize, 1, "MAKE-OBJECT-DANGEROUS", 0x48)
{
Primitive_1_Arg();
return Set_Danger_Bit(Arg1);
}
-/* (UNDANGERIZE OBJECT)
- Returns OBJECT with the danger bit cleared. This does not
- side-effect the object, it merely returns a new (non-dangerous)
- pointer to the same item.
+/* (MAKE-OBJECT-SAFE OBJECT)
+ Returns OBJECT with the danger bit cleared. This does not
+ side-effect the object, it merely returns a new (non-dangerous)
+ pointer to the same item.
*/
-Built_In_Primitive(Prim_Undangerize, 1, "UNDANGERIZE")
+Built_In_Primitive(Prim_Undangerize, 1, "MAKE-OBJECT-SAFE", 0x47)
{
Primitive_1_Arg();
/* Cells */
/* (MAKE-CELL CONTENTS)
- Creates a cell with contents CONTENTS.
+ Creates a cell with contents CONTENTS.
*/
-Built_In_Primitive(Prim_Make_Cell, 1, "MAKE-CELL")
+Built_In_Primitive(Prim_Make_Cell, 1, "MAKE-CELL", 0x61)
{
Primitive_1_Arg();
return Make_Pointer(TC_CELL, Free-1);
}
-/* (CONTENTS CELL)
- Returns the contents of the cell CELL.
+/* (CELL-CONTENTS CELL)
+ Returns the contents of the cell CELL.
*/
-Built_In_Primitive(Prim_Cell_Contents, 1, "CONTENTS")
+Built_In_Primitive(Prim_Cell_Contents, 1, "CELL-CONTENTS", 0x62)
{
Primitive_1_Arg();
}
/* (CELL? OBJECT)
- Returns #!TRUE if OBJECT has type-code CELL, otherwise returns
- NIL.
+ Returns #!TRUE if OBJECT has type-code CELL, otherwise returns
+ NIL.
*/
-Built_In_Primitive(Prim_Cell, 1,"CELL?")
+Built_In_Primitive(Prim_Cell, 1, "CELL?", 0x63)
{
Primitive_1_Arg();
return (Type_Code(Arg1 == TC_CELL)) ? TRUTH : NIL;
}
-/* (SET-CONTENTS! CELL VALUE)
- Stores VALUE as contents of CELL. Returns (bad style to count
- on this) the previous contents of CELL.
+/* (SET-CELL-CONTENTS! CELL VALUE)
+ Stores VALUE as contents of CELL. Returns the previous contents of CELL.
*/
-Built_In_Primitive(Prim_Set_Cell_Contents, 2, "SET-CONTENTS!")
+Built_In_Primitive(Prim_Set_Cell_Contents, 2, "SET-CELL-CONTENTS!", 0x8C)
{
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.35 1987/04/03 00:48:04 jinx Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/prim.h,v 9.36 1987/04/16 02:27:34 jinx Rel $ */
+\f
+/*
+ Primitive declarations.
-/* External primitive definition structure. */
+ Note that the following cannot be changed without changing
+ Findprim.c.
+*/
-typedef struct ext_desc /* User supplied primitive data */
-{
- Pointer (*proc)(); /* Location of actual procedure */
- int arity; /* Number of arguments */
- char *name; /* Name of primitive */
-} External_Descriptor;
+extern Pointer (*(Primitive_Procedure_Table[]))();
+extern int Primitive_Arity_Table[];
+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;
-extern External_Descriptor Ext_Prim_Desc[];
-extern long MAX_EXTERNAL_PRIMITIVE, Get_Ext_Number();
extern Pointer Undefined_Externals, Make_Prim_Exts();
+
+/* Utility macros */
+
+#define NUndefined() \
+((Undefined_Externals == NIL) ? \
+ 0 : \
+ Get_Integer(User_Vector_Ref(Undefined_Externals, 0)))
+
+#define CHUNK_SIZE 20 /* Grow undefined vector by this much */
+
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.21 1987/04/03 00:18:49 jinx Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/prims.h,v 9.22 1987/04/16 02:27:43 jinx Exp $ */
/* This file contains some macros for defining primitives,
for argument type or value checking, and for accessing
the arguments. */
\f
-/* Definition of primitives. See storage.c for some information. */
+/* Definition of primitives. */
#define Define_Primitive(C_Name, Number_of_args, Scheme_Name) \
extern Pointer C_Name(); \
Pointer C_Name()
-#define Built_In_Primitive(C_Name, Number_of_args, Scheme_Name) \
-Define_Primitive(C_Name, Number_of_args, Scheme_Name)
-
-extern Pointer Not_Implemented_Yet();
-
-#define NIY(C_Name, Number_of_args, Scheme_Name) \
-Built_In_Primitive(C_Name, Number_of_args, Scheme_Name) \
-{ return Not_Implemented_Yet(Scheme_Name); \
-}
+#define Built_In_Primitive(C_Name, Number_of_args, Scheme_Name, index) \
+extern Pointer C_Name(); \
+Pointer C_Name()
/* Preambles for primitive procedures. These store the arguments into
* local variables for fast access.
#define guarantee_fixnum_arg_6() \
if (! (fixnum_p (Arg6))) error_wrong_type_arg_6 ()
-extern long guarantee_nonnegative_integer_arg_1();
-extern long guarantee_nonnegative_integer_arg_2();
-extern long guarantee_nonnegative_integer_arg_3();
-extern long guarantee_nonnegative_integer_arg_4();
-extern long guarantee_nonnegative_integer_arg_5();
-extern long guarantee_nonnegative_integer_arg_6();
-extern long guarantee_nonnegative_integer_arg_7();
-extern long guarantee_nonnegative_integer_arg_8();
-extern long guarantee_nonnegative_integer_arg_9();
-extern long guarantee_nonnegative_integer_arg_10();
+extern long guarantee_nonnegative_int_arg_1();
+extern long guarantee_nonnegative_int_arg_2();
+extern long guarantee_nonnegative_int_arg_3();
+extern long guarantee_nonnegative_int_arg_4();
+extern long guarantee_nonnegative_int_arg_5();
+extern long guarantee_nonnegative_int_arg_6();
+extern long guarantee_nonnegative_int_arg_7();
+extern long guarantee_nonnegative_int_arg_8();
+extern long guarantee_nonnegative_int_arg_9();
+extern long guarantee_nonnegative_int_arg_10();
extern long guarantee_index_arg_1();
extern long guarantee_index_arg_2();
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.25 1987/04/03 00:19:30 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/purify.c,v 9.26 1987/04/16 02:27:53 jinx Exp $
*
* This file contains the code that copies objects into pure
* and constant space.
GC();
Free[Purify_Vector_Header] =
Make_Non_Pointer(TC_MANIFEST_VECTOR, Purify_N_Slots);
- Free[Purify_Length] = FIXNUM_0 + Length;
+ Free[Purify_Length] = Make_Unsigned_Fixnum(Length);
Free[Purify_Really_Pure] = Purify_Object;
Answer = Make_Pointer(TC_VECTOR, Free);
Free += Purify_N_Slots+1;
have changed.
*/
-Built_In_Primitive(Prim_Primitive_Purify, 2, "PRIMITIVE-PURIFY")
+Built_In_Primitive(Prim_Primitive_Purify, 2, "PRIMITIVE-PURIFY", 0xB4)
{
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.27 1987/04/03 00:19:50 jinx Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/purutl.c,v 9.28 1987/04/16 02:28:06 jinx Exp $ */
/* Pure/Constant space utilities. */
#include "gccode.h"
#include "zones.h"
\f
-Pointer Make_Impure(Object)
-Pointer Object;
-{ Pointer *New_Address, *End_Of_Area;
+void
+Update(From, To, Was, Will_Be)
+ fast Pointer *From, *To, *Was, *Will_Be;
+{
+ for (; From < To; From++)
+ {
+ if (GC_Type_Special(*From))
+ {
+ if (Safe_Type_Code(*From) == TC_MANIFEST_NM_VECTOR)
+ From += Get_Integer(*From);
+ continue;
+ }
+ if (GC_Type_Non_Pointer(*From))
+ continue;
+ if (Get_Pointer(*From) == Was)
+ *From = Make_Pointer(Type_Code(*From), Will_Be);
+ }
+ return;
+}
+\f
+Pointer
+Make_Impure(Object)
+ Pointer Object;
+{
+ Pointer *New_Address, *End_Of_Area;
fast Pointer *Obj_Address, *Constant_Address;
long Length, Block_Length;
fast long i;
*/
Switch_by_GC_Type(Object)
- { case TC_BROKEN_HEART:
+ {
+ case TC_BROKEN_HEART:
case TC_MANIFEST_NM_VECTOR:
case TC_MANIFEST_SPECIAL_NM_VECTOR:
case_Non_Pointer:
- printf("Impurify Non-Pointer.\n");
+ fprintf(stderr, "\nImpurify Non-Pointer.\n");
Microcode_Termination(TERM_NON_POINTER_RELOCATION);
+
case TC_BIG_FLONUM:
case TC_FUTURE:
- case_Vector: Length = Vector_Length(Object) + 1; break;
- case_Quadruple: Length = 4; break;
+ case_Vector:
+ Length = Vector_Length(Object) + 1;
+ break;
+
+ case_Quadruple:
+ Length = 4;
+ break;
+
case TC_VARIABLE:
- case_Triple: Length = 3; break;
+ case_Triple:
+ Length = 3;
+ break;
+
case TC_WEAK_CONS:
- case_Pair: Length = 2; break;
- case_Cell: Length = 1; break;
+ case_Pair:
+ Length = 2;
+ break;
+
+ case_Cell:
+ Length = 1;
+ break;
+
default:
- fprintf(stderr, "Impurify: Bad type code = 0x%02x\n",
+ fprintf(stderr, "\nImpurify: Bad type code = 0x%02x\n",
Type_Code(Object));
Invalid_Type_Code();
}
-
+\f
/* Add a copy of the object to the last constant block in memory.
*/
Constant_Address = Free_Constant;
Obj_Address = Get_Pointer(Object);
- if (!Test_Pure_Space_Top(Constant_Address+Length)) return NIL;
+ if (!Test_Pure_Space_Top(Constant_Address + Length))
+ return NIL;
Block_Length = Get_Integer(*(Constant_Address-1));
- Constant_Address = Constant_Address-2;
+ Constant_Address -= 2;
New_Address = Constant_Address;
#ifdef FLOATING_ALIGNMENT
*/
if (Type_Code(Object) == TC_BIG_FLONUM)
- { Pointer *Start = Constant_Address;
+ {
+ Pointer *Start;
+
+ Start = Constant_Address;
Align_Float(Constant_Address);
- for (i=0; i < Length; i++) *Constant_Address++ = *Obj_Address++;
- Length = Constant_Address-Start;
+ for (i = 0; i < Length; i++)
+ *Constant_Address++ = *Obj_Address++;
+ Length = Constant_Address - Start;
}
else
#endif
for (i = Length; --i >= 0; )
- { *Constant_Address++ = *Obj_Address;
+ {
+ *Constant_Address++ = *Obj_Address;
*Obj_Address++ = Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, i);
}
*Constant_Address++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
- *Constant_Address++ = Make_Non_Pointer(END_OF_BLOCK, Block_Length+Length);
- *(New_Address+2-Block_Length) =
- Make_Non_Pointer(PURE_PART, Block_Length+Length);
+ *Constant_Address++ = Make_Non_Pointer(END_OF_BLOCK, Block_Length + Length);
+ *(New_Address + 2 - Block_Length) =
+ Make_Non_Pointer(PURE_PART, Block_Length + Length);
Obj_Address -= Length;
Free_Constant = Constant_Address;
return Make_Pointer(Type_Code(Object), New_Address);
}
\f
-/* (IMPURIFY OBJECT)
+/* (PRIMITIVE-IMPURIFY OBJECT)
+ Remove an object from pure space so it can be side effected.
+ The object is placed in constant space instead.
*/
-Built_In_Primitive(Prim_Impurify, 1, "IMPURIFY")
-{ Pointer Result;
+Built_In_Primitive(Prim_Impurify, 1, "PRIMITIVE-IMPURIFY", 0xBD)
+{
+ Pointer Result;
Primitive_1_Arg();
+
Touch_In_Primitive(Arg1, Arg1);
Result = Make_Impure(Arg1);
- if (Result != NIL) return Result;
- Primitive_Error(ERR_IMPURIFY_OUT_OF_SPACE); /*NOTREACHED*/
-}
-
-Update(From, To, Was, Will_Be)
-fast Pointer *From, *To, *Was, *Will_Be;
-{ for (; From < To; From++)
- { if (GC_Type_Special(*From))
- { if (Safe_Type_Code(*From) == TC_MANIFEST_NM_VECTOR)
- From += Get_Integer(*From);
- continue;
- }
- if (GC_Type_Non_Pointer(*From)) continue;
- if (Get_Pointer(*From) == Was)
- *From = Make_Pointer(Type_Code(*From), Will_Be);
- }
+ if (Result != NIL)
+ return Result;
+ Primitive_Error(ERR_IMPURIFY_OUT_OF_SPACE);
+ /*NOTREACHED*/
}
\f
-Boolean Pure_Test(Obj_Address)
-fast Pointer *Obj_Address;
-{ fast Pointer *Where;
+Boolean
+Pure_Test(Obj_Address)
+ fast Pointer *Obj_Address;
+{
+ fast Pointer *Where;
#ifdef FLOATING_ALIGNMENT
- fast Pointer Float_Align_Value = Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, 0);
+ fast Pointer Float_Align_Value;
+
+ Float_Align_Value = Make_Non_Pointer(TC_MANIFEST_NM_VECTOR, 0);
#endif
+
Where = Free_Constant-1;
while (Where >= Constant_Space)
{
#ifdef FLOATING_ALIGNMENT
- while (*Where == Float_Align_Value) Where -= 1;
+ while (*Where == Float_Align_Value)
+ Where -= 1;
#endif
- Where -= 1+Get_Integer(*Where);
+ Where -= 1 + Get_Integer(*Where);
if (Where <= Obj_Address)
- return (Boolean) (Obj_Address <= (Where+1+Get_Integer(*(Where+1))));
+ return
+ ((Boolean) (Obj_Address <= (Where + 1 + Get_Integer(*(Where + 1)))));
}
- return (Boolean) false;
+ return ((Boolean) false);
}
-
+\f
/* (PURE? OBJECT)
- Returns #!TRUE if the object is pure (ie it doesn't point to any
- other object, or it is in a pure section of the constant space).
+ Returns #!TRUE if the object is pure (ie it doesn't point to any
+ other object, or it is in a pure section of the constant space).
*/
-Built_In_Primitive(Prim_Pure_P, 1, "PURE?")
-{ Primitive_1_Arg();
+Built_In_Primitive(Prim_Pure_P, 1, "PURE?", 0xBB)
+{
+ Primitive_1_Arg();
if ((GC_Type_Non_Pointer(Arg1)) ||
(GC_Type_Special(Arg1)))
return TRUTH;
- if (GC_Type_Compiled(Arg1)) return NIL;
+ if (GC_Type_Compiled(Arg1))
+ return NIL;
Touch_In_Primitive(Arg1, Arg1);
- { Pointer *Obj_Address;
+ {
+ Pointer *Obj_Address;
+
Obj_Address = Get_Pointer(Arg1);
- if (Is_Pure(Obj_Address)) return TRUTH;
+ if (Is_Pure(Obj_Address))
+ return TRUTH;
}
return NIL;
}
/* (CONSTANT? OBJECT)
- Returns #!TRUE if the object is in constant space or isn't a
- pointer.
+ Returns #!TRUE if the object is in constant space or isn't a
+ pointer.
*/
-Built_In_Primitive(Prim_Constant_P, 1, "CONSTANT?")
-{ Primitive_1_Arg();
+Built_In_Primitive(Prim_Constant_P, 1, "CONSTANT?", 0xBA)
+{
+ Primitive_1_Arg();
+
Touch_In_Primitive(Arg1, Arg1);
return ((GC_Type_Non_Pointer(Arg1)) ||
(GC_Type_Special(Arg1)) ||
}
/* (GET-NEXT-CONSTANT)
- Returns the next free address in constant space.
+ Returns the next free address in constant space.
*/
-Built_In_Primitive(Prim_Get_Next_Constant, 0, "GET-NEXT-CONSTANT")
-{ Pointer *Next_Address = Free_Constant+1;
+Built_In_Primitive(Prim_Get_Next_Constant, 0, "GET-NEXT-CONSTANT", 0xE4)
+{
+ Pointer *Next_Address;
+
+ Next_Address = Free_Constant + 1;
Primitive_0_Args();
return Make_Pointer(TC_ADDRESS, Next_Address);
}
Pointer *
copy_to_constant_space(source, nobjects)
-fast Pointer *source;
-long nobjects;
-{ fast Pointer *dest;
+ fast Pointer *source;
+ long nobjects;
+{
+ fast Pointer *dest;
fast long i;
Pointer *result;
dest = Free_Constant;
if (!Test_Pure_Space_Top(dest + nobjects + 6))
- { fprintf(stderr,
+ {
+ fprintf(stderr,
"copy_to_constant_space: Not enough constant space!\n");
Microcode_Termination(TERM_NO_SPACE);
}
*dest++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 3);
- *dest++ = Make_Non_Pointer(PURE_PART, nobjects+5);
+ *dest++ = Make_Non_Pointer(PURE_PART, nobjects + 5);
*dest++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
*dest++ = Make_Non_Pointer(CONSTANT_PART, 3);
result = dest;
for (i = nobjects; --i >= 0; )
+ {
*dest++ = *source++;
+ }
*dest++ = Make_Non_Pointer(TC_MANIFEST_SPECIAL_NM_VECTOR, 1);
- *dest++ = Make_Non_Pointer(END_OF_BLOCK, nobjects+5);
+ *dest++ = Make_Non_Pointer(END_OF_BLOCK, nobjects + 5);
Free_Constant = dest;
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/returns.h,v 9.21 1987/01/22 14:30:54 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/returns.h,v 9.22 1987/04/16 02:28:30 jinx Exp $
*
* Return codes. These are placed in Return when an
* interpreter operation needs to operate in several
*/
#define RC_END_OF_COMPUTATION 0x00
-/* Used to be RC_RESTORE_CONTROL_POINT */
+/* formerly RC_RESTORE_CONTROL_POINT 0x01 */
#define RC_JOIN_STACKLETS 0x01
#define RC_RESTORE_CONTINUATION 0x02 /* Used for 68000 */
#define RC_INTERNAL_APPLY 0x03
#define RC_BAD_INTERRUPT_CONTINUE 0x04 /* Used for 68000 */
#define RC_RESTORE_HISTORY 0x05
-/* Generated by primitive WITH_HISTORY_DISABLED */
#define RC_INVOKE_STACK_THREAD 0x06
-/* Generated by primitive WITH_THREADED_CONTINUATION */
#define RC_RESTART_EXECUTION 0x07 /* Used for 68000 */
#define RC_EXECUTE_ASSIGNMENT_FINISH 0x08
#define RC_EXECUTE_DEFINITION_FINISH 0x09
#define RC_PCOMB3_APPLY 0x1B
\f
#define RC_SNAP_NEED_THUNK 0x1C
-/* Generated by primitive FORCE */
#define RC_REENTER_COMPILED_CODE 0x1D
-/* Formerly RC_GET_CHAR_REPEAT on 68000 0x1E */
-#define RC_COMPILER_REFERENCE_RESTART 0x1F
+/* formerly RC_GET_CHAR_REPEAT 0x1E */
+#define RC_COMP_REFERENCE_RESTART 0x1F
#define RC_NORMAL_GC_DONE 0x20
#define RC_COMPLETE_GC_DONE 0x21 /* Used for 68000 */
#define RC_PURIFY_GC_1 0x22
-/* Generated by primitive PURIFY */
#define RC_PURIFY_GC_2 0x23
-/* Generated by primitive PURIFY */
#define RC_AFTER_MEMORY_UPDATE 0x24 /* Used for 68000 */
#define RC_RESTARTABLE_EXIT 0x25 /* Used for 68000 */
/* formerly RC_GET_CHAR 0x26 */
/* formerly RC_GET_CHAR_IMMEDIATE 0x27 */
-#define RC_COMPILER_ASSIGNMENT_RESTART 0x28
+#define RC_COMP_ASSIGNMENT_RESTART 0x28
#define RC_POP_FROM_COMPILED_CODE 0x29
#define RC_RETURN_TRAP_POINT 0x2A
#define RC_RESTORE_STEPPER 0x2B /* Used for 68000 */
#define RC_RESTORE_TO_STATE_POINT 0x2C
-/* Generated by primitive EXECUTE_AT_NEW_POINT */
#define RC_MOVE_TO_ADJACENT_POINT 0x2D
#define RC_RESTORE_VALUE 0x2E
#define RC_RESTORE_DONT_COPY_HISTORY 0x2F
#define RC_POP_RETURN_ERROR 0x40
#define RC_EVAL_ERROR 0x41
#define RC_REPEAT_PRIMITIVE 0x42
-#define RC_COMPILER_INTERRUPT_RESTART 0x43
-/* #define RC_COMPILER_RECURSION_GC 0x44 */
+#define RC_COMP_INTERRUPT_RESTART 0x43
+/* formerly RC_COMP_RECURSION_GC 0x44 */
#define RC_RESTORE_INT_MASK 0x45
#define RC_HALT 0x46
#define RC_FINISH_GLOBAL_INT 0x47 /* Multiprocessor */
#define RC_REPEAT_DISPATCH 0x48
#define RC_GC_CHECK 0x49
#define RC_RESTORE_FLUIDS 0x4A
-#define RC_COMPILER_LOOKUP_APPLY_RESTART 0x4B
-#define RC_COMPILER_ACCESS_RESTART 0x4C
-#define RC_COMPILER_UNASSIGNED_P_RESTART 0x4D
-#define RC_COMPILER_UNBOUND_P_RESTART 0x4E
-#define RC_COMPILER_DEFINITION_RESTART 0x4F
-#define RC_COMPILER_LEXPR_INTERRUPT_RESTART 0x50
+#define RC_COMP_LOOKUP_APPLY_RESTART 0x4B
+#define RC_COMP_ACCESS_RESTART 0x4C
+#define RC_COMP_UNASSIGNED_P_RESTART 0x4D
+#define RC_COMP_UNBOUND_P_RESTART 0x4E
+#define RC_COMP_DEFINITION_RESTART 0x4F
+#define RC_COMP_LEXPR_INTERRUPT_RESTART 0x50
#define MAX_RETURN_CODE 0x50
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.22 1987/04/03 00:20:06 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/scheme.h,v 9.23 1987/04/16 02:28:57 jinx Exp $
*
* General declarations for the SCode interpreter. This
* file is INCLUDED by others and contains declarations only.
#define fast register
#endif
+#define quick fast
+
#ifdef ENABLE_DEBUGGING_TOOLS
#define Consistency_Check true
#else
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.22 1987/04/03 00:20:33 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/sdata.h,v 9.23 1987/04/16 02:29:06 jinx Exp $
*
* Description of the user data objects. This should parallel the
* file SDATA.SCM in the runtime system.
so that the "compiled" lookup code does not have to check whether
the frame has been extended or not.
- Note that for the code to work, ENVIRONMENT_EXTENSION_PARENT_FRAME
- must be equal to PROCEDURE_ENVIRONMENT.
+ Note that for the code to work, ENV_EXTENSION_PARENT_FRAME must be
+ equal to PROCEDURE_ENVIRONMENT.
The following constants are implicitely hard-coded in lookup.c,
where a new extension object is consed in extend_frame.
*/
-#define ENVIRONMENT_EXTENSION_HEADER 0
-#define ENVIRONMENT_EXTENSION_PARENT_FRAME 1
-#define ENVIRONMENT_EXTENSION_PROCEDURE 2
-#define ENVIRONMENT_EXTENSION_COUNT 3
-#define ENVIRONMENT_EXTENSION_MIN_SIZE 4
+#define ENV_EXTENSION_HEADER 0
+#define ENV_EXTENSION_PARENT_FRAME 1
+#define ENV_EXTENSION_PROCEDURE 2
+#define ENV_EXTENSION_COUNT 3
+#define ENV_EXTENSION_MIN_SIZE 4
\f
/* EXTENDED_FIXNUM
* Not used in the C version. On the 68000 this is used for 24-bit
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.20 1987/01/21 20:26:56 jinx Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/stack.h,v 9.21 1987/04/16 02:29:23 jinx Exp $ */
/* This file contains macros for manipulating stacks and stacklets. */
\f
#ifdef USE_STACKLETS
/* Stack is made up of linked small parts, each in the heap */
-#define Initialize_Stack()
+#define Initialize_Stack() \
+{ \
if (GC_Check(Default_Stacklet_Size)) \
Microcode_Termination(TERM_STACK_ALLOCATION_FAILED); \
Stack_Guard = Free+STACKLET_HEADER_SIZE; \
- *Free = Make_Non_Pointer(TC_MANIFEST_VECTOR, Default_Stacklet_Size-1);\
+ *Free = Make_Non_Pointer(TC_MANIFEST_VECTOR, Default_Stacklet_Size-1); \
Free += Default_Stacklet_Size; \
Stack_Pointer = Free; \
- Free_Stacklets = NULL; \
- Previous_Restore_History_Stacklet = NULL; \
- Previous_Restore_History_Offset = 0
+ Free_Stacklets = NULL; \
+ Prev_Restore_History_Stacklet = NULL; \
+ Prev_Restore_History_Offset = 0; \
+}
#define Internal_Will_Push(N) \
-if ((Stack_Pointer - (N)) < Stack_Guard) \
-{ Export_Registers(); \
- Allocate_New_Stacklet((N)); \
- Import_Registers(); \
+{ \
+ if ((Stack_Pointer - (N)) < Stack_Guard) \
+ { Export_Registers(); \
+ Allocate_New_Stacklet((N)); \
+ Import_Registers(); \
+ } \
}
-#define Stack_Allocation_Size(Stack_Blocks) 0
/* No space required independent of the heap for the stacklets */
+#define Stack_Allocation_Size(Stack_Blocks) 0
+
#define Current_Stacklet (Stack_Guard-STACKLET_HEADER_SIZE)
/* Make the unused portion of the old stacklet invisible to garbage
* collection. This also allows the stack pointer to be reconstructed.
*/
+#define Internal_Terminate_Old_Stacklet() \
+{ \
+ Current_Stacklet[STACKLET_UNUSED_LENGTH] = \
+ Make_Non_Pointer((DANGER_TYPE | TC_MANIFEST_NM_VECTOR), \
+ Stack_Pointer-Stack_Guard); \
+}
+
#ifdef ENABLE_DEBUGGING_TOOLS
+
#define Terminate_Old_Stacklet() \
+{ \
if (Stack_Pointer < Stack_Guard) \
- { printf("\nStack_Pointer: 0x%x, Guard: 0x%x\n", \
- Stack_Pointer, Stack_Guard); \
+ { \
+ fprintf(stderr, "\nStack_Pointer: 0x%x, Guard: 0x%x\n", \
+ Stack_Pointer, Stack_Guard); \
Microcode_Termination(TERM_EXIT); \
} \
- Current_Stacklet[STACKLET_UNUSED_LENGTH] = \
- Make_Non_Pointer((DANGER_TYPE | TC_MANIFEST_NM_VECTOR), \
- Stack_Pointer-Stack_Guard)
+ Internal_Terminate_Old_Stacklet(); \
+}
+
#else
-#define Terminate_Old_Stacklet() \
- Current_Stacklet[STACKLET_UNUSED_LENGTH] = \
- Make_Non_Pointer((DANGER_TYPE | TC_MANIFEST_NM_VECTOR), \
- Stack_Pointer-Stack_Guard)
+
+#define Terminate_Old_Stacklet() Internal_Terminate_Old_Stacklet()
+
#endif
\f
/* Used by garbage collector to detect the end of constant space */
((Pointer) Free_Stacklets); \
Free_Stacklets = Stacklet_Top; \
if (!(From_Pop_Return)) \
- { Previous_Restore_History_Stacklet = NULL; \
- Previous_Restore_History_Offset = 0; \
+ { Prev_Restore_History_Stacklet = NULL; \
+ Prev_Restore_History_Offset = 0; \
} \
if (!(Dangerous(Fast_Vector_Ref(Previous_Stacklet, \
STACKLET_UNUSED_LENGTH)))) \
{ Free_Stacklets = \
((Pointer *) Free_Stacklets[STACKLET_FREE_LIST_LINK]); \
Stack_Pointer = Get_End_Of_Stacklet(); \
- Previous_Restore_History_Stacklet = NULL; \
- Previous_Restore_History_Offset = 0;
+ Prev_Restore_History_Stacklet = NULL; \
+ Prev_Restore_History_Offset = 0;
+
/* Backout code inserted here, SUN screw up! */
\f
+ /* Backout code inserted here, SUN screw up! */
+
#define Our_Throw_Part_2() \
- /* Backout code inserted here, SUN screw up! */ \
Request_GC(Vector_Length(Previous_Stacklet) + 1); \
} \
else /* Space available for copy */ \
Get_Pointer(Previous_Stacklet); \
Pointer *First_Continuation = \
Nth_Vector_Loc(Previous_Stacklet, \
- ((1+Vector_Length(Previous_Stacklet))- \
+ ((1 + Vector_Length(Previous_Stacklet)) - \
CONTINUATION_SIZE)); \
- if (Old_Stacklet_Top==Previous_Restore_History_Stacklet) \
- Previous_Restore_History_Stacklet = NULL; \
+ if (Old_Stacklet_Top == Prev_Restore_History_Stacklet) \
+ Prev_Restore_History_Stacklet = NULL; \
if (First_Continuation[CONTINUATION_RETURN_CODE] == \
Make_Non_Pointer(TC_RETURN_CODE, RC_JOIN_STACKLETS)) \
{ Pointer *Even_Older_Stacklet = \
} \
else /* No need to copy the stacklet we are going into */ \
{ if (Get_Pointer(Previous_Stacklet)== \
- Previous_Restore_History_Stacklet) \
- Previous_Restore_History_Stacklet = NULL; \
+ Prev_Restore_History_Stacklet) \
+ Prev_Restore_History_Stacklet = NULL; \
Set_Current_Stacklet(Previous_Stacklet); \
} \
}
Microcode_Termination (TERM_BAD_STACK); \
if (!(From_Pop_Return)) \
{ \
- Previous_Restore_History_Stacklet = NULL; \
- Previous_Restore_History_Offset = 0; \
+ Prev_Restore_History_Stacklet = NULL; \
+ Prev_Restore_History_Offset = 0; \
if ((!Valid_Fixed_Obj_Vector ()) || \
(Get_Fixed_Obj_Slot (Dummy_History) == NIL)) \
History = Make_Dummy_History (); \
else \
History = Get_Pointer (Get_Fixed_Obj_Slot (Dummy_History)); \
} \
- else if (Previous_Restore_History_Stacklet == Get_Pointer (Control_Point)) \
- Previous_Restore_History_Stacklet = NULL; \
+ else if (Prev_Restore_History_Stacklet == Get_Pointer (Control_Point)) \
+ Prev_Restore_History_Stacklet = NULL; \
}
#define Our_Throw_Part_2()
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.21 1987/01/22 14:32:26 jinx Exp $
+/* $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 $
*
* Support for the stepper
*/
}
}
\f
-/* (EVAL_STEP EXPRESSION ENV HUNK3)
- Evaluates EXPRESSION in ENV and intalls the eval-trap,
- apply-trap, and return-trap from HUNK3. If any
- trap is '(), it is a null trap that does a normal EVAL,
- APPLY or return.
+/* (PRIMITIVE-EVAL-STEP EXPRESSION ENV HUNK3)
+ Evaluates EXPRESSION in ENV and intalls the eval-trap,
+ apply-trap, and return-trap from HUNK3. If any
+ trap is '(), it is a null trap that does a normal EVAL,
+ APPLY or return.
*/
-Built_In_Primitive(Prim_Eval_Step, 3, "EVAL-STEP")
-{ Primitive_3_Args();
+Built_In_Primitive(Prim_Eval_Step, 3, "PRIMITIVE-EVAL-STEP", 0xCA)
+{
+ Primitive_3_Args();
+
Install_Traps(Arg3, false);
Pop_Primitive_Frame(3);
Store_Expression(Arg1);
Store_Env(Arg2);
longjmp(*Back_To_Eval, PRIM_NO_TRAP_EVAL);
+ /*NOTREACHED*/
}
\f
-/* (APPLY-STEP OPERATOR OPERANDS HUNK3)
- Applies OPERATOR to OPERANDS and intalls the eval-trap,
- apply-trap, and return-trap from HUNK3. If any
- trap is '(), it is a null trap that does a normal EVAL,
- APPLY or return.
-*/
-Built_In_Primitive(Prim_Apply_Step, 3, "APPLY-STEP")
-/* Mostly a copy of Prim_Apply, since this, too, must count the space
+/* (PRIMITIVE-APPLY-STEP OPERATOR OPERANDS HUNK3)
+ Applies OPERATOR to OPERANDS and intalls the eval-trap,
+ apply-trap, and return-trap from HUNK3. If any
+ trap is '(), it is a null trap that does a normal EVAL,
+ APPLY or return.
+
+ Mostly a copy of Prim_Apply, since this, too, must count the space
required before actually building a frame
*/
-{ Pointer Next_From_Slot, *Next_To_Slot;
+
+Built_In_Primitive(Prim_Apply_Step, 3, "PRIMITIVE-APPLY-STEP", 0xCB)
+{
+ Pointer Next_From_Slot, *Next_To_Slot;
long Number_Of_Args, i;
Primitive_3_Args();
+
Arg_3_Type(TC_HUNK3);
Number_Of_Args = 0;
Next_From_Slot = Arg2;
while (Type_Code(Next_From_Slot) == TC_LIST)
- { Number_Of_Args += 1;
+ {
+ Number_Of_Args += 1;
Next_From_Slot = Vector_Ref(Next_From_Slot, CONS_CDR);
}
if (Next_From_Slot != NIL)
Next_To_Slot = Stack_Pointer - Number_Of_Args;
Will_Push(Number_Of_Args + STACK_ENV_EXTRA_SLOTS + 1);
Stack_Pointer = Next_To_Slot;
- for (i=0; i < Number_Of_Args; i++)
- { *Next_To_Slot++ = Vector_Ref(Next_From_Slot, CONS_CAR);
+
+ for (i = 0; i < Number_Of_Args; i++)
+ {
+ *Next_To_Slot++ = Vector_Ref(Next_From_Slot, CONS_CAR);
Next_From_Slot = Vector_Ref(Next_From_Slot, CONS_CDR);
}
Push(Arg1); /* The function */
Push(STACK_FRAME_HEADER + Number_Of_Args);
Pushed();
longjmp(*Back_To_Eval, PRIM_NO_TRAP_APPLY);
+ /*NOTREACHED*/
}
\f
-/* (RETURN_STEP VALUE HUNK3)
- Returns VALUE and intalls the eval-trap, apply-trap, and
- return-trap from HUNK3. If any trap is '(), it is a null trap
- that does a normal EVAL, APPLY or return.
-*/
+/* (PRIMITIVE-RETURN-STEP VALUE HUNK3)
+ Returns VALUE and intalls the eval-trap, apply-trap, and
+ return-trap from HUNK3. If any trap is '(), it is a null trap
+ that does a normal EVAL, APPLY or return.
-Built_In_Primitive(Prim_Return_Step, 2, "RETURN-STEP")
-/* UGLY ... currently assumes that it is illegal to set a return trap
+ UGLY ... currently assumes that it is illegal to set a return trap
this way, so that we don't run into stack parsing problems. If
this is ever changed, be sure to check for COMPILE_STEPPER flag!
*/
-{ Pointer Return_Hook;
+
+Built_In_Primitive(Prim_Return_Step, 2, "PRIMITIVE-RETURN-STEP", 0xCC)
+{
+ Pointer Return_Hook;
Primitive_2_Args();
+
Return_Hook = Vector_Ref(Arg2, HUNK_CXR2);
if (Return_Hook != NIL)
Primitive_Error(ERR_ARG_2_BAD_RANGE);
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.27 1987/04/03 00:20:53 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/storage.c,v 9.28 1987/04/16 02:29:45 jinx Exp $
This file defines the storage for global variables for
the Scheme Interpreter. */
#include "scheme.h"
-#include "prims.h"
#include "gctype.c"
\f
/*************/
Declare_Fixed_Objects();
FILE *(Channels[FILE_CHANNELS]), *File_Handle, *Photo_File_Handle;
+
int Saved_argc;
char **Saved_argv;
char *OS_Name, *OS_Variant;
+
Boolean Photo_Open = false; /* Photo file open */
-Boolean Trapping, Can_Do_Cursor;
-Pointer Old_Return_Code, *Return_Hook_Address,
- *Previous_Restore_History_Stacklet,
- Weak_Chain;
-long Previous_Restore_History_Offset;
+
+Boolean Trapping;
+
+Pointer Old_Return_Code, *Return_Hook_Address;
+
+Pointer *Prev_Restore_History_Stacklet;
+long Prev_Restore_History_Offset;
+
jmp_buf *Back_To_Eval; /* Buffer for set/longjmp */
+
long Heap_Size, Constant_Size, Stack_Size;
Pointer *Highest_Allocated_Address;
char *CONT_PRINT_EXPR_MESSAGE = "Save_Cont, expression";
char *RESTORE_CONT_RETURN_MESSAGE = "Restore_Cont, return code";
char *RESTORE_CONT_EXPR_MESSAGE = "Restore_Cont, expression";
-
-\f
- /*********************************/
- /* Argument Count for Primitives */
- /*********************************/
-
-char Arg_Count_Table[] = {
-/* 000 */ (char) 3, /* LEXICAL-ASSIGNMENT */
-/* 001 */ (char) 2, /* LOCAL-REFERENCE */
-/* 002 */ (char) 3, /* LOCAL-ASSIGNMENT */
-/* 003 */ (char) 1, /* CATCH */
-/* 004 */ (char) 2, /* SCODE-EVAL */
-/* 005 */ (char) 2, /* APPLY */
-/* 006 */ (char) 1, /* SET!-INTERRUPT-ENABLES */
-/* 007 */ (char) 1, /* STRING->SYMBOL */
-/* 008 */ (char) 1, /* GET-WORK */
-/* 009 */ (char) 1, /* NON-REENTRANT-CATCH */
-/* 00A */ (char) 1, /* GET-CURRENT-DYNAMIC-STATE */
-/* 00B */ (char) 1, /* SET-CURRENT-DYNAMIC-STATE! */
-/* 00C */ (char) 1, /* NULL? NOT */
-/* 00D */ (char) 2, /* EQ? */
-/* 00E */ (char) 2, /* STRING-EQUAL? */
-/* 00F */ (char) 2, /* PRIMITIVE-TYPE? */
-/* 010 */ (char) 1, /* PRIMITIVE-TYPE */
-/* 011 */ (char) 2, /* PRIMITIVE-SET-TYPE */
-/* 012 */ (char) 2, /* LEXICAL-REFERENCE */
-/* 013 */ (char) 2, /* LEXICAL-UNREFERENCEABLE-TEST */
-/* 014 */ (char) 2, /* MAKE-CHAR */
-/* 015 */ (char) 1, /* CHAR-BITS */
-/* 016 */ (char) 0, /* NON-RESTARTABLE-EXIT */
-/* 017 */ (char) 1, /* CHAR-CODE */
-/* 018 */ (char) 2, /* UNASSIGNED-TEST */
-/* 019 */ (char) 3, /* INSERT-NON-MARKED-VECTOR */
-/* 01A */ (char) 0, /* RESTARTABLE-EXIT */
-/* 01B */ (char) 1, /* CHAR->INTEGER */
-/* 01C */ (char) 2, /* MEMQ */
-/* 01D */ (char) 3, /* INSERT-STRING */
-/* 01E */ (char) 1, /* ENABLE-INTERRUPTS */
-/* 01F */ (char) 1, /* MAKE-EMPTY-STRING */
-/* 020 */ (char) 2, /* CONS */
-/* 021 */ (char) 1, /* CAR */
-/* 022 */ (char) 1, /* CDR */
-/* 023 */ (char) 2, /* SET!-CAR */
-/* 024 */ (char) 2, /* SET!-CDR */
-/* 025 */ (char) 0, /* unused */
-/* 026 */ (char) 0, /* TTY-GET-CURSOR */
-/* 027 */ (char) 2, /* GENERAL-CAR-CDR */
-/* 028 */ (char) 3, /* HUNK3-CONS */
-
-/* Argument Count Table continues on next page */
-\f
-/* Argument Count Table, continued */
-
-/* 029 */ (char) 2, /* HUNK3-CXR */
-/* 02A */ (char) 3, /* HUNK3-SET!-CXR */
-/* 02B */ (char) 3, /* OVERWRITE-STRING */
-/* 02C */ (char) 2, /* VECTOR-CONS */
-/* 02D */ (char) 1, /* VECTOR-SIZE */
-/* 02E */ (char) 2, /* VECTOR-REF */
-/* 02F */ (char) 1, /* SET-CURRENT-HISTORY */
-/* 030 */ (char) 3, /* VECTOR-SET! */
-/* 031 */ (char) 1, /* NON-MARKED-VECTOR-CONS */
-/* 032 */ (char) 0, /* unused */
-/* 033 */ (char) 2, /* UNBOUND-TEST */
-/* 034 */ (char) 1, /* INTEGER->CHAR */
-/* 035 */ (char) 1, /* CHAR-DOWNCASE */
-/* 036 */ (char) 1, /* CHAR-UPCASE */
-/* 037 */ (char) 1, /* ASCII->CHAR */
-/* 038 */ (char) 1, /* CHAR-ASCII? */
-/* 039 */ (char) 1, /* CHAR->ASCII */
-/* 03A */ (char) 1, /* GARBAGE-COLLECT */
-/* 03B */ (char) 2, /* PLUS-FIXNUM */
-/* 03C */ (char) 2, /* MINUS-FIXNUM */
-/* 03D */ (char) 2, /* MULTIPLY-FIXNUM */
-/* 03E */ (char) 2, /* DIVIDE-FIXNUM */
-/* 03F */ (char) 2, /* EQUAL-FIXNUM? */
-/* 040 */ (char) 2, /* LESS-THAN-FIXNUM? */
-/* 041 */ (char) 1, /* POSITIVE-FIXNUM? */
-/* 042 */ (char) 1, /* ONE-PLUS-FIXNUM */
-/* 043 */ (char) 1, /* MINUS-ONE-PLUS-FIXNUM */
-/* 044 */ (char) 2, /* TRUNCATE-STRING */
-/* 045 */ (char) 3, /* SUBSTRING */
-/* 046 */ (char) 1, /* ZERO-FIXNUM? */
-/* 047 */ (char) 1, /* UNDANGERIZE */
-/* 048 */ (char) 1, /* DANGERIZE */
-/* 049 */ (char) 1, /* DANGEROUS? */
-/* 04A */ (char) 3, /* SUBSTRING-TO-LIST */
-/* 04B */ (char) 2, /* MAKE-FILLED-STRING */
-/* 04C */ (char) 2, /* PLUS-BIGNUM */
-/* 04D */ (char) 2, /* MINUS-BIGNUM */
-/* 04E */ (char) 2, /* MULTIPLY-BIGNUM */
-/* 04F */ (char) 2, /* DIVIDE-BIGNUM */
-/* 050 */ (char) 2, /* LISTIFY-BIGNUM */
-/* 051 */ (char) 2, /* EQUAL-BIGNUM? */
-/* 052 */ (char) 2, /* LESS-THAN-BIGNUM? */
-/* 053 */ (char) 1, /* POSITIVE-BIGNUM? */
-
-/* Argument Count Table continues on next page */
-\f
-/* Argument Count Table, continued */
-
-/* 054 */ (char) 2, /* FILE-OPEN-CHANNEL */
-/* 055 */ (char) 1, /* FILE-CLOSE-CHANNEL */
-/* 056 */ (char) 3, /* PRIMITIVE-FASDUMP */
-/* 057 */ (char) 1, /* BINARY-FASLOAD */
-/* 058 */ (char) 3, /* STRING-POSITION */
-/* 059 */ (char) 2, /* STRING-LESS? */
-/* 05A */ (char) 0, /* unused */
-/* 05B */ (char) 0, /* unused */
-/* 05C */ (char) 2, /* REHASH */
-/* 05D */ (char) 1, /* LENGTH */
-/* 05E */ (char) 2, /* ASSQ */
-/* 05F */ (char) 1, /* BUILD-STRING-FROM-LIST */
-/* 060 */ (char) 2, /* EQUAL-STRING-TO-LIST? */
-/* 061 */ (char) 1, /* MAKE-CELL */
-/* 062 */ (char) 1, /* CONTENTS */
-/* 063 */ (char) 1, /* CELL? */
-/* 064 */ (char) 1, /* CHARACTER-UPCASE */
-/* 065 */ (char) 1, /* CHARACTER-LIST-HASH */
-/* 066 */ (char) 2, /* GCD-FIXNUM */
-/* 067 */ (char) 1, /* COERCE-FIXNUM-TO-BIGNUM */
-/* 068 */ (char) 1, /* COERCE-BIGNUM-TO-FIXNUM */
-/* 069 */ (char) 2, /* PLUS-FLONUM */
-/* 06A */ (char) 2, /* MINUS-FLONUM */
-/* 06B */ (char) 2, /* MULTIPLY-FLONUM */
-/* 06C */ (char) 2, /* DIVIDE-FLONUM */
-/* 06D */ (char) 2, /* EQUAL-FLONUM? */
-/* 06E */ (char) 2, /* LESS-THAN-FLONUM? */
-/* 06F */ (char) 1, /* ZERO-BIGNUM? */
-/* 070 */ (char) 1, /* TRUNCATE-FLONUM */
-/* 071 */ (char) 1, /* ROUND-FLONUM */
-/* 072 */ (char) 1, /* COERCE-INTEGER-TO-FLONUM */
-/* 073 */ (char) 1, /* SINE-FLONUM */
-/* 074 */ (char) 1, /* COSINE-FLONUM */
-/* 075 */ (char) 1, /* ARCTAN-FLONUM */
-/* 076 */ (char) 1, /* EXP-FLONUM */
-/* 077 */ (char) 1, /* LN-FLONUM */
-/* 078 */ (char) 1, /* SQRT-FLONUM */
-/* 079 */ (char) 1, /* PRIMITIVE-FASLOAD */
-/* 07A */ (char) 0, /* GET-FIXED-OBJECTS-VECTOR */
-/* 07B */ (char) 1, /* SET!-FIXED-OBJECTS-VECTOR */
-/* 07C */ (char) 1, /* LIST-TO-VECTOR */
-/* 07D */ (char) 3, /* SUBVECTOR-TO-LIST */
-/* 07E */ (char) 1, /* PAIR? */
-/* 07F */ (char) 1, /* NEGATIVE-FIXNUM? */
-/* 080 */ (char) 1, /* NEGATIVE-BIGNUM? */
-
-/* Argument Count Table continues on next page */
-\f
-/* Argument Count Table, continued */
-
-/* 081 */ (char) 2, /* GREATER-THAN-FIXNUM? */
-/* 082 */ (char) 2, /* GREATER-THAN-BIGNUM? */
-/* 083 */ (char) 1, /* STRING-HASH */
-/* 084 */ (char) 3, /* SYS-PAIR-CONS */
-/* 085 */ (char) 1, /* SYS-PAIR? */
-/* 086 */ (char) 1, /* SYS-PAIR-CAR */
-/* 087 */ (char) 1, /* SYS-PAIR-CDR */
-/* 088 */ (char) 2, /* SYS-PAIR-SET!-CAR */
-/* 089 */ (char) 2, /* SYS-PAIR-SET!-CDR */
-/* 08A */ (char) 0, /* unused */
-/* 08B */ (char) 0, /* unused */
-/* 08C */ (char) 2, /* SET-CONTENTS! */
-/* 08D */ (char) 2, /* &MAKE-OBJECT */
-/* 08E */ (char) 1, /* SYSTEM-HUNK3-CXR0 */
-/* 08F */ (char) 2, /* SYSTEM-HUNK3-SET!-CXR0 */
-/* 090 */ (char) 2, /* MAP-MACHINE-ADDRESS-TO-CODE */
-/* 091 */ (char) 1, /* SYSTEM-HUNK3-CXR1 */
-/* 092 */ (char) 2, /* SYSTEM-HUNK3-SET!-CXR1 */
-/* 093 */ (char) 2, /* MAP-CODE-TO-MACHINE-ADDRESS */
-/* 094 */ (char) 1, /* SYSTEM-HUNK3-CXR2 */
-/* 095 */ (char) 2, /* SYSTEM-HUNK3-SET!-CXR2 */
-/* 096 */ (char) 1, /* MAP-PRIMITIVE-ADDRESS-TO-ARITY */
-/* 097 */ (char) 2, /* SYSTEM-LIST->VECTOR */
-/* 098 */ (char) 3, /* SYSTEM-SUBVECTOR->LIST */
-/* 099 */ (char) 1, /* SYSTEM-VECTOR? */
-/* 09A */ (char) 2, /* SYSTEM-VECTOR-REF */
-/* 09B */ (char) 3, /* SYSTEM-VECTOR-SET! */
-/* 09C */ (char) 1, /* WITH-HISTORY-DISABLED */
-/* 09D */ (char) 0, /* unused */
-/* 09E */ (char) 0, /* unused */
-/* 09F */ (char) 0, /* unused */
-/* 0A0 */ (char) 0, /* unused */
-/* 0A1 */ (char) 0, /* unused */
-/* 0A2 */ (char) 0, /* unused */
-/* 0A3 */ (char) 1, /* VECTOR-8B-CONS */
-/* 0A4 */ (char) 1, /* VECTOR-8B? */
-/* 0A5 */ (char) 2, /* VECTOR-8B-REF */
-/* 0A6 */ (char) 3, /* VECTOR-8B-SET! */
-/* 0A7 */ (char) 1, /* ZERO-FLONUM? */
-/* 0A8 */ (char) 1, /* POSITIVE-FLONUM? */
-/* 0A9 */ (char) 1, /* NEGATIVE-FLONUM? */
-/* 0AA */ (char) 2, /* GREATER-THAN-FLONUM? */
-/* 0AB */ (char) 1, /* INTERN-CHARACTER-LIST */
-
-/* Argument Count Table continues on next page */
-\f
-/* Argument Count Table, continued */
-
-/* 0AC */ (char) 0, /* unused */
-/* 0AD */ (char) 1, /* VECTOR-8B-SIZE */
-/* 0AE */ (char) 1, /* Sys-VECTOR-SIZE */
-/* 0AF */ (char) 1, /* FORCE */
-/* 0B0 */ (char) 1, /* PRIMITIVE-DATUM */
-/* 0B1 */ (char) 1, /* MAKE-NON-POINTER-OBJECT */
-/* 0B2 */ (char) 1, /* DEBUGGING-PRINTER */
-/* 0B3 */ (char) 1, /* STRING-UPCASE */
-/* 0B4 */ (char) 2, /* PRIMITIVE-PURIFY */
-/* 0B5 */ (char) 0, /* unused */
-/* 0B6 */ (char) 2, /* COMPLETE-GARBAGE-COLLECT */
-/* 0B7 */ (char) 2, /* BAND-DUMP */
-/* 0B8 */ (char) 2, /* SUBSTRING-SEARCH */
-/* 0B9 */ (char) 1, /* BAND-LOAD */
-/* 0BA */ (char) 1, /* CONSTANT-P */
-/* 0BB */ (char) 1, /* PURE-P */
-/* 0BC */ (char) 1, /* GC-TYPE */
-/* 0BD */ (char) 1, /* IMPURIFY */
-/* 0BE */ (char) 2, /* WITH-THREADED-STACK */
-/* 0BF */ (char) 2, /* WITHIN-CONTROL-POINT */
-/* 0C0 */ (char) 1, /* SET-RUN-LIGHT */
-/* 0C1 */ (char) 1, /* FILE-EOF? */
-/* 0C2 */ (char) 1, /* FILE-READ-CHAR */
-/* 0C3 */ (char) 2, /* FILE-FILL-INPUT-BUFFER */
-/* 0C4 */ (char) 1, /* FILE-LENGTH */
-/* 0C5 */ (char) 2, /* FILE-WRITE-CHAR */
-/* 0C6 */ (char) 2, /* FILE-WRITE-STRING */
-/* 0C7 */ (char) 1, /* CLOSE-LOST-OPEN-FILES */
-/* 0C8 */ (char) 0, /* unused */
-
-/* Argument Count Table continues on next page */
-\f
-/* Argument Count Table, continued */
-
-/* 0C9 */ (char) 2, /* WITH-INTERRUPTS-REDUCED */
-/* 0CA */ (char) 3, /* EVAL-STEP */
-/* 0CB */ (char) 3, /* APPLY-STEP */
-/* 0CC */ (char) 2, /* RETURN-STEP */
-/* 0CD */ (char) 1, /* TTY-READ-CHAR-READY? */
-/* 0CE */ (char) 0, /* TTY-READ-CHAR */
-/* 0CF */ (char) 0, /* TTY-READ-CHAR-IMMEDIATE */
-/* 0D0 */ (char) 0, /* TTY-READ-FINISH */
-/* 0D1 */ (char) 1, /* BIT-STRING-ALLOCATE */
-/* 0D2 */ (char) 2, /* MAKE-BIT-STRING */
-/* 0D3 */ (char) 1, /* BIT-STRING-P */
-/* 0D4 */ (char) 1, /* BIT-STRING-LENGTH */
-/* 0D5 */ (char) 2, /* BIT-STRING-REF */
-/* 0D6 */ (char) 5, /* BIT-SUBSTRING-MOVE-RIGHT-X */
-/* 0D7 */ (char) 2, /* BIT-STRING-SET-X */
-/* 0D8 */ (char) 2, /* BIT-STRING-CLEAR-X */
-/* 0D9 */ (char) 1, /* BIT-STRING-ZERO-P */
-/* 0DA */ (char) 0, /* unused */
-/* 0DB */ (char) 0, /* unused */
-/* 0DC */ (char) 2, /* UNSIGNED-INTEGER-TO-BIT-STRING */
-/* 0DD */ (char) 1, /* BIT-STRING-TO-UNSIGNED-INTEGER */
-/* 0DE */ (char) 0, /* unused */
-/* 0DF */ (char) 3, /* READ-BITS-X */
-/* 0E0 */ (char) 3, /* WRITE-BITS-X */
-/* 0E1 */ (char) 1, /* MAKE-STATE-SPACE */
-/* 0E2 */ (char) 4, /* EXECUTE-AT-NEW-POINT */
-/* 0E3 */ (char) 1, /* TRANSLATE-TO-POINT */
-/* 0E4 */ (char) 0, /* GET-NEXT-CONSTANT */
-/* 0E5 */ (char) 0, /* MICROCODE-IDENTIFY */
-/* 0E6 */ (char) 1, /* ZERO */
-/* 0E7 */ (char) 1, /* POSITIVE */
-
-/* Argument Count Table continues on next page */
-\f
-/* Argument Count Table, continued */
-
-/* 0E8 */ (char) 1, /* NEGATIVE */
-/* 0E9 */ (char) 2, /* EQUAL-NUMBER */
-/* 0EA */ (char) 2, /* LESS */
-/* 0EB */ (char) 2, /* GREATER */
-/* 0EC */ (char) 2, /* PLUS */
-/* 0ED */ (char) 2, /* MINUS */
-/* 0EE */ (char) 2, /* MULTIPLY */
-/* 0EF */ (char) 2, /* DIVIDE */
-/* 0F0 */ (char) 2, /* INTEGER-DIVIDE */
-/* 0F1 */ (char) 1, /* ONE-PLUS */
-/* 0F2 */ (char) 1, /* MINUS-ONE-PLUS */
-/* 0F3 */ (char) 1, /* TRUNCATE */
-/* 0F4 */ (char) 1, /* ROUND */
-/* 0F5 */ (char) 1, /* FLOOR */
-/* 0F6 */ (char) 1, /* CEILING */
-/* 0F7 */ (char) 1, /* SQRT */
-/* 0F8 */ (char) 1, /* EXP */
-/* 0F9 */ (char) 1, /* LN */
-/* 0FA */ (char) 1, /* SINE */
-/* 0FB */ (char) 1, /* COSINE */
-/* 0FB */ (char) 1, /* ARCTAN */
-/* 0FD */ (char) 1, /* TTY-WRITE-CHAR */
-/* 0FE */ (char) 1, /* TTY-WRITE-STRING */
-/* 0FF */ (char) 0, /* TTY-BEEP */
-/* 100 */ (char) 0, /* TTY-CLEAR */
-/* 101 */ (char) 0, /* GET-EXTERNAL-COUNTS */
-/* 102 */ (char) 1, /* GET-EXT-NAME */
-/* 103 */ (char) 2, /* GET-EXT-NUMBER */
-/* 104 */ (char) 0, /* unused */
-/* 105 */ (char) 0, /* unused */
-/* 106 */ (char) 0, /* GET-NEXT-INTERRUPT-CHARACTER */
-/* 107 */ (char) 2, /* CHECK-AND-CLEAN-UP-INPUT-CHANNEL */
-/* 108 */ (char) 0, /* unused */
-/* 109 */ (char) 0, /* SYSTEM-CLOCK */
-/* 10A */ (char) 1, /* FILE-EXISTS */
-/* 10B */ (char) 0, /* unused */
-/* 10C */ (char) 2, /* TTY-MOVE-CURSOR */
-/* 10D */ (char) 0, /* unused */
-/* 10E */ (char) 0, /* CURRENT-DATE */
-/* 10F */ (char) 0, /* CURRENT-TIME */
-/* 110 */ (char) 2, /* TRANSLATE-FILE */
-/* 111 */ (char) 2, /* COPY-FILE */
-/* 112 */ (char) 2, /* RENAME-FILE */
-/* 113 */ (char) 1, /* REMOVE-FILE */
-/* 114 */ (char) 3, /* LINK-FILE */
-/* 115 */ (char) 1, /* MAKE-DIRECTORY */
-/* 116 */ (char) 1, /* VOLUME-NAME */
-/* 117 */ (char) 1, /* SET-WORKING-DIRECTORY-PATHNAME-X */
-/* 118 */ (char) 1, /* OPEN-CATALOG */
-/* 119 */ (char) 0, /* CLOSE-CATALOG */
-/* 11A */ (char) 0, /* NEXT-FILE */
-/* 11B */ (char) 0, /* CAT-NAME */
-/* 11C */ (char) 0, /* CAT-KIND */
-/* 11D */ (char) 0, /* CAT-PSIZE */
-/* 11E */ (char) 0, /* CAT-LSIZE */
-/* 11F */ (char) 0, /* CAT-INFO */
-/* 120 */ (char) 0, /* CAT-BLOCK */
-/* 121 */ (char) 0, /* CAT-CREATE-DATE */
-/* 122 */ (char) 0, /* CAT-CREATE-TIME */
-/* 123 */ (char) 0, /* CAT-LAST-DATE */
-/* 124 */ (char) 0, /* CAT-LAST-TIME */
-/* 125 */ (char) 0, /* ERROR-MESSAGE */
-/* 126 */ (char) 0, /* CURRENT-YEAR */
-/* 127 */ (char) 0, /* CURRENT-MONTH */
-/* 128 */ (char) 0, /* CURRENT-DAY */
-/* 129 */ (char) 0, /* CURRENT-HOUR */
-/* 12A */ (char) 0, /* CURRENT-MINUTE */
-/* 12B */ (char) 0, /* CURRENT-SECOND */
-/* 12C */ (char) 1, /* INIT-FLOPPY */
-/* 12D */ (char) 1, /* ZERO-FLOPPY */
-/* 12E */ (char) 1, /* PACK-VOLUME */
-/* 12F */ (char) 1, /* LOAD-PICTURE */
-/* 130 */ (char) 1, /* STORE-PICTURE */
-/* 131 */ (char) 1, /* LOOKUP-SYSTEM-SYMBOL */
-/* 132 */ (char) 0, /* unused */
-/* 133 */ (char) 0, /* unused */
-/* 134 */ (char) 0, /* CLEAR-TO-END-OF-LINE */
-/* 135 */ (char) 0, /* unused */
-/* 136 */ (char) 0, /* unused */
-/* 137 */ (char) 2, /* WITH-INTERRUPT-MASK */
-/* 138 */ (char) 1, /* STRING? */
-/* 139 */ (char) 1, /* STRING-LENGTH */
-/* 13A */ (char) 2, /* STRING-REF */
-/* 13B */ (char) 3, /* STRING-SET! */
-/* 13C */ (char) 5, /* SUBSTRING-MOVE-RIGHT! */
-/* 13D */ (char) 5, /* SUBSTRING-MOVE-LEFT! */
-/* 13E */ (char) 1, /* STRING-ALLOCATE */
-/* 13F */ (char) 1, /* STRING-MAXIMUM-LENGTH */
-/* 140 */ (char) 2, /* SET-STRING-LENGTH! */
-/* 141 */ (char) 4, /* VECTOR-8B-FILL! */
-/* 142 */ (char) 4, /* VECTOR-8B-FIND-NEXT-CHAR */
-/* 143 */ (char) 4, /* VECTOR-8B-FIND-PREVIOUS-CHAR */
-/* 144 */ (char) 4, /* VECTOR-8B-FIND-NEXT-CHAR-CI */
-/* 145 */ (char) 4, /* VECTOR-8B-FIND-PREVIOUS-CHAR-CI */
-/* 146 */ (char) 4, /* SUBSTRING-FIND-NEXT-CHAR-IN-SET */
-/* 147 */ (char) 4, /* SUBSTRING-FIND-PREVIOUS-CHAR-IN-SET */
-/* 148 */ (char) 6, /* SUBSTRING=? */
-/* 149 */ (char) 6, /* SUBSTRING-CI=? */
-/* 14A */ (char) 6, /* SUBSTRING<? */
-/* 14B */ (char) 3, /* SUBSTRING-UPCASE! */
-/* 14C */ (char) 3, /* SUBSTRING-DOWNCASE! */
-/* 14D */ (char) 6, /* SUBSTRING-MATCH-FORWARD */
-/* 14E */ (char) 6, /* SUBSTRING-MATCH-BACKWARD */
-/* 14F */ (char) 6, /* SUBSTRING-MATCH-FORWARD-CI */
-/* 150 */ (char) 6, /* SUBSTRING-MATCH-BACKWARD-CI */
-/* 151 */ (char) 1, /* PHOTO-OPEN */
-/* 152 */ (char) 0, /* PHOTO-CLOSE */
-/* 153 */ (char) 2, /* SETUP-TIMER-INTERRUPT */
-/* 154 */ (char) 0, /* unused */
-/* 155 */ (char) 0, /* unused */
-/* 156 */ (char) 0, /* unused */
-/* 157 */ (char) 0, /* unused */
-/* 158 */ (char) 0, /* unused */
-/* 159 */ (char) 0, /* unused */
-/* 15A */ (char) 0, /* unused */
-/* 15B */ (char) 0, /* unused */
-/* 15C */ (char) 0, /* unused */
-/* 15D */ (char) 0, /* unused */
-/* 15E */ (char) 0, /* unused */
-/* 15F */ (char) 0, /* unused */
-/* 160 */ (char) 0, /* unused */
-/* 161 */ (char) 0, /* EXTRACT-NON-MARKED-VECTOR */
-/* 162 */ (char) 0, /* UNSNAP-LINKS */
-/* 163 */ (char) 0, /* SAFE-PRIMITIVE-P */
-/* 164 */ (char) 0, /* SUBSTRING-READ */
-/* 165 */ (char) 0, /* SUBSTRING-WRITE */
-/* 166 */ (char) 0, /* SCREEN-X-SIZE */
-/* 167 */ (char) 0, /* SCREEN-Y-SIZE */
-/* 168 */ (char) 0, /* SCREEN-WRITE-CURSOR */
-/* 169 */ (char) 0, /* SCREEN-WRITE-CHARACTER */
-/* 16A */ (char) 0, /* SCREEN-WRITE-SUBSTRING */
-/* 16B */ (char) 0, /* NEXT-FILE-MATCHING */
-/* 16C */ (char) 0, /* unused */
-/* 16D */ (char) 0, /* TTY-WRITE-BYTE */
-/* 16E */ (char) 0, /* FILE-READ-BYTE */
-/* 16F */ (char) 0, /* FILE-WRITE-BYTE */
-/* 170 */ (char) 0, /* unused: SAVE-SCREEN */
-/* 171 */ (char) 0, /* unused: RESTORE-SCREEN */
-/* 172 */ (char) 0, /* unused: SUBSCREEN-CLEAR */
-/* 173 */ (char) 0, /* unused: AND-GCD */
-/* 174 */ (char) 0, /* unused: TTY-REDRAW-SCREEN */
-/* 175 */ (char) 0, /* unused: SCREEN-INVERSE-VIDEO */
-/* 176 */ (char) 1, /* STRING-TO-SYNTAX-ENTRY */
-/* 177 */ (char) 4, /* SCAN-WORD-FORWARD */
-/* 178 */ (char) 4, /* SCAN-WORD-BACKWARD */
-/* 179 */ (char) 7, /* SCAN-LIST-FORWARD */
-/* 17A */ (char) 7, /* SCAN-LIST-BACKWARD */
-/* 17B */ (char) 7, /* SCAN-SEXPS-FORWARD */
-/* 17C */ (char) 4, /* SCAN-FORWARD-TO-WORD */
-/* 17D */ (char) 4, /* SCAN-BACKWARD-PREFIX-CHARS */
-/* 17E */ (char) 2, /* CHAR-TO-SYNTAX-CODE */
-/* 17F */ (char) 4, /* QUOTED-CHAR-P */
-/* 180 */ (char) 0, /* MICROCODE-TABLES-FILENAME */
-/* 181 */ (char) 0, /* unused */
-/* 182 */ (char) 0, /* unused: FIND-PASCAL-PROGRAM */
-/* 183 */ (char) 0, /* unused: EXECUTE-PASCAL-PROGRAM */
-/* 184 */ (char) 0, /* unused: GRAPHICS-MOVE */
-/* 185 */ (char) 0, /* unused: GRAPHICS-LINE */
-/* 186 */ (char) 0, /* unused: GRAPHICS-PIXEL */
-/* 187 */ (char) 0, /* unused: GRAPHICS-SET-DRAWING-MODE */
-/* 188 */ (char) 0, /* unused: ALPHA-RASTER-P */
-/* 189 */ (char) 0, /* unused: TOGGLE-ALPHA-RASTER */
-/* 18A */ (char) 0, /* unused: GRAPHICS-RASTER-P */
-/* 18B */ (char) 0, /* unused: TOGGLE-GRAPHICS-RASTER */
-/* 18C */ (char) 0, /* unused: GRAPHICS-CLEAR */
-/* 18D */ (char) 0, /* unused: GRAPHICS-SET-LINE-STYLE */
-/* 18E */ (char) 3, /* ERROR-PROCEDURE */
-/* 18F */ (char) 0, /* VOLUME-EXISTS-P */
-/* 190 */ (char) 0, /* RE-CHAR-SET-ADJOIN */
-/* 191 */ (char) 0, /* RE-COMPILE-FASTMAP */
-/* 192 */ (char) 0, /* RE-MATCH */
-/* 193 */ (char) 0, /* RE-SEARCH-FORWARD */
-/* 194 */ (char) 0, /* RE-SEARCH-BACKWARD */
-/* 195 */ (char) 2, /* SYS-MEMORY-REF */
-/* 196 */ (char) 3, /* SYS-MEMORY-SET! */
-/* 197 */ (char) 2, /* BIT-STRING-FILL-X */
-/* 198 */ (char) 2, /* BIT-STRING-MOVE-X */
-/* 199 */ (char) 2, /* BIT-STRING-MOVEC-X */
-/* 19A */ (char) 2, /* BIT-STRING-OR-X */
-/* 19B */ (char) 2, /* BIT-STRING-AND-X */
-/* 19C */ (char) 2, /* BIT-STRING-ANDC-X */
-/* 19D */ (char) 2, /* BIT-STRING-EQUAL-P */
-/* 19E */ (char) 0, /* WORKING-DIRECTORY-PATHNAME */
-/* 19F */ (char) 1, /* OPEN-DIRECTORY */
-/* 1A0 */ (char) 0, /* DIRECTORY-READ */
-/* 1A1 */ (char) 0, /* UNDER-EMACS? */
-/* 1A2 */ (char) 0, /* TTY-FLUSH-OUTPUT */
-/* 1A3 */ (char) 0 /* RELOAD-BAND-NAME */
-};
-
-#if (MAX_PRIMITIVE_NUMBER != 0x1A3)
-/* Cause an error */
-#include "prims.h and storage.c are inconsistent -- arity table"
-#endif
-\f
-/* Declare the primitives themselves to be Externs */
-
-extern Pointer
- Prim_And_Make_Object(),
- Prim_Apply(), Prim_Apply_Step(), Prim_Arctan(), Prim_Arctan_Flonum(),
- Prim_Assq(), Prim_Band_Dump(), Prim_Band_Load(), Prim_Big_To_Fix(),
- Prim_Binary_Fasload(),
- Prim_Build_String_From_List(),
- Prim_Car(), Prim_Cat_Block(), Prim_Cat_Create_Date(),
- Prim_Cat_Create_Time(), Prim_Cat_Info(), Prim_Cat_Kind(),
- Prim_Cat_Last_Date(), Prim_Cat_Last_Time(), Prim_Cat_Lsize(),
- Prim_Cat_Name(), Prim_Cat_Psize(), Prim_Catch(), Prim_Cdr(),
- Prim_Ceiling(), Prim_Cell(), Prim_Cell_Contents(),
- Prim_Character_List_Hash(),
- Prim_Chk_And_Cln_Input_Channel(),
- Prim_Close_Lost_Open_Files(),
- Prim_Clear_To_End_Of_Line(),
- Prim_Close_Catalog(),
- Prim_Complete_Garbage_Collect(), Prim_Cons(),
- Prim_Constant_P(), Prim_Copy_File(),
- Prim_Cosine(), Prim_Cosine_Flonum(),
- Prim_Current_Date(), Prim_Current_Day(),
- Prim_Current_Dynamic_State(), Prim_Current_Hour(),
- Prim_Current_Minute(), Prim_Current_Month(), Prim_Current_Second(),
- Prim_Current_Time(), Prim_Current_Year(),
- Prim_Dangerize(), Prim_Dangerous_QM(),
- Prim_Divide(), Prim_Divide_Bignum(), Prim_Divide_Fixnum(),
- Prim_Divide_Flonum(),
- Prim_Enable_Interrupts(), Prim_Eq(),
- Prim_Equal_Bignum(), Prim_Equal_Fixnum(),
- Prim_Equal_Flonum(), Prim_Equal_Number(),
- Prim_Equal_String_To_List(), Prim_Error_Message(),
- Prim_Eval_Step(),
- Prim_Execute_At_New_Point(),
- Prim_Exp(), Prim_Fix_To_Big(),
- Prim_Exp_Flonum(), Prim_File_Exists(), Prim_Floor(), Prim_Force(),
- Prim_Garbage_Collect(), Prim_Gcd_Fixnum(),
- Prim_Gc_Type(),
- Prim_General_Car_Cdr(),
- Prim_Get_External_Count(), Prim_Get_Ext_Name(),
- Prim_Get_Ext_Number();
-
-/* Externs continue on next page */
-\f
-/* Externs, continued */
-
-extern Pointer
- Prim_Get_Fixed_Objects_Vector(),
- Prim_Get_Next_Constant(), Prim_Get_Next_Interrupt_Char(),
-#ifdef COMPILE_FUTURES
- Prim_Get_Work(),
-#endif
- Prim_Greater_Bignum(), Prim_Greater(),
- Prim_Greater_Fixnum(), Prim_Greater_Flonum(),
- Prim_Hunk3_Cons(), Prim_Hunk3_Cxr(), Prim_Hunk3_Set_Cxr(),
- Prim_Impurify(), Prim_Init_Floppy(),
- Prim_Ins_BStr(), Prim_Ins_BStr_Excl(),
- Prim_Insert_Non_Marked_Vector(), Prim_Insert_String(),
- Prim_Int_To_Float(), Prim_Integer_Divide(),
- Prim_Intern_Character_List(), Prim_String_To_Symbol(),
- Prim_Length(), Prim_Less(), Prim_Less_Bignum(), Prim_Less_Fixnum(),
- Prim_Less_Flonum(), Prim_Lexical_Assignment(),
- Prim_Lexical_Reference(), Prim_Link_File(),
- Prim_Listify_Bignum(), Prim_List_To_Vector(), Prim_Ln(),
- Prim_Ln_Flonum(), Prim_Load_Picture(), Prim_Local_Assignment(),
- Prim_Local_Reference(),
- Prim_Lookup_System_Symbol(), Prim_M_1_Plus(),
- Prim_M_1_Plus_Fixnum(), Prim_Make_Cell(),
- Prim_Make_Directory(), Prim_Make_Empty_String(),
- Prim_Make_Fld_String(),
- Prim_Make_Non_Pointer(), Prim_Make_State_Space(),
- Prim_Map_Code_To_Address(),
- Prim_Map_Address_To_Code(),
- Prim_Map_Prim_Address_To_Arity();
-
-/* Externs continue on next page */
-\f
-/* Externs, continued */
-
-extern Pointer
- Prim_Memq(),
- Prim_Microcode_Identify(),
- Prim_Minus(), Prim_Minus_Bignum(), Prim_Minus_Fixnum(),
- Prim_Minus_Flonum(), Prim_Multiply_Bignum(),
- Prim_Multiply(), Prim_Multiply_Fixnum(), Prim_Multiply_Flonum(),
- Prim_Negative(), Prim_Negative_Bignum(), Prim_Negative_Fixnum(),
- Prim_Negative_Flonum(), Prim_Next_File(),
- Prim_Non_Marked_Vector_Cons(), Prim_Non_Reentrant_Catch(),
- Prim_Non_Restartable_Exit(), Prim_Null(),
- Prim_One_Plus(), Prim_One_Plus_Fixnum(),
- Prim_Open_Catalog(),
- Prim_Overwrite_String(), Prim_Pack_Volume(),
- Prim_Pair(), Prim_Plus_Bignum(),
- Prim_Plus(), Prim_Plus_Fixnum(), Prim_Plus_Flonum(), Prim_Positive(),
- Prim_Positive_Bignum(),
- Prim_Positive_Fixnum(), Prim_Positive_Flonum(),
- Prim_Primitive_Datum(), Prim_Prim_Fasdump(),
- Prim_Prim_Fasload(), Prim_Primitive_Purify(),
- Prim_Primitive_Set_Type(), Prim_Prim_Type(),
- Prim_Prim_Type_QM(), Prim_Pure_P(),
- Prim_Raise_Char(), Prim_Raise_String(),
- Prim_Rehash(),
- Prim_Remove_File(), Prim_Rename_File(),
- Prim_Restartable_Exit(), Prim_Return_Step(),
- Prim_Round(),
- Prim_Round_Flonum(), Prim_Scode_Eval(), Prim_Set_Car(),
- Prim_Set_Cdr(), Prim_Set_Cell_Contents(),
- Prim_Set_Current_History(), Prim_Set_Dynamic_State(),
- Prim_Set_Fixed_Objects_Vector(), Prim_Set_Interrupt_Enables();
-
-/* Externs continue on next page */
\f
-/* Externs, continued */
-
-extern Pointer
- Prim_Set_Run_Light(),
- Prim_Sine(), Prim_Sine_Flonum(),
- Prim_Sqrt(), Prim_Sqrt_Flonum(), Prim_Store_Picture(),
- Prim_String_Equal(), Prim_String_Hash(),
- Prim_String_Less(), Prim_String_Position(),
- Prim_Substring(), Prim_Substring_Search(),
- Prim_Substring_To_List(), Prim_Subvector_To_List(),
- Prim_Sys_H3_0(), Prim_Sys_H3_1(),
- Prim_Sys_H3_2(), Prim_SH3_Set_0(),
- Prim_SH3_Set_1(), Prim_SH3_Set_2(),
- Prim_Sys_List_To_Vector(), Prim_Sys_Pair(),
- Prim_Sys_Pair_Car(), Prim_Sys_Pair_Cdr(),
- Prim_Sys_Pair_Cons(), Prim_Sys_Set_Car(),
- Prim_Sys_Set_Cdr(), Prim_Sys_Subvector_To_List(),
- Prim_Sys_Vector(), Prim_Sys_Vector_Ref(),
- Prim_Sys_Vec_Set(), Prim_Sys_Vec_Size(),
- Prim_System_Clock(),
- Prim_System_Memory_Ref(), Prim_System_Memory_Set(),
- Prim_Temp_Printer(),
- Prim_Translate_File(), Prim_Translate_To_Point(),
- Prim_Truncate(), Prim_Truncate_Flonum(), Prim_Truncate_String(),
- Prim_Unassigned_Test(), Prim_Unbound_Test(),
- Prim_Undangerize(), Prim_Unreferenceable_Test(),
- Prim_Unused(),
- Prim_Volume_Name(),
- Prim_Vector_8b(), Prim_Vector_8b_Cons(), Prim_Vector_8b_Ref(),
- Prim_Vec_8b_Size(), Prim_Vector_Cons(), Prim_Vector_Ref(),
- Prim_Vector_Set(), Prim_Vector_Size(), Prim_With_History_Disabled(),
- Prim_With_Interrupt_Mask(), Prim_With_Interrupts_Reduced(),
- Prim_With_Threaded_Stack(), Prim_Within_Control_Point(),
- Prim_Zero(), Prim_Zero_Bignum(), Prim_Zero_Fixnum(),
- Prim_Zero_Flonum(), Prim_Zero_Floppy();
-\f
-extern Pointer
- Prim_Make_Char(), Prim_Char_Bits(), Prim_Char_Code(),
- Prim_Char_To_Integer(), Prim_Integer_To_Char(),
- Prim_Char_Downcase(), Prim_Char_Upcase(), Prim_Ascii_To_Char(),
- Prim_Char_Ascii_P(), Prim_Char_To_Ascii(),
-
- Prim_File_Open_Channel(), Prim_File_Close_Channel(),
- Prim_File_Eof_P(), Prim_File_Read_Char(),
- Prim_File_Fill_Input_Buffer(), Prim_File_Length(),
- Prim_File_Write_Char(), Prim_File_Write_String(),
-
- Prim_Tty_Read_Char_Ready_P(), Prim_Tty_Read_Char(),
- Prim_Tty_Read_Char_Immediate(), Prim_Tty_Read_Finish(),
- Prim_Tty_Write_Char(), Prim_Tty_Write_String(), Prim_tty_flush_output(),
- Prim_Tty_Beep(), Prim_Tty_Clear(),
- Prim_Photo_Open(), Prim_Photo_Close(),
- Prim_Setup_Timer_Interrupt(),
- Prim_Tty_Move_Cursor(), Prim_Tty_Get_Cursor(),
-
- Prim_String_P(),Prim_String_Length(),Prim_String_Ref(),
- Prim_String_Set(), Prim_Substring_Move_Right(),
- Prim_Substring_Move_Left(), Prim_String_Allocate(),
- Prim_String_Maximum_Length(), Prim_Set_String_Length();
-
-extern Pointer
- Prim_Vector_8b_Set(), Prim_Vector_8b_Fill(),
- Prim_Vector_8b_Find_Next_Char(),
- Prim_Vector_8b_Find_Previous_Char(),
- Prim_Vector_8b_Find_Next_Char_Ci(),
- Prim_Vector_8b_Find_Previous_Char_Ci(),
- Prim_Substring_Find_Next_Char_In_Set(),
- Prim_Substring_Find_Previous_Char_In_Set(),
- Prim_Substring_Equal(),
- Prim_Substring_Ci_Equal(),
- Prim_Substring_Less(),
- Prim_Substring_Upcase(),
- Prim_Substring_Downcase(),
- Prim_Substring_Match_Forward(),
- Prim_Substring_Match_Backward(),
- Prim_Substring_Match_Forward_Ci(),
- Prim_Substring_Match_Backward_Ci(),
- Prim_Screen_X_Size(),
- Prim_Screen_Y_Size(),
-/* Not yet implemented below here */
- Prim_Extract_Non_Marked_Vector(),
- Prim_Unsnap_Links(),
- Prim_Safe_Primitive_P(),
- Prim_Substring_Read(),
- Prim_Substring_Write(),
- Prim_Screen_Write_Cursor(),
- Prim_Screen_Write_Character(),
- Prim_Screen_Write_Substring(),
- Prim_Next_File_Matching(),
- Prim_Tty_Write_Byte(),
- Prim_File_Read_Byte(),
- Prim_File_Write_Byte(),
-#if false
- Prim_And_Gcd(),
- Prim_Save_Screen(),
- Prim_Restore_Screen(),
- Prim_Subscreen_Clear(),
- Prim_Tty_Redraw_Screen(),
- Prim_Screen_Inverse_Video(),
-#endif
- Prim_String_To_Syntax_Entry(),
- Prim_Scan_Word_Forward(),
- Prim_Scan_Word_Backward(),
- Prim_Scan_List_Forward(),
- Prim_Scan_List_Backward(),
- Prim_Scan_Sexps_Forward(),
- Prim_Scan_Forward_To_Word(),
- Prim_Scan_Backward_Prefix_Chars(),
- Prim_Char_To_Syntax_Code(),
- Prim_Quoted_Char_P(),
- Prim_Microcode_Tables_Filename(),
- Prim_Error_Procedure(),
- Prim_Volume_Exists_P(),
- Prim_Re_Char_Set_Adjoin(),
- Prim_Re_Compile_Fastmap(),
- Prim_Re_Match(),
- Prim_Re_Search_Forward(),
- Prim_Re_Search_Backward(),
-
-/* new directory access primitives */
- Prim_working_directory_pathname(),
- Prim_set_working_directory_pathname_x(),
- Prim_open_directory(),
- Prim_directory_read(),
-
-/* new bit string primitives */
- Prim_bit_string_allocate(), Prim_make_bit_string(),
- Prim_bit_string_p(), Prim_bit_string_length(),
- Prim_bit_string_ref(), Prim_bit_substring_move_right_x(),
- Prim_bit_string_set_x(), Prim_bit_string_clear_x(),
- Prim_unsigned_integer_to_bit_string(), Prim_bit_string_to_unsigned_integer(),
- Prim_read_bits_x(), Prim_write_bits_x(),
- Prim_bit_string_fill_x(), Prim_bit_string_move_x(),
- Prim_bit_string_movec_x(), Prim_bit_string_or_x(),
- Prim_bit_string_and_x(), Prim_bit_string_andc_x(),
- Prim_bit_string_equal_p(), Prim_bit_string_zero_p(),
-
- Prim_under_emacs_p(), Prim_reload_band_name();
-\f
-/* The table of all primitive procedures */
-
-Pointer (*(Primitive_Table[]))() = {
-/* 000 */ Prim_Lexical_Assignment,
-/* 001 */ Prim_Local_Reference,
-/* 002 */ Prim_Local_Assignment,
-/* 003 */ Prim_Catch,
-/* 004 */ Prim_Scode_Eval,
-/* 005 */ Prim_Apply,
-/* 006 */ Prim_Set_Interrupt_Enables,
-/* 007 */ Prim_String_To_Symbol,
-#ifdef COMPILE_FUTURES
-/* 008 */ Prim_Get_Work,
-#else
-/* 008 */ Prim_Unused,
-#endif
-/* 009 */ Prim_Non_Reentrant_Catch,
-/* 00A */ Prim_Current_Dynamic_State,
-/* 00B */ Prim_Set_Dynamic_State,
-/* 00C */ Prim_Null,
-/* 00D */ Prim_Eq,
-/* 00E */ Prim_String_Equal,
-/* 00F */ Prim_Prim_Type_QM,
-/* 010 */ Prim_Prim_Type,
-/* 011 */ Prim_Primitive_Set_Type,
-/* 012 */ Prim_Lexical_Reference,
-/* 013 */ Prim_Unreferenceable_Test,
-/* 014 */ Prim_Make_Char,
-/* 015 */ Prim_Char_Bits,
-/* 016 */ Prim_Non_Restartable_Exit,
-/* 017 */ Prim_Char_Code,
-/* 018 */ Prim_Unassigned_Test,
-/* 019 */ Prim_Insert_Non_Marked_Vector,
-/* 01A */ Prim_Restartable_Exit,
-/* 01B */ Prim_Char_To_Integer,
-/* 01C */ Prim_Memq,
-/* 01D */ Prim_Insert_String,
-/* 01E */ Prim_Enable_Interrupts,
-/* 01F */ Prim_Make_Empty_String,
-/* 020 */ Prim_Cons,
-/* 021 */ Prim_Car,
-/* 022 */ Prim_Cdr,
-/* 023 */ Prim_Set_Car,
-/* 024 */ Prim_Set_Cdr,
-/* 025 */ Prim_Unused,
-/* 026 */ Prim_Tty_Get_Cursor,
-/* 027 */ Prim_General_Car_Cdr,
-/* 028 */ Prim_Hunk3_Cons,
-
-/* Primitive dispatch table continues on next page */
-\f
-/* Primitive dispatch table, continued */
-
-/* 029 */ Prim_Hunk3_Cxr,
-/* 02A */ Prim_Hunk3_Set_Cxr,
-/* 02B */ Prim_Overwrite_String,
-/* 02C */ Prim_Vector_Cons,
-/* 02D */ Prim_Vector_Size,
-/* 02E */ Prim_Vector_Ref,
-/* 02F */ Prim_Set_Current_History,
-/* 030 */ Prim_Vector_Set,
-/* 031 */ Prim_Non_Marked_Vector_Cons,
-/* 032 */ Prim_Unused,
-/* 033 */ Prim_Unbound_Test,
-/* 034 */ Prim_Integer_To_Char,
-/* 035 */ Prim_Char_Downcase,
-/* 036 */ Prim_Char_Upcase,
-/* 037 */ Prim_Ascii_To_Char,
-/* 038 */ Prim_Char_Ascii_P,
-/* 039 */ Prim_Char_To_Ascii,
-/* 03A */ Prim_Garbage_Collect,
-/* 03B */ Prim_Plus_Fixnum,
-/* 03C */ Prim_Minus_Fixnum,
-/* 03D */ Prim_Multiply_Fixnum,
-/* 03E */ Prim_Divide_Fixnum,
-/* 03F */ Prim_Equal_Fixnum,
-/* 040 */ Prim_Less_Fixnum,
-/* 041 */ Prim_Positive_Fixnum,
-/* 042 */ Prim_One_Plus_Fixnum,
-/* 043 */ Prim_M_1_Plus_Fixnum,
-/* 044 */ Prim_Truncate_String,
-/* 045 */ Prim_Substring,
-/* 046 */ Prim_Zero_Fixnum,
-/* 047 */ Prim_Undangerize,
-/* 048 */ Prim_Dangerize,
-/* 049 */ Prim_Dangerous_QM,
-/* 04A */ Prim_Substring_To_List,
-/* 04B */ Prim_Make_Fld_String,
-/* 04C */ Prim_Plus_Bignum,
-/* 04D */ Prim_Minus_Bignum,
-/* 04E */ Prim_Multiply_Bignum,
-/* 04F */ Prim_Divide_Bignum,
-/* 050 */ Prim_Listify_Bignum,
-/* 051 */ Prim_Equal_Bignum,
-/* 052 */ Prim_Less_Bignum,
-/* 053 */ Prim_Positive_Bignum,
-
-/* Primitive dispatch table continues on next page */
-\f
-/* Primitive dispatch table, continued */
-
-/* 054 */ Prim_File_Open_Channel,
-/* 055 */ Prim_File_Close_Channel,
-/* 056 */ Prim_Prim_Fasdump,
-/* 057 */ Prim_Binary_Fasload,
-/* 058 */ Prim_String_Position,
-/* 059 */ Prim_String_Less,
-/* 05A */ Prim_Unused,
-/* 05B */ Prim_Unused,
-/* 05C */ Prim_Rehash,
-/* 05D */ Prim_Length,
-/* 05E */ Prim_Assq,
-/* 05F */ Prim_Build_String_From_List,
-/* 060 */ Prim_Equal_String_To_List,
-/* 061 */ Prim_Make_Cell,
-/* 062 */ Prim_Cell_Contents,
-/* 063 */ Prim_Cell,
-/* 064 */ Prim_Raise_Char,
-/* 065 */ Prim_Character_List_Hash,
-/* 066 */ Prim_Gcd_Fixnum,
-/* 067 */ Prim_Fix_To_Big,
-/* 068 */ Prim_Big_To_Fix,
-/* 069 */ Prim_Plus_Flonum,
-/* 06A */ Prim_Minus_Flonum,
-/* 06B */ Prim_Multiply_Flonum,
-/* 06C */ Prim_Divide_Flonum,
-/* 06D */ Prim_Equal_Flonum,
-/* 06E */ Prim_Less_Flonum,
-/* 06F */ Prim_Zero_Bignum,
-/* 070 */ Prim_Truncate_Flonum,
-/* 071 */ Prim_Round_Flonum,
-/* 072 */ Prim_Int_To_Float,
-/* 073 */ Prim_Sine_Flonum,
-/* 074 */ Prim_Cosine_Flonum,
-/* 075 */ Prim_Arctan_Flonum,
-/* 076 */ Prim_Exp_Flonum,
-/* 077 */ Prim_Ln_Flonum,
-/* 078 */ Prim_Sqrt_Flonum,
-/* 079 */ Prim_Prim_Fasload,
-/* 07A */ Prim_Get_Fixed_Objects_Vector,
-/* 07B */ Prim_Set_Fixed_Objects_Vector,
-/* 07C */ Prim_List_To_Vector,
-/* 07D */ Prim_Subvector_To_List,
-/* 07E */ Prim_Pair,
-/* 07F */ Prim_Negative_Fixnum,
-/* 080 */ Prim_Negative_Bignum,
-
-/* Primitive dispatch table continues on next page */
-\f
-/* Primitive dispatch table, continued */
-
-/* 081 */ Prim_Greater_Fixnum,
-/* 082 */ Prim_Greater_Bignum,
-/* 083 */ Prim_String_Hash,
-/* 084 */ Prim_Sys_Pair_Cons,
-/* 085 */ Prim_Sys_Pair,
-/* 086 */ Prim_Sys_Pair_Car,
-/* 087 */ Prim_Sys_Pair_Cdr,
-/* 088 */ Prim_Sys_Set_Car,
-/* 089 */ Prim_Sys_Set_Cdr,
-/* 08A */ Prim_Unused,
-/* 08B */ Prim_Unused,
-/* 08C */ Prim_Set_Cell_Contents,
-/* 08D */ Prim_And_Make_Object,
-/* 08E */ Prim_Sys_H3_0,
-/* 08F */ Prim_SH3_Set_0,
-/* 090 */ Prim_Map_Address_To_Code,
-/* 091 */ Prim_Sys_H3_1,
-/* 092 */ Prim_SH3_Set_1,
-/* 093 */ Prim_Map_Code_To_Address,
-/* 094 */ Prim_Sys_H3_2,
-/* 095 */ Prim_SH3_Set_2,
-/* 096 */ Prim_Map_Prim_Address_To_Arity,
-/* 097 */ Prim_Sys_List_To_Vector,
-/* 098 */ Prim_Sys_Subvector_To_List,
-/* 099 */ Prim_Sys_Vector,
-/* 09A */ Prim_Sys_Vector_Ref,
-/* 09B */ Prim_Sys_Vec_Set,
-/* 09C */ Prim_With_History_Disabled,
-/* 09D */ Prim_Unused,
-/* 09E */ Prim_Unused,
-/* 09F */ Prim_Unused,
-/* 0A0 */ Prim_Unused,
-/* 0A1 */ Prim_Unused,
-/* 0A2 */ Prim_Unused,
-/* 0A3 */ Prim_Vector_8b_Cons,
-/* 0A4 */ Prim_Vector_8b,
-/* 0A5 */ Prim_Vector_8b_Ref,
-/* 0A6 */ Prim_Vector_8b_Set,
-/* 0A7 */ Prim_Zero_Flonum,
-/* 0A8 */ Prim_Positive_Flonum,
-/* 0A9 */ Prim_Negative_Flonum,
-/* 0AA */ Prim_Greater_Flonum,
-/* 0AB */ Prim_Intern_Character_List,
-
-/* Primitive dispatch table continues on next page */
-\f
-/* Primitive dispatch table, continued */
-
-/* 0AC */ Prim_Unused,
-/* 0AD */ Prim_Vec_8b_Size,
-/* 0AE */ Prim_Sys_Vec_Size,
-/* 0AF */ Prim_Force,
-/* 0B0 */ Prim_Primitive_Datum,
-/* 0B1 */ Prim_Make_Non_Pointer,
-/* 0B2 */ Prim_Temp_Printer,
-/* 0B3 */ Prim_Raise_String,
-/* 0B4 */ Prim_Primitive_Purify,
-/* 0B5 */ Prim_Unused,
-/* 0B6 */ Prim_Complete_Garbage_Collect,
-/* 0B7 */ Prim_Band_Dump,
-/* 0B8 */ Prim_Substring_Search,
-/* 0B9 */ Prim_Band_Load,
-/* 0BA */ Prim_Constant_P,
-/* 0BB */ Prim_Pure_P,
-/* 0BC */ Prim_Gc_Type,
-/* 0BD */ Prim_Impurify,
-/* 0BE */ Prim_With_Threaded_Stack,
-/* 0BF */ Prim_Within_Control_Point,
-/* 0C0 */ Prim_Set_Run_Light,
-/* 0C1 */ Prim_File_Eof_P,
-/* 0C2 */ Prim_File_Read_Char,
-/* 0C3 */ Prim_File_Fill_Input_Buffer,
-/* 0C4 */ Prim_File_Length,
-/* 0C5 */ Prim_File_Write_Char,
-/* 0C6 */ Prim_File_Write_String,
-/* 0C7 */ Prim_Close_Lost_Open_Files,
-/* 0C8 */ Prim_Unused,
-/* 0C9 */ Prim_With_Interrupts_Reduced,
-
-/* Primitive dispatch table continues on next page */
-\f
-/* Primitive dispatch table, continued */
-
-/* 0CA */ Prim_Eval_Step,
-/* 0CB */ Prim_Apply_Step,
-/* 0CC */ Prim_Return_Step,
-/* 0CD */ Prim_Tty_Read_Char_Ready_P,
-/* 0CE */ Prim_Tty_Read_Char,
-/* 0CF */ Prim_Tty_Read_Char_Immediate,
-/* 0D0 */ Prim_Tty_Read_Finish,
-/* 0D1 */ Prim_bit_string_allocate,
-/* 0D2 */ Prim_make_bit_string,
-/* 0D3 */ Prim_bit_string_p,
-/* 0D4 */ Prim_bit_string_length,
-/* 0D5 */ Prim_bit_string_ref,
-/* 0D6 */ Prim_bit_substring_move_right_x,
-/* 0D7 */ Prim_bit_string_set_x,
-/* 0D8 */ Prim_bit_string_clear_x,
-/* 0D9 */ Prim_bit_string_zero_p,
-/* 0DA */ Prim_Unused,
-/* 0DB */ Prim_Unused,
-/* 0DC */ Prim_unsigned_integer_to_bit_string,
-/* 0DD */ Prim_bit_string_to_unsigned_integer,
-/* 0DE */ Prim_Unused,
-/* 0DF */ Prim_read_bits_x,
-/* 0E0 */ Prim_write_bits_x,
-/* 0E1 */ Prim_Make_State_Space,
-/* 0E2 */ Prim_Execute_At_New_Point,
-/* 0E3 */ Prim_Translate_To_Point,
-/* 0E4 */ Prim_Get_Next_Constant,
-/* 0E5 */ Prim_Microcode_Identify,
-
-/* Primitive dispatch table continues on next page */
-\f
-/* Primitive dispatch table, continued */
-
-/* 0E6 */ Prim_Zero,
-/* 0E7 */ Prim_Positive,
-/* 0E8 */ Prim_Negative,
-/* 0E9 */ Prim_Equal_Number,
-/* 0EA */ Prim_Less,
-/* 0EB */ Prim_Greater,
-/* 0EC */ Prim_Plus,
-/* 0ED */ Prim_Minus,
-/* 0EE */ Prim_Multiply,
-/* 0EF */ Prim_Divide,
-/* 0F0 */ Prim_Integer_Divide,
-/* 0F1 */ Prim_One_Plus,
-/* 0F2 */ Prim_M_1_Plus,
-/* 0F3 */ Prim_Truncate,
-/* 0F4 */ Prim_Round,
-/* 0F5 */ Prim_Floor,
-/* 0F6 */ Prim_Ceiling,
-/* 0F7 */ Prim_Sqrt,
-/* 0F8 */ Prim_Exp,
-/* 0F9 */ Prim_Ln,
-/* 0FA */ Prim_Sine,
-/* 0FB */ Prim_Cosine,
-/* 0FC */ Prim_Arctan,
-/* 0FD */ Prim_Tty_Write_Char,
-/* 0FE */ Prim_Tty_Write_String,
-/* 0FF */ Prim_Tty_Beep,
-/* 100 */ Prim_Tty_Clear,
-/* 101 */ Prim_Get_External_Count,
-/* 102 */ Prim_Get_Ext_Name,
-/* 103 */ Prim_Get_Ext_Number,
-/* 104 */ Prim_Unused,
-/* 105 */ Prim_Unused,
-/* 106 */ Prim_Get_Next_Interrupt_Char,
-/* 107 */ Prim_Chk_And_Cln_Input_Channel,
-/* 108 */ Prim_Unused,
-/* 109 */ Prim_System_Clock,
-/* 10a */ Prim_File_Exists,
-/* 10b */ Prim_Unused,
-/* 10c */ Prim_Tty_Move_Cursor,
-/* 10d */ Prim_Unused,
-/* 10e */ Prim_Current_Date,
-/* 10f */ Prim_Current_Time,
-/* 110 */ Prim_Translate_File,
-/* 111 */ Prim_Copy_File,
-/* 112 */ Prim_Rename_File,
-/* 113 */ Prim_Remove_File,
-/* 114 */ Prim_Link_File,
-/* 115 */ Prim_Make_Directory,
-/* 116 */ Prim_Volume_Name,
-/* 117 */ Prim_set_working_directory_pathname_x,
-/* 118 */ Prim_Open_Catalog,
-/* 119 */ Prim_Close_Catalog,
-/* 11a */ Prim_Next_File,
-/* 11b */ Prim_Cat_Name,
-/* 11c */ Prim_Cat_Kind,
-/* 11d */ Prim_Cat_Psize,
-/* 11e */ Prim_Cat_Lsize,
-/* 11f */ Prim_Cat_Info,
-/* 120 */ Prim_Cat_Block,
-/* 121 */ Prim_Cat_Create_Date,
-/* 122 */ Prim_Cat_Create_Time,
-/* 123 */ Prim_Cat_Last_Date,
-/* 124 */ Prim_Cat_Last_Time,
-/* 125 */ Prim_Error_Message,
-/* 126 */ Prim_Current_Year,
-/* 127 */ Prim_Current_Month,
-/* 128 */ Prim_Current_Day,
-/* 129 */ Prim_Current_Hour,
-/* 12a */ Prim_Current_Minute,
-/* 12b */ Prim_Current_Second,
-/* 12c */ Prim_Init_Floppy,
-/* 12d */ Prim_Zero_Floppy,
-/* 12e */ Prim_Pack_Volume,
-/* 12f */ Prim_Load_Picture,
-/* 130 */ Prim_Store_Picture,
-/* 131 */ Prim_Lookup_System_Symbol,
-/* 132 */ Prim_Unused,
-/* 133 */ Prim_Unused,
-/* 134 */ Prim_Clear_To_End_Of_Line,
-/* 135 */ Prim_Unused,
-/* 136 */ Prim_Unused,
-/* 137 */ Prim_With_Interrupt_Mask,
-/* 138 */ Prim_String_P,
-/* 139 */ Prim_String_Length,
-/* 13A */ Prim_String_Ref,
-/* 13B */ Prim_String_Set,
-/* 13C */ Prim_Substring_Move_Right,
-/* 13D */ Prim_Substring_Move_Left,
-/* 13E */ Prim_String_Allocate,
-/* 13F */ Prim_String_Maximum_Length,
-/* 140 */ Prim_Set_String_Length,
-/* 141 */ Prim_Vector_8b_Fill,
-/* 142 */ Prim_Vector_8b_Find_Next_Char,
-/* 143 */ Prim_Vector_8b_Find_Previous_Char,
-/* 144 */ Prim_Vector_8b_Find_Next_Char_Ci,
-/* 145 */ Prim_Vector_8b_Find_Previous_Char_Ci,
-/* 146 */ Prim_Substring_Find_Next_Char_In_Set,
-/* 147 */ Prim_Substring_Find_Previous_Char_In_Set,
-/* 148 */ Prim_Substring_Equal,
-/* 149 */ Prim_Substring_Ci_Equal,
-/* 14A */ Prim_Substring_Less,
-/* 14B */ Prim_Substring_Upcase,
-/* 14C */ Prim_Substring_Downcase,
-/* 14D */ Prim_Substring_Match_Forward,
-/* 14E */ Prim_Substring_Match_Backward,
-/* 14F */ Prim_Substring_Match_Forward_Ci,
-/* 150 */ Prim_Substring_Match_Backward_Ci,
-/* 151 */ Prim_Photo_Open,
-/* 152 */ Prim_Photo_Close,
-/* 153 */ Prim_Setup_Timer_Interrupt,
-/* 154 */ Prim_Unused,
-/* 155 */ Prim_Unused,
-/* 156 */ Prim_Unused,
-/* 157 */ Prim_Unused,
-/* 158 */ Prim_Unused,
-/* 159 */ Prim_Unused,
-/* 15A */ Prim_Unused,
-/* 15B */ Prim_Unused,
-/* 15C */ Prim_Unused,
-/* 15D */ Prim_Unused,
-/* 15E */ Prim_Unused,
-/* 15F */ Prim_Unused,
-/* 160 */ Prim_Unused,
-/* 161 */ Prim_Extract_Non_Marked_Vector,
-/* 162 */ Prim_Unsnap_Links,
-/* 163 */ Prim_Safe_Primitive_P,
-/* 164 */ Prim_Substring_Read,
-/* 165 */ Prim_Substring_Write,
-/* 166 */ Prim_Screen_X_Size,
-/* 167 */ Prim_Screen_Y_Size,
-/* 168 */ Prim_Screen_Write_Cursor,
-/* 169 */ Prim_Screen_Write_Character,
-/* 16a */ Prim_Screen_Write_Substring,
-/* 16b */ Prim_Next_File_Matching,
-/* 16c */ Prim_Unused,
-/* 16d */ Prim_Tty_Write_Byte,
-/* 16e */ Prim_File_Read_Byte,
-/* 16f */ Prim_File_Write_Byte,
-/* 170 */ Prim_Unused, /* Prim_Save_Screen, */
-/* 171 */ Prim_Unused, /* Prim_Restore_Screen, */
-/* 172 */ Prim_Unused, /* Prim_Subscreen_Clear, */
-/* 173 */ Prim_Unused, /* Prim_And_Gcd, */
-/* 174 */ Prim_Unused, /* Prim_Tty_Redraw_Screen, */
-/* 175 */ Prim_Unused, /* Prim_Screen_Inverse_Video, */
-/* 176 */ Prim_String_To_Syntax_Entry,
-/* 177 */ Prim_Scan_Word_Forward,
-/* 178 */ Prim_Scan_Word_Backward,
-/* 179 */ Prim_Scan_List_Forward,
-/* 17a */ Prim_Scan_List_Backward,
-/* 17b */ Prim_Scan_Sexps_Forward,
-/* 17c */ Prim_Scan_Forward_To_Word,
-/* 17d */ Prim_Scan_Backward_Prefix_Chars,
-/* 17e */ Prim_Char_To_Syntax_Code,
-/* 17f */ Prim_Quoted_Char_P,
-/* 180 */ Prim_Microcode_Tables_Filename,
-/* 181 */ Prim_Unused,
-/* 182 */ Prim_Unused, /* Prim_Find_Pascal_Program, */
-/* 183 */ Prim_Unused, /* Prim_Execute_Pascal_Program, */
-/* 184 */ Prim_Unused, /* Prim_Graphics_Move, */
-/* 185 */ Prim_Unused, /* Prim_Graphics_Line, */
-/* 186 */ Prim_Unused, /* Prim_Graphics_Pixel, */
-/* 187 */ Prim_Unused, /* Prim_Graphics_Set_Drawing_Mode, */
-/* 188 */ Prim_Unused, /* Prim_Alpha_Raster_P, */
-/* 189 */ Prim_Unused, /* Prim_Toggle_Alpha_Raster, */
-/* 18a */ Prim_Unused, /* Prim_Graphics_Raster_P, */
-/* 18b */ Prim_Unused, /* Prim_Toggle_Graphics_Raster, */
-/* 18c */ Prim_Unused, /* Prim_Graphics_Clear, */
-/* 18d */ Prim_Unused, /* Prim_Graphics_Set_Line_Style, */
-/* 18e */ Prim_Error_Procedure,
-/* 18f */ Prim_Volume_Exists_P,
-/* 190 */ Prim_Re_Char_Set_Adjoin,
-/* 191 */ Prim_Re_Compile_Fastmap,
-/* 192 */ Prim_Re_Match,
-/* 193 */ Prim_Re_Search_Forward,
-/* 194 */ Prim_Re_Search_Backward,
-/* 195 */ Prim_System_Memory_Ref,
-/* 196 */ Prim_System_Memory_Set,
-/* 197 */ Prim_bit_string_fill_x,
-/* 198 */ Prim_bit_string_move_x,
-/* 199 */ Prim_bit_string_movec_x,
-/* 19a */ Prim_bit_string_or_x,
-/* 19b */ Prim_bit_string_and_x,
-/* 19c */ Prim_bit_string_andc_x,
-/* 19d */ Prim_bit_string_equal_p,
-/* 19E */ Prim_working_directory_pathname,
-/* 19F */ Prim_open_directory,
-/* 1A0 */ Prim_directory_read,
-/* 1A1 */ Prim_under_emacs_p,
-/* 1A2 */ Prim_tty_flush_output,
-/* 1A3 */ Prim_reload_band_name
-};
-
-#if (MAX_PRIMITIVE_NUMBER != 0x1A3)
-/* Cause an error */
-#include "Prims.h and storage.c are inconsistent -- Procedure Table"
-#endif
-\f
-/* And, finally, the table of primitive names. */
-
static char No_Name[] = "";
-char *Primitive_Names[] = {
-
-/* 0x00 in lookup */ "LEXICAL-ASSIGNMENT",
-/* 0x01 in lookup */ "LOCAL-REFERENCE",
-/* 0x02 in lookup */ "LOCAL-ASSIGNMENT",
-/* 0x03 in hooks */ "CALL-WITH-CURRENT-CONTINUATION",
-/* 0x04 in hooks */ "SCODE-EVAL",
-/* 0x05 in hooks */ "APPLY",
-/* 0x06 in hooks */ "SET-INTERRUPT-ENABLES!",
-/* 0x07 in fasload */ "STRING->SYMBOL",
-/* 0x08 in random */ "GET-WORK",
-/* 0x09 in hooks */ "NON-REENTRANT-CALL-WITH-CURRENT-CONTINUATION",
-/* 0x0A in hooks */ "CURRENT-DYNAMIC-STATE",
-/* 0x0B in hooks */ "SET-CURRENT-DYNAMIC-STATE!",
-/* 0x0C in prim */ "NULL?",
-/* 0x0D in prim */ "EQ?",
-/* 0x0E in string */ "STRING-EQUAL?",
-/* 0x0F in prim */ "PRIMITIVE-TYPE?",
-/* 0x10 in prim */ "PRIMITIVE-TYPE",
-/* 0x11 in prim */ "PRIMITIVE-SET-TYPE",
-/* 0x12 in lookup */ "LEXICAL-REFERENCE",
-/* 0x13 in lookup */ "LEXICAL-UNREFERENCEABLE?",
-/* 0x14 in character */ "MAKE-CHAR",
-/* 0x15 in character */ "CHAR-BITS",
-/* 0x16 in sysprim */ "EXIT",
-/* 0x17 in character */ "CHAR-CODE",
-/* 0x18 in lookup */ "LEXICAL-UNASSIGNED?",
-/* 0x19 in random */ "INSERT-NON-MARKED-VECTOR!",
-/* 0x1A in sysprim */ "HALT",
-/* 0x1B in character */ "CHAR->INTEGER",
-/* 0x1C in list */ "MEMQ",
-/* 0x1D in string */ "INSERT-STRING",
-/* 0x1E in hooks */ "ENABLE-INTERRUPTS!",
-/* 0x1F in string */ "MAKE-EMPTY-STRING",
-/* 0x20 in list */ "CONS",
-/* 0x21 in list */ "CAR",
-/* 0x22 in list */ "CDR",
-/* 0x23 in list */ "SET-CAR!",
-/* 0x24 in list */ "SET-CDR!",
-
-/* Primitive names continue on the next page */
-\f
-/* Primitive names, continued */
-
-/* 0x25 not here */ No_Name,
-/* 0x26 in ttyio */ "TTY-GET-CURSOR",
-/* 0x27 in list */ "GENERAL-CAR-CDR",
-/* 0x28 in hunk */ "HUNK3-CONS",
-/* 0x29 in hunk */ "HUNK3-CXR",
-/* 0x2A in hunk */ "HUNK3-SET-CXR!",
-/* 0x2B in string */ "INSERT-STRING!",
-/* 0x2C in vector */ "VECTOR-CONS",
-/* 0x2D in vector */ "VECTOR-LENGTH",
-/* 0x2E in vector */ "VECTOR-REF",
-/* 0x2F in hooks */ "SET-CURRENT-HISTORY!",
-/* 0x30 in vector */ "VECTOR-SET!",
-/* 0x31 in random */ "NON-MARKED-VECTOR-CONS",
-/* 0x32 not here */ No_Name,
-/* 0x33 in lookup */ "LEXICAL-UNBOUND?",
-/* 0x34 in character */ "INTEGER->CHAR",
-/* 0x35 in character */ "CHAR-DOWNCASE",
-/* 0x36 in character */ "CHAR-UPCASE",
-/* 0x37 in character */ "ASCII->CHAR",
-/* 0x38 in character */ "CHAR-ASCII?",
-/* 0x39 in character */ "CHAR->ASCII",
-/* 0x3A in memmag */ "GARBAGE-COLLECT",
-/* 0x3B in fixnum */ "PLUS-FIXNUM",
-/* 0x3C in fixnum */ "MINUS-FIXNUM",
-/* 0x3D in fixnum */ "MULTIPLY-FIXNUM",
-/* 0x3E in fixnum */ "DIVIDE-FIXNUM",
-/* 0x3F in fixnum */ "EQUAL-FIXNUM?",
-/* 0x40 in fixnum */ "LESS-THAN-FIXNUM?",
-/* 0x41 in fixnum */ "POSITIVE-FIXNUM?",
-/* 0x42 in fixnum */ "ONE-PLUS-FIXNUM",
-/* 0x43 in fixnum */ "MINUS-ONE-PLUS-FIXNUM",
-/* 0x44 in string */ "TRUNCATE-STRING!",
-/* 0x45 in string */ "SUBSTRING",
-/* 0x46 in fixnum */ "ZERO-FIXNUM?",
-/* 0x47 in prim */ "MAKE-OBJECT-SAFE",
-/* 0x48 in prim */ "MAKE-OBJECT-DANGEROUS",
-/* 0x49 in prim */ "OBJECT-DANGEROUS?",
-/* 0x4A in string */ "SUBSTRING->LIST",
-/* 0x4B in string */ "MAKE-FILLED-STRING",
-/* 0x4C in bignum */ "PLUS-BIGNUM",
-/* 0x4D in bignum */ "MINUS-BIGNUM",
-/* 0x4E in bignum */ "MULTIPLY-BIGNUM",
-/* 0x4F in bignum */ "DIVIDE-BIGNUM",
-
-/* Primitive names continue on the next page */
-\f
-/* Primitive names, continued */
-
-/* 0x50 in bignum */ "LISTIFY-BIGNUM",
-/* 0x51 in bignum */ "EQUAL-BIGNUM?",
-/* 0x52 in bignum */ "LESS-THAN-BIGNUM?",
-/* 0x53 in bignum */ "POSITIVE-BIGNUM?",
-/* 0x54 in fileio */ "FILE-OPEN-CHANNEL",
-/* 0x55 in fileio */ "FILE-CLOSE-CHANNEL",
-/* 0x56 in fasdump */ "PRIMITIVE-FASDUMP",
-/* 0x57 in fasload */ "BINARY-FASLOAD",
-/* 0x58 in string */ "STRING-POSITION",
-/* 0x59 in string */ "STRING-LESS?",
-/* 0x5A not here */ No_Name,
-/* 0x5B not here */ No_Name,
-/* 0x5C in daemon */ "REHASH",
-/* 0x5D in list */ "LENGTH",
-/* 0x5E in list */ "ASSQ",
-/* 0x5F in string */ "LIST->STRING",
-/* 0x60 in string */ "EQUAL-STRING-TO-LIST?",
-/* 0x61 in prim */ "MAKE-CELL",
-/* 0x62 in prim */ "CELL-CONTENTS",
-/* 0x63 in prim */ "CELL?",
-/* 0x64 in string */ "CHARACTER-UPCASE",
-/* 0x65 in fasload */ "CHARACTER-LIST-HASH",
-/* 0x66 in fixnum */ "GCD-FIXNUM",
-/* 0x67 in bignum */ "COERCE-FIXNUM-TO-BIGNUM",
-/* 0x68 in bignum */ "COERCE-BIGNUM-TO-FIXNUM",
-/* 0x69 in flonum */ "PLUS-FLONUM",
-/* 0x6A in flonum */ "MINUS-FLONUM",
-/* 0x6B in flonum */ "MULTIPLY-FLONUM",
-/* 0x6C in flonum */ "DIVIDE-FLONUM",
-/* 0x6D in flonum */ "EQUAL-FLONUM?",
-/* 0x6E in flonum */ "LESS-THAN-FLONUM?",
-/* 0x6F in bignum */ "ZERO-BIGNUM?",
-/* 0x70 in flonum */ "TRUNCATE-FLONUM",
-/* 0x71 in flonum */ "ROUND-FLONUM",
-/* 0x72 in flonum */ "COERCE-INTEGER-TO-FLONUM",
-/* 0x73 in flonum */ "SINE-FLONUM",
-/* 0x74 in flonum */ "COSINE-FLONUM",
-/* 0x75 in flonum */ "ARCTAN-FLONUM",
-/* 0x76 in flonum */ "EXP-FLONUM",
-/* 0x77 in flonum */ "LN-FLONUM",
-
-/* Primitive names continue on the next page */
-\f
-/* Primitive names, continued */
-
-/* 0x78 in flonum */ "SQRT-FLONUM",
-/* 0x79 in nihil */ "PRIMITIVE-FASLOAD",
-/* 0x7A in hooks */ "GET-FIXED-OBJECTS-VECTOR",
-/* 0x7B in hooks */ "SET-FIXED-OBJECTS-VECTOR!",
-/* 0x7C in vector */ "LIST->VECTOR",
-/* 0x7D in vector */ "SUBVECTOR->LIST",
-/* 0x7E in list */ "PAIR?",
-/* 0x7F in fixnum */ "NEGATIVE-FIXNUM?",
-/* 0x80 in bignum */ "NEGATIVE-BIGNUM?",
-/* 0x81 in fixnum */ "GREATER-THAN-FIXNUM?",
-/* 0x82 in bignum */ "GREATER-THAN-BIGNUM?",
-/* 0x83 in string */ "STRING-HASH",
-/* 0x84 in list */ "SYSTEM-PAIR-CONS",
-/* 0x85 in list */ "SYSTEM-PAIR?",
-/* 0x86 in list */ "SYSTEM-PAIR-CAR",
-/* 0x87 in list */ "SYSTEM-PAIR-CDR",
-/* 0x88 in list */ "SYSTEM-PAIR-SET-CAR!",
-/* 0x89 in list */ "SYSTEM-PAIR-SET-CDR!",
-/* 0x8A not here */ No_Name,
-/* 0x8B not here */ No_Name,
-/* 0x8C in prim */ "SET-CELL-CONTENTS!",
-/* 0x8D in prim */ "&MAKE-OBJECT",
-/* 0x8E in hunk */ "SYSTEM-HUNK3-CXR0",
-/* 0x8F in hunk */ "SYSTEM-HUNK3-SET-CXR0!",
-/* 0x90 in random */ "MAP-MACHINE-ADDRESS-TO-CODE",
-/* 0x91 in hunk */ "SYSTEM-HUNK3-CXR1",
-/* 0x92 in hunk */ "SYSTEM-HUNK3-SET-CXR1!",
-/* 0x93 in random */ "MAP-CODE-TO-MACHINE-ADDRESS",
-/* 0x94 in hunk */ "SYSTEM-HUNK3-CXR2",
-/* 0x95 in hunk */ "SYSTEM-HUNK3-SET-CXR2!",
-/* 0x96 in random */ "PRIMITIVE-PROCEDURE-ARITY",
-/* 0x97 in vector */ "SYSTEM-LIST-TO-VECTOR",
-/* 0x98 in vector */ "SYSTEM-SUBVECTOR-TO-LIST",
-/* 0x99 in vector */ "SYSTEM-VECTOR?",
-/* 0x9A in vector */ "SYSTEM-VECTOR-REF",
-/* 0x9B in vector */ "SYSTEM-VECTOR-SET!",
-/* 0x9C in hooks */ "WITH-HISTORY-DISABLED",
-
-/* Primitive names continue on the next page */
-\f
-/* Primitive names, continued */
-
-/* 0x9D not here */ No_Name,
-/* 0x9E not here */ No_Name,
-/* 0x9F not here */ No_Name,
-/* 0xA0 not here */ No_Name,
-/* 0xA1 not here */ No_Name,
-/* 0xA2 not here */ No_Name,
-/* 0xA3 in string */ "VECTOR-8B-CONS",
-/* 0xA4 in string */ "VECTOR-8B?",
-/* 0xA5 in string */ "VECTOR-8B-REF",
-/* 0xA6 in string */ "VECTOR-8B-SET!",
-/* 0xA7 in flonum */ "ZERO-FLONUM?",
-/* 0xA8 in flonum */ "POSITIVE-FLONUM?",
-/* 0xA9 in flonum */ "NEGATIVE-FLONUM?",
-/* 0xAA in flonum */ "GREATER-THAN-FLONUM?",
-/* 0xAB in fasload */ "INTERN-CHARACTER-LIST",
-/* 0xAC not here */ No_Name,
-/* 0xAD in string */ "STRING-LENGTH",
-/* 0xAE in vector */ "SYSTEMTEM-VECTOR-SIZE",
-/* 0xAF in hooks */ "FORCE",
-/* 0xB0 in prim */ "PRIMITIVE-DATUM",
-/* 0xB1 in prim */ "MAKE-NON-POINTER-OBJECT",
-/* 0xB2 in debug */ "DEBUGGING-PRINTER",
-/* 0xB3 in string */ "STRING-UPCASE",
-/* 0xB4 in purify */ "PRIMITIVE-PURIFY",
-/* 0xB5 not here */ No_Name,
-/* 0xB6 in nihil */ "COMPLETE-GARBAGE-COLLECT",
-/* 0xB7 in fasdump */ "DUMP-BAND",
-/* 0xB8 in string */ "SUBSTRING-SEARCH",
-/* 0xB9 in fasload */ "LOAD-BAND",
-/* 0xBA in purutl */ "CONSTANT?",
-/* 0xBB in purutl */ "PURE?",
-/* 0xBC in prim */ "PRIMITIVE-GC-TYPE",
-/* 0xBD in purutl */ "IMPURIFY",
-/* 0xBE in hooks */ "WITH-THREADED-CONTINUATION",
-/* 0xBF in hooks */ "WITHIN-CONTROL-POINT",
-/* 0xC0 in sysprim */ "SET-RUN-LIGHT!",
-/* 0xC1 in fileio */ "FILE-EOF?",
-/* 0xC2 in fileio */ "FILE-READ-CHAR",
-/* 0xC3 in fileio */ "FILE-FILL-INPUT-BUFFER",
-/* 0xC4 in fileio */ "FILE-LENGTH",
-/* 0xC5 in fileio */ "FILE-WRITE-CHAR",
-/* 0xC6 in fileio */ "FILE-WRITE-STRING",
-
-/* Primitive names continue on the next page */
-\f
-/* Primitive names, continued */
-
-/* 0xC7 in daemon */ "CLOSE-LOST-OPEN-FILES",
-/* 0xC8 not here */ No_Name,
-/* 0xC9 in hooks */ "WITH-INTERRUPTS-REDUCED",
-/* 0xCA in step */ "PRIMITIVE-EVAL-STEP",
-/* 0xCB in step */ "PRIMITIVE-APPLY-STEP",
-/* 0xCC in step */ "PRIMITIVE-RETURN-STEP",
-/* 0xCD in ttyio */ "TTY-READ-CHAR-READY?",
-/* 0xCE in ttyio */ "TTY-READ-CHAR",
-/* 0xCF in ttyio */ "TTY-READ-CHAR-IMMEDIATE",
-/* 0xD0 in ttyio */ "TTY-READ-FINISH",
-/* 0xD1 in bitstr */ "BIT-STRING-ALLOCATE",
-/* 0xD2 in bitstr */ "MAKE-BIT-STRING",
-/* 0xD3 in bitstr */ "BIT-STRING?",
-/* 0xD4 in bitstr */ "BIT-STRING-LENGTH",
-/* 0xD5 in bitstr */ "BIT-STRING-REF",
-/* 0xD6 in bitstr */ "BIT-SUBSTRING-MOVE-RIGHT!",
-/* 0xD7 in bitstr */ "BIT-STRING-SET!",
-/* 0xD8 in bitstr */ "BIT-STRING-CLEAR!",
-/* 0xD9 in bitstr */ "BIT-STRING-ZERO?",
-/* 0xDA not here */ No_Name,
-/* 0xDB not here */ No_Name,
-/* 0xDC in bitstr */ "UNSIGNED-INTEGER->BIT-STRING",
-/* 0xDD in bitstr */ "BIT-STRING->UNSIGNED-INTEGER",
-/* 0xDE not here */ No_Name,
-/* 0xDF in bitstr */ "READ-BITS!",
-/* 0xE0 in bitstr */ "WRITE-BITS!",
-/* 0xE1 in hooks */ "MAKE-STATE-SPACE",
-/* 0xE2 in hooks */ "EXECUTE-AT-NEW-POINT",
-/* 0xE3 in hooks */ "TRANSLATE-TO-POINT",
-/* 0xE4 in purutl */ "GET-NEXT-CONSTANT",
-
-/* Primitive names continue on the next page */
-\f
-/* Primitive names, continued */
-
-/* 0xE5 in boot */ "MICROCODE-IDENTIFY",
-/* 0xE6 in generic */ "ZERO?",
-/* 0xE7 in generic */ "POSITIVE?",
-/* 0xE8 in generic */ "NEGATIVE?",
-/* 0xE9 in generic */ "&=",
-/* 0xEA in generic */ "&<",
-/* 0xEB in generic */ "&>",
-/* 0xEC in generic */ "&+",
-/* 0xED in generic */ "&-",
-/* 0xEE in generic */ "&*",
-/* 0xEF in generic */ "&/",
-/* 0xF0 in generic */ "INTEGER-DIVIDE",
-/* 0xF1 in generic */ "1+",
-/* 0xF2 in generic */ "-1+",
-/* 0xF3 in generic */ "TRUNCATE",
-/* 0xF4 in generic */ "ROUND",
-/* 0xF5 in generic */ "FLOOR",
-/* 0xF6 in generic */ "CEILING",
-/* 0xF7 in generic */ "SQRT",
-/* 0xF8 in generic */ "EXP",
-/* 0xF9 in generic */ "LOG",
-/* 0xFA in generic */ "SIN",
-/* 0xFB in generic */ "COS",
-/* 0xFC in generic */ "&ATAN",
-/* 0xFD in ttyio */ "TTY-WRITE-CHAR",
-/* 0xFE in ttyio */ "TTY-WRITE-STRING",
-/* 0xFF in ttyio */ "TTY-BEEP",
-/* 0x100 in ttyio */ "TTY-CLEAR",
-/* 0x101 in extern */ "GET-EXTERNAL-COUNTS",
-/* 0x102 in extern */ "GET-EXTERNAL-NAME",
-/* 0x103 in extern */ "GET-EXTERNAL-NUMBER",
-/* 0x104 not here */ No_Name,
-/* 0x105 not here */ No_Name,
-/* 0x106 in sysprim */ "GET-NEXT-INTERRUPT-CHARACTER",
-/* 0x107 in sysprim */ "CHECK-AND-CLEAN-UP-INPUT-CHANNEL",
-/* 0x108 not here */ No_Name,
-/* 0x109 in sysprim */ "SYSTEM-CLOCK",
-/* 0x10A in fileio */ "FILE-EXISTS?",
-/* 0x10B not here */ No_Name,
-/* 0x10C in ttyio */ "TTY-MOVE-CURSOR",
-/* 0x10D not here */ No_Name,
-/* 0x10E in nihil */ "CURRENT-DATE",
-/* 0x10F in nihil */ "CURRENT-TIME",
-/* 0x110 in nihil */ "TRANSLATE-FILE",
-/* 0x111 in fileio */ "COPY-FILE",
-/* 0x112 in fileio */ "RENAME-FILE",
-/* 0x113 in fileio */ "REMOVE-FILE",
-/* 0x114 in fileio */ "LINK-FILE",
-/* 0x115 in fileio */ "MAKE-DIRECTORY",
-/* 0x116 in nihil */ "VOLUME-NAME",
-/* 0x117 in fileio */ "SET-WORKING-DIRECTORY-PATHNAME!",
-/* 0x118 in nihil */ "OPEN-CATALOG",
-/* 0x119 in nihil */ "CLOSE-CATALOG",
-/* 0x11A in nihil */ "NEXT-FILE",
-/* 0x11B in nihil */ "CAT-NAME",
-/* 0x11C in nihil */ "CAT-KIND",
-/* 0x11D in nihil */ "CAT-PSIZE",
-/* 0x11E in nihil */ "CAT-LSIZE",
-/* 0x11F in nihil */ "CAT-INFO",
-/* 0x120 in nihil */ "CAT-BLOCK",
-/* 0x121 in nihil */ "CAT-CREATE-DATE",
-/* 0x122 in nihil */ "CAT-CREATE-TIME",
-/* 0x123 in nihil */ "CAT-LAST-DATE",
-/* 0x124 in nihil */ "CAT-LAST-TIME",
-/* 0x125 in nihil */ "ERROR-MESSAGE",
-/* 0x126 in sysprim */ "CURRENT-YEAR",
-/* 0x127 in sysprim */ "CURRENT-MONTH",
-/* 0x128 in sysprim */ "CURRENT-DAY",
-/* 0x129 in sysprim */ "CURRENT-HOUR",
-/* 0x12A in sysprim */ "CURRENT-MINUTE",
-/* 0x12B in sysprim */ "CURRENT-SECOND",
-/* 0x12C in nihil */ "INIT-FLOPPY",
-/* 0x12D in nihil */ "ZERO-FLOPPY",
-/* 0x12E in nihil */ "PACK-VOLUME",
-/* 0x12F in nihil */ "LOAD-PICTURE",
-/* 0x130 in nihil */ "STORE-PICTURE",
-/* 0x131 in nihil */ "LOOKUP-SYSTEM-SYMBOL",
-
-/* Unix specialized primitives start here */
-
-/* 0x132 not here */ No_Name,
-/* 0x133 not here */ No_Name,
-/* 0x134 in ttyio */ "CLEAR-TO-END-OF-LINE",
-/* 0x135 not here */ No_Name,
-/* 0x136 not here */ No_Name,
-/* 0x137 in hooks */ "WITH-INTERRUPT-MASK",
-
-/* 0x138 in stringprim */ "STRING?",
-/* 0x139 in stringprim */ "STRING-LENGTH",
-/* 0x13A in stringprim */ "STRING-REF",
-/* 0x13B in stringprim */ "STRING-SET!",
-/* 0x13C in stringprim */ "SUBSTRING-MOVE-RIGHT!",
-/* 0x13D in stringprim */ "SUBSTRING-MOVE-LEFT!",
-/* 0x13E in stringprim */ "STRING-ALLOCATE",
-/* 0x13F in stringprim */ "STRING-MAXIMUM-LENGTH",
-/* 0x140 in stringprim */ "SET-STRING-LENGTH!",
-/* 0x141 in stringprim */ "VECTOR-8B-FILL!",
-/* 0x142 in stringprim */ "VECTOR-8B-FIND-NEXT-CHAR",
-/* 0x143 in stringprim */ "VECTOR-8B-FIND-PREVIOUS-CHAR",
-/* 0x144 in stringprim */ "VECTOR-8B-FIND-NEXT-CHAR-CI",
-/* 0x145 in stringprim */ "VECTOR-8B-FIND-PREVIOUS-CHAR-CI",
-/* 0x146 in stringprim */ "SUBSTRING-FIND-NEXT-CHAR-IN-SET",
-/* 0x147 in stringprim */ "SUBSTRING-FIND-PREVIOUS-CHAR-IN-SET",
-/* 0x148 in stringprim */ "SUBSTRING=?",
-/* 0x149 in stringprim */ "SUBSTRING-CI=?",
-/* 0x14A in stringprim */ "SUBSTRING<?",
-/* 0x14B in stringprim */ "SUBSTRING-UPCASE!",
-/* 0x14C in stringprim */ "SUBSTRING-DOWNCASE!",
-/* 0x14D in stringprim */ "SUBSTRING-MATCH-FORWARD",
-/* 0x14E in stringprim */ "SUBSTRING-MATCH-BACKWARD",
-/* 0x14F in stringprim */ "SUBSTRING-MATCH-FORWARD-CI",
-/* 0x150 in stringprim */ "SUBSTRING-MATCH-BACKWARD-CI",
-/* 0x151 in fileio */ "PHOTO-OPEN",
-/* 0x152 in fileio */ "PHOTO-CLOSE",
-/* 0x153 in sysprim */ "SETUP-TIMER-INTERRUPT",
-/* 0x154 in nihil */ No_Name,
-/* 0x155 in nihil */ No_Name,
-/* 0x156 in nihil */ No_Name,
-/* 0x157 in nihil */ No_Name,
-/* 0x158 in nihil */ No_Name,
-/* 0x159 in nihil */ No_Name,
-/* 0x15A in nihil */ No_Name,
-/* 0x15B in nihil */ No_Name,
-/* 0x15C in nihil */ No_Name,
-/* 0x15D in nihil */ No_Name,
-/* 0x15E in nihil */ No_Name,
-/* 0x15F in nihil */ No_Name,
-/* 0x160 in nihil */ No_Name,
-/* 0x161 in nihil */ "EXTRACT-NON-MARKED-VECTOR",
-/* 0x162 in nihil */ "UNSNAP-LINKS!",
-/* 0x163 in nihil */ "SAFE-PRIMITIVE?",
-/* 0x164 in nihil */ "SUBSTRING-READ",
-/* 0x165 in nihil */ "SUBSTRING-WRITE",
-/* 0x166 in ttyio */ "SCREEN-X-SIZE",
-/* 0x167 in ttyio */ "SCREEN-Y-SIZE",
-/* 0x168 in nihil */ "SCREEN-WRITE-CURSOR",
-/* 0x169 in nihil */ "SCREEN-WRITE-CHARACTER",
-/* 0x16A in nihil */ "SCREEN-WRITE-SUBSTRING",
-/* 0x16B in nihil */ "NEXT-FILE-MATCHING",
-/* 0x16C in nihil */ No_Name,
-/* 0x16D in nihil */ "TTY-WRITE-BYTE",
-/* 0x16E in nihil */ "FILE-READ-BYTE",
-/* 0x16F in nihil */ "FILE-WRITE-BYTE",
-/* 0x170 not here */ No_Name, /* "SAVE-SCREEN", */
-/* 0x171 not here */ No_Name, /* "RESTORE-SCREEN!", */
-/* 0x172 not here */ No_Name, /* "SUBSCREEN-CLEAR!", */
-/* 0x173 not here */ No_Name, /* "&GCD", */
-/* 0x174 not here */ No_Name, /* "TTY-REDRAW-SCREEN", */
-/* 0x175 not here */ No_Name, /* "SCREEN-INVERSE-VIDEO", */
-/* 0x176 in nihil */ "STRING->SYNTAX-ENTRY",
-/* 0x177 in scanprim */ "SCAN-WORD-FORWARD",
-/* 0x178 in scanprim */ "SCAN-WORD-BACKWARD",
-/* 0x179 in scanprim */ "SCAN-LIST-FORWARD",
-/* 0x17A in scanprim */ "SCAN-LIST-BACKWARD",
-/* 0x17B in scanprim */ "SCAN-SEXPS-FORWARD",
-/* 0x17C in scanprim */ "SCAN-FORWARD-TO-WORD",
-/* 0x17D in scanprim */ "SCAN-BACKWARD-PREFIX-CHARS",
-/* 0x17E in scanprim */ "CHAR->SYNTAX-CODE",
-/* 0x17F in scanprim */ "QUOTED-CHAR?",
-/* 0x180 in boot */ "MICROCODE-TABLES-FILENAME",
-/* 0x181 not here */ No_Name,
-/* 0x182 not here */ No_Name, /* "FIND-PASCAL-PROGRAM", */
-/* 0x183 not here */ No_Name, /* "EXECUTE-PASCAL-PROGRAM", */
-/* 0x184 not here */ No_Name, /* "GRAPHICS-MOVE", */
-/* 0x185 not here */ No_Name, /* "GRAPHICS-LINE", */
-/* 0x186 not here */ No_Name, /* "GRAPHICS-PIXEL", */
-/* 0x187 not here */ No_Name, /* "GRAPHICS-SET-DRAWING-MODE", */
-/* 0x188 not here */ No_Name, /* "ALPHA-RASTER?", */
-/* 0x189 not here */ No_Name, /* "TOGGLE-ALPHA-RASTER", */
-/* 0x18A not here */ No_Name, /* "GRAPHICS-RASTER?", */
-/* 0x18B not here */ No_Name, /* "TOGGLE-GRAPHICS-RASTER", */
-/* 0x18C not here */ No_Name, /* "GRAPHICS-CLEAR", */
-/* 0x18D not here */ No_Name, /* "GRAPHICS-SET-LINE-STYLE", */
-/* 0x18E in hooks */ "ERROR-PROCEDURE",
-/* 0x18F in nihil */ "VOLUME-EXISTS?",
-/* 0x190 in nihil */ "RE-CHAR-SET-ADJOIN!",
-/* 0x191 in nihil */ "RE-COMPILE-FASTMAP",
-/* 0x192 in nihil */ "RE-MATCH",
-/* 0x193 in nihil */ "RE-SEARCH-FORWARD",
-/* 0x194 in nihil */ "RE-SEARCH-BACKWARD",
-/* 0x195 in prim */ "SYSTEM-MEMORY-REF",
-/* 0x196 in prim */ "SYSTEM-MEMORY-SET!",
-/* 0x197 in bitstr */ "BIT-STRING-FILL!",
-/* 0x198 in bitstr */ "BIT-STRING-MOVE!",
-/* 0x199 in bitstr */ "BIT-STRING-MOVEC!",
-/* 0x19A in bitstr */ "BIT-STRING-OR!",
-/* 0x19B in bitstr */ "BIT-STRING-AND!",
-/* 0x19C in bitstr */ "BIT-STRING-ANDC!",
-/* 0x19D in bitstr */ "BIT-STRING=?",
-/* 0x19E in fileio */ "WORKING-DIRECTORY-PATHNAME",
-/* 0x19F in fileio */ "OPEN-DIRECTORY",
-/* 0x1A0 in fileio */ "DIRECTORY-READ",
-/* 0x1A1 in sysprim */ "UNDER-EMACS?",
-/* 0x1A2 in ttyio */ "TTY-FLUSH-OUTPUT",
-/* 0x1A3 in fasload */ "RELOAD-BAND-NAME"
-};
-
-#if (MAX_PRIMITIVE_NUMBER != 0x1A3)
-/* Cause an error */
-#include "Error: prims.h and storage.c are inconsistent -- Names Table"
-#endif
-
-/* After passing all above checks */
-
-long MAX_PRIMITIVE = MAX_PRIMITIVE_NUMBER;
-\f
char *Return_Names[] = {
/* 0x00 */ "END_OF_COMPUTATION",
/* 0x01 */ "JOIN_STACKLETS",
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/string.c,v 9.22 1987/04/08 12:25:57 jinx Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/string.c,v 9.23 1987/04/16 02:30:34 jinx Exp $ */
/* String primitives. */
/* Currently the strings used in symbols have type codes in the length
field. They should be changed to have just longwords there. */
-Built_In_Primitive (Prim_String_Allocate, 1, "STRING-ALLOCATE")
+Built_In_Primitive (Prim_String_Allocate, 1, "STRING-ALLOCATE", 0x13E)
{
long length, count;
Pointer result;
Primitive_1_Arg ();
- length = (guarantee_nonnegative_integer_arg_1 (Arg1));
+ length = (guarantee_nonnegative_int_arg_1 (Arg1));
/* Add 1 to length to account for '\0' at end of string.
Add 2 to count to account for string header words. */
count =
return (result);
}
-Built_In_Primitive (Prim_String_P, 1, "STRING?")
+Built_In_Primitive (Prim_String_P, 1, "STRING?", 0x138)
{
Primitive_1_Arg ();
return ((string_p (Arg1)) ? TRUTH : NIL);
}
\f
-Built_In_Primitive (Prim_String_Length, 1, "STRING-LENGTH")
+Built_In_Primitive (Prim_String_Length, 1, "STRING-LENGTH", 0x139)
{
Primitive_1_Arg ();
return (Make_Unsigned_Fixnum (string_length (Arg1)));
}
-Built_In_Primitive (Prim_String_Maximum_Length, 1, "STRING-MAXIMUM-LENGTH")
+Built_In_Primitive (Prim_String_Maximum_Length, 1,
+ "STRING-MAXIMUM-LENGTH", 0x13F)
{
Primitive_1_Arg ();
return (Make_Unsigned_Fixnum ((maximum_string_length (Arg1)) - 1));
}
-Built_In_Primitive (Prim_Set_String_Length, 2, "SET-STRING-LENGTH!")
+Built_In_Primitive (Prim_Set_String_Length, 2, "SET-STRING-LENGTH!", 0x140)
{
long length, result;
Primitive_2_Args ();
guarantee_string_arg_1 ();
- length = (guarantee_nonnegative_integer_arg_2 (Arg2));
+ length = (guarantee_nonnegative_int_arg_2 (Arg2));
if (length > (maximum_string_length (Arg1)))
error_bad_range_arg_2 ();
return (process_result (string_ref (Arg1, index))); \
}
-Built_In_Primitive (Prim_String_Ref, 2, "STRING-REF")
+Built_In_Primitive (Prim_String_Ref, 2, "STRING-REF", 0x13A)
string_ref_body (c_char_to_scheme_char)
-Built_In_Primitive (Prim_Vector_8b_Ref, 2, "VECTOR-8B-REF")
+Built_In_Primitive (Prim_Vec_8b_Ref, 2, "VECTOR-8B-REF", 0xA5)
string_ref_body (Make_Unsigned_Fixnum)
#define string_set_body(get_ascii, process_result) \
return (process_result (result)); \
}
-Built_In_Primitive (Prim_String_Set, 3, "STRING-SET!")
- string_set_body (guarantee_ascii_character_arg_3, c_char_to_scheme_char)
+Built_In_Primitive (Prim_String_Set, 3, "STRING-SET!", 0x13B)
+ string_set_body (guarantee_ascii_char_arg_3, c_char_to_scheme_char)
-Built_In_Primitive (Prim_Vector_8b_Set, 3, "VECTOR-8B-SET!")
+Built_In_Primitive (Prim_Vec_8b_Set, 3, "VECTOR-8B-SET!", 0xA6)
string_set_body (guarantee_ascii_integer_arg_3, Make_Unsigned_Fixnum)
\f
#define substring_move_prefix() \
Primitive_5_Args (); \
\
guarantee_string_arg_1 (); \
- start1 = (guarantee_nonnegative_integer_arg_2 (Arg2)); \
- end1 = (guarantee_nonnegative_integer_arg_3 (Arg3)); \
+ start1 = (guarantee_nonnegative_int_arg_2 (Arg2)); \
+ end1 = (guarantee_nonnegative_int_arg_3 (Arg3)); \
guarantee_string_arg_4 (); \
- start2 = (guarantee_nonnegative_integer_arg_5 (Arg5)); \
+ start2 = (guarantee_nonnegative_int_arg_5 (Arg5)); \
\
if (end1 > (string_length (Arg1))) \
error_bad_range_arg_2 (); \
if (end2 > (string_length (Arg4))) \
error_bad_range_arg_3 ();
-Built_In_Primitive (Prim_Substring_Move_Right, 5, "SUBSTRING-MOVE-RIGHT!")
+Built_In_Primitive (Prim_Substring_Move_Right, 5,
+ "SUBSTRING-MOVE-RIGHT!", 0x13C)
{
substring_move_prefix()
return (NIL);
}
-Built_In_Primitive (Prim_Substring_Move_Left, 5, "SUBSTRING-MOVE-LEFT!")
+Built_In_Primitive (Prim_Substring_Move_Left, 5,
+ "SUBSTRING-MOVE-LEFT!", 0x13D)
{
substring_move_prefix()
Primitive_4_Args (); \
\
guarantee_string_arg_1 (); \
- start = (guarantee_nonnegative_integer_arg_2 (Arg2)); \
- end = (guarantee_nonnegative_integer_arg_3 (Arg3)); \
+ start = (guarantee_nonnegative_int_arg_2 (Arg2)); \
+ end = (guarantee_nonnegative_int_arg_3 (Arg3)); \
ascii = (guarantee_ascii_integer_arg_4 (Arg4)); \
\
if (end > (string_length (Arg1))) \
if (start > end) \
error_bad_range_arg_2 ();
-Built_In_Primitive (Prim_Vector_8b_Fill, 4, "VECTOR-8B-FILL!")
+Built_In_Primitive (Prim_Vec_8b_Fill, 4, "VECTOR-8B-FILL!", 0x141)
{
vector_8b_substring_prefix ();
return (NIL);
}
-Built_In_Primitive (Prim_Vector_8b_Find_Next_Char, 4,
- "VECTOR-8B-FIND-NEXT-CHAR")
+Built_In_Primitive (Prim_Vec_8b_Find_Next_Char, 4,
+ "VECTOR-8B-FIND-NEXT-CHAR", 0x142)
{
vector_8b_substring_prefix ();
return (NIL);
}
\f
-Built_In_Primitive (Prim_Vector_8b_Find_Previous_Char, 4,
- "VECTOR-8B-FIND-PREVIOUS-CHAR")
+Built_In_Primitive (Prim_Vec_8b_Find_Prev_Char, 4,
+ "VECTOR-8B-FIND-PREVIOUS-CHAR", 0x143)
{
vector_8b_substring_prefix ();
return (NIL);
}
-Built_In_Primitive(Prim_Vector_8b_Find_Next_Char_Ci, 4,
- "VECTOR-8B-FIND-NEXT-CHAR-CI")
+Built_In_Primitive(Prim_Vec_8b_Find_Next_Char_Ci, 4,
+ "VECTOR-8B-FIND-NEXT-CHAR-CI", 0x144)
{
char char1;
vector_8b_substring_prefix ();
return (NIL);
}
-Built_In_Primitive(Prim_Vector_8b_Find_Previous_Char_Ci, 4,
- "VECTOR-8B-FIND-PREVIOUS-CHAR-CI")
+Built_In_Primitive(Prim_Vec_8b_Find_Prev_Char_Ci, 4,
+ "VECTOR-8B-FIND-PREVIOUS-CHAR-CI", 0x145)
{
char char1;
vector_8b_substring_prefix ();
Primitive_4_Args (); \
\
guarantee_string_arg_1 (); \
- start = (guarantee_nonnegative_integer_arg_2 (Arg2)); \
- end = (guarantee_nonnegative_integer_arg_3 (Arg3)); \
+ start = (guarantee_nonnegative_int_arg_2 (Arg2)); \
+ end = (guarantee_nonnegative_int_arg_3 (Arg3)); \
guarantee_string_arg_4 (); \
\
if (end > (string_length (Arg1))) \
if ((string_length (Arg4)) != MAX_ASCII) \
error_bad_range_arg_4 ();
-Built_In_Primitive(Prim_Substring_Find_Next_Char_In_Set, 4,
- "SUBSTRING-FIND-NEXT-CHAR-IN-SET")
+Built_In_Primitive(Prim_Find_Next_Char_In_Set, 4,
+ "SUBSTRING-FIND-NEXT-CHAR-IN-SET", 0x146)
{
substring_find_char_in_set_prefix ();
return (NIL);
}
-Built_In_Primitive(Prim_Substring_Find_Previous_Char_In_Set, 4,
- "SUBSTRING-FIND-PREVIOUS-CHAR-IN-SET")
+Built_In_Primitive(Prim_Find_Prev_Char_In_Set, 4,
+ "SUBSTRING-FIND-PREVIOUS-CHAR-IN-SET", 0x147)
{
substring_find_char_in_set_prefix ();
Primitive_6_Args (); \
\
guarantee_string_arg_1 (); \
- start1 = (guarantee_nonnegative_integer_arg_2 (Arg2)); \
- end1 = (guarantee_nonnegative_integer_arg_3 (Arg3)); \
+ start1 = (guarantee_nonnegative_int_arg_2 (Arg2)); \
+ end1 = (guarantee_nonnegative_int_arg_3 (Arg3)); \
guarantee_string_arg_4 (); \
- start2 = (guarantee_nonnegative_integer_arg_5 (Arg5)); \
- end2 = (guarantee_nonnegative_integer_arg_6 (Arg6)); \
+ start2 = (guarantee_nonnegative_int_arg_5 (Arg5)); \
+ end2 = (guarantee_nonnegative_int_arg_6 (Arg6)); \
\
if (end1 > (string_length (Arg1))) \
error_bad_range_arg_3 (); \
if (length != (end2 - start2)) \
return (NIL);
-Built_In_Primitive (Prim_Substring_Equal, 6, "SUBSTRING=?")
+Built_In_Primitive(Prim_Substring_Equal, 6, "SUBSTRING=?", 0x148)
{
substring_equal_prefix ();
return (TRUTH);
}
-Built_In_Primitive(Prim_Substring_Ci_Equal, 6, "SUBSTRING-CI=?")
+Built_In_Primitive(Prim_Substring_Ci_Equal, 6, "SUBSTRING-CI=?", 0x149)
{
substring_equal_prefix ();
return (TRUTH);
}
\f
-Built_In_Primitive (Prim_Substring_Less, 6, "SUBSTRING<?")
+Built_In_Primitive (Prim_Substring_Less, 6, "SUBSTRING<?", 0x14A)
{
long length, length1, length2;
substring_compare_prefix (start1, start2);
Primitive_3_Args (); \
\
guarantee_string_arg_1 (); \
- start = (guarantee_nonnegative_integer_arg_2 (Arg2)); \
- end = (guarantee_nonnegative_integer_arg_3 (Arg3)); \
+ start = (guarantee_nonnegative_int_arg_2 (Arg2)); \
+ end = (guarantee_nonnegative_int_arg_3 (Arg3)); \
\
if (end > (string_length (Arg1))) \
error_bad_range_arg_3 (); \
length = (end - start); \
scan = (string_pointer (Arg1, start));
-Built_In_Primitive(Prim_Substring_Upcase, 3, "SUBSTRING-UPCASE!")
+Built_In_Primitive(Prim_Substring_Upcase, 3, "SUBSTRING-UPCASE!", 0x14B)
{
substring_modification_prefix ();
return (NIL);
}
-Built_In_Primitive(Prim_Substring_Downcase, 3, "SUBSTRING-DOWNCASE!")
+Built_In_Primitive(Prim_Substring_Downcase, 3, "SUBSTRING-DOWNCASE!", 0x14C)
{
substring_modification_prefix ();
length = (substring_length_min (start1, end1, start2, end2)); \
unmatched = length;
-Built_In_Primitive (Prim_Substring_Match_Forward, 6, "SUBSTRING-MATCH-FORWARD")
+Built_In_Primitive (Prim_Match_Forward, 6,
+ "SUBSTRING-MATCH-FORWARD", 0x14D)
{
substring_match_prefix (start1, start2);
return (Make_Unsigned_Fixnum (length));
}
-Built_In_Primitive (Prim_Substring_Match_Forward_Ci, 6,
- "SUBSTRING-MATCH-FORWARD-CI")
+Built_In_Primitive (Prim_Match_Forward_Ci, 6,
+ "SUBSTRING-MATCH-FORWARD-CI", 0x14F)
{
substring_match_prefix (start1, start2);
return (Make_Unsigned_Fixnum (length));
}
-Built_In_Primitive (Prim_Substring_Match_Backward, 6,
- "SUBSTRING-MATCH-BACKWARD")
+Built_In_Primitive (Prim_Match_Backward, 6,
+ "SUBSTRING-MATCH-BACKWARD", 0x14E)
{
substring_match_prefix (end1, end2);
return (Make_Unsigned_Fixnum (length));
}
-Built_In_Primitive(Prim_Substring_Match_Backward_Ci, 6,
- "SUBSTRING-MATCH-BACKWARD-CI")
+Built_In_Primitive(Prim_Match_Backward_Ci, 6,
+ "SUBSTRING-MATCH-BACKWARD-CI", 0x150)
{
substring_match_prefix (end1, end2);
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/trap.h,v 9.36 1987/04/06 11:03:21 jinx Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/trap.h,v 9.37 1987/04/16 02:30:49 jinx Exp $ */
\f
/* Kinds of traps:
#define DANGEROUS_OBJECT Make_Unsigned_Fixnum(TRAP_DANGEROUS)
-#if ((TC_REFERENCE_TRAP != 0x32) || (TC_TRUE != 0x08))
-#include "error: lookup.h and types.h are inconsistent"
+#if (TC_REFERENCE_TRAP != 0x32)
+#include "error: trap.h and types.h are inconsistent"
#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/usrdef.h,v 9.35 1987/04/03 00:47:31 jinx Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/usrdef.h,v 9.36 1987/04/16 02:31:57 jinx Rel $ */
/* Macros and header for usrdef.c and variants. */
#include "config.h"
#include "object.h"
+#include "errors.h"
#include "prim.h"
+#include "primitive.h"
-
+extern void
+ Microcode_Termination(),
+ signal_error_from_primitive();
;;;; Machine Dependent Type Tables
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utabmd.scm,v 9.24 1987/04/03 00:22:18 jinx Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utabmd.scm,v 9.25 1987/04/16 02:32:05 jinx Exp $
(declare (usual-integrations))
(CDR FIRST-TAIL) ;$22
(SET-CAR! SET-FIRST!) ;$23
(SET-CDR! SET-FIRST-TAIL!) ;$24
- PRINT-STRING ;$25
+ #F ;$25
TTY-GET-CURSOR ;$26
GENERAL-CAR-CDR ;$27
HUNK3-CONS ;$28
SET-CURRENT-HISTORY! ;$2F
VECTOR-SET! ;$30
NON-MARKED-VECTOR-CONS ;$31
- GET-CHARACTER-FROM-INPUT-CHANNEL ;$32
+ #F ;$32
LEXICAL-UNBOUND? ;$33
INTEGER->CHAR ;$34
CHAR-DOWNCASE ;$35
SYSTEM-PAIR-SET-CAR! ;$88
SYSTEM-PAIR-SET-CDR! ;$89
#F ;$8A
- GET-CHARACTER-FROM-INPUT-CHANNEL-IMMEDIATE ;$8B
+ #F ;$8B
SET-CELL-CONTENTS! ;$8C
&MAKE-OBJECT ;$8D
SYSTEM-HUNK3-CXR0 ;$8E
GREATER-THAN-FLONUM? ;$AA
INTERN-CHARACTER-LIST ;$AB
#F ;$AC
- (STRING-LENGTH STRING-SIZE VECTOR-8B-SIZE) ;$AD
+ (STRING-SIZE VECTOR-8B-SIZE) ;$AD
SYSTEM-VECTOR-SIZE ;$AE
FORCE ;$AF
PRIMITIVE-DATUM ;$B0
FILE-WRITE-CHAR ;$C5
FILE-WRITE-STRING ;$C6
CLOSE-LOST-OPEN-FILES ;$C7
- PUT-CHARACTER-TO-OUTPUT-CHANNEL ;$C8
+ #F ;$C8
WITH-INTERRUPTS-REDUCED ;$C9
PRIMITIVE-EVAL-STEP ;$CA
PRIMITIVE-APPLY-STEP ;$CB
GET-EXTERNAL-COUNTS ;$101
GET-EXTERNAL-NAME ;$102
GET-EXTERNAL-NUMBER ;$103
- OPEN-CHANNEL ;$104
- CLOSE-PHYSICAL-CHANNEL ;$105
+ #F ;$104
+ #F ;$105
GET-NEXT-INTERRUPT-CHARACTER ;$106
CHECK-AND-CLEAN-UP-INPUT-CHANNEL ;$107
#F ;$108
;;; This identification string is saved by the system.
-"$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utabmd.scm,v 9.24 1987/04/03 00:22:18 jinx Exp $"
+"$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utabmd.scm,v 9.25 1987/04/16 02:32:05 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.22 1987/04/03 00:22:38 jinx Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utils.c,v 9.23 1987/04/16 02:32:25 jinx Exp $ */
/* This file contains utilities for interrupts, errors, etc. */
Will_Push(Save_Space);
/* Return from interrupt handler will re-enable interrupts */
Store_Return(RC_RESTORE_INT_MASK);
- Store_Expression(FIXNUM_0 + IntEnb);
+ Store_Expression(Make_Unsigned_Fixnum(IntEnb));
Save_Cont();
if (New_Int_Enb+1 == INT_GC)
{ Store_Return(RC_GC_CHECK);
- Store_Expression(FIXNUM_0 + GC_Space_Needed);
+ Store_Expression(Make_Unsigned_Fixnum(GC_Space_Needed));
Save_Cont();
}
* the currently enabled interrupts.
*/
- Push(FIXNUM_0+IntEnb);
- Push(FIXNUM_0+The_Int_Code);
+ Push(Make_Unsigned_Fixnum(IntEnb));
+ Push(Make_Unsigned_Fixnum(The_Int_Code));
Push(Handler);
Push(STACK_FRAME_HEADER+2);
Pushed();
\f
/* Useful error procedures */
+extern void
+ signal_error_from_primitive(),
+ signal_interrupt_from_primitive(),
+ error_wrong_type_arg_1(),
+ error_wrong_type_arg_2(),
+ error_wrong_type_arg_3(),
+ error_wrong_type_arg_4(),
+ error_wrong_type_arg_5(),
+ error_wrong_type_arg_6(),
+ error_wrong_type_arg_7(),
+ error_wrong_type_arg_8(),
+ error_wrong_type_arg_9(),
+ error_wrong_type_arg_10(),
+ error_bad_range_arg_1(),
+ error_bad_range_arg_2(),
+ error_bad_range_arg_3(),
+ error_bad_range_arg_4(),
+ error_bad_range_arg_5(),
+ error_bad_range_arg_6(),
+ error_bad_range_arg_7(),
+ error_bad_range_arg_8(),
+ error_bad_range_arg_9(),
+ error_bad_range_arg_10(),
+ error_external_return();
+
void
signal_error_from_primitive (error_code)
long error_code;
{
Back_Out_Of_Primitive ();
longjmp (*Back_To_Eval, error_code);
+ /*NOTREACHED*/
}
void
Back_Out_Of_Primitive();
Save_Cont();
Store_Return(RC_RESTORE_INT_MASK);
- Store_Expression(FIXNUM_0+IntEnb);
+ Store_Expression(Make_Unsigned_Fixnum(IntEnb));
IntEnb = (local_mask);
longjmp(*Back_To_Eval, PRIM_INTERRUPT);
/*NOTREACHED*/
return (pointer_datum (argument)); \
}
-define_integer_guarantee (guarantee_nonnegative_integer_arg_1,
+define_integer_guarantee (guarantee_nonnegative_int_arg_1,
error_wrong_type_arg_1,
error_bad_range_arg_1)
-define_integer_guarantee (guarantee_nonnegative_integer_arg_2,
+define_integer_guarantee (guarantee_nonnegative_int_arg_2,
error_wrong_type_arg_2,
error_bad_range_arg_2)
-define_integer_guarantee (guarantee_nonnegative_integer_arg_3,
+define_integer_guarantee (guarantee_nonnegative_int_arg_3,
error_wrong_type_arg_3,
error_bad_range_arg_3)
-define_integer_guarantee (guarantee_nonnegative_integer_arg_4,
+define_integer_guarantee (guarantee_nonnegative_int_arg_4,
error_wrong_type_arg_4,
error_bad_range_arg_4)
-define_integer_guarantee (guarantee_nonnegative_integer_arg_5,
+define_integer_guarantee (guarantee_nonnegative_int_arg_5,
error_wrong_type_arg_5,
error_bad_range_arg_5)
-define_integer_guarantee (guarantee_nonnegative_integer_arg_6,
+define_integer_guarantee (guarantee_nonnegative_int_arg_6,
error_wrong_type_arg_6,
error_bad_range_arg_6)
-define_integer_guarantee (guarantee_nonnegative_integer_arg_7,
+define_integer_guarantee (guarantee_nonnegative_int_arg_7,
error_wrong_type_arg_7,
error_bad_range_arg_7)
-define_integer_guarantee (guarantee_nonnegative_integer_arg_8,
+define_integer_guarantee (guarantee_nonnegative_int_arg_8,
error_wrong_type_arg_8,
error_bad_range_arg_8)
-define_integer_guarantee (guarantee_nonnegative_integer_arg_9,
+define_integer_guarantee (guarantee_nonnegative_int_arg_9,
error_wrong_type_arg_9,
error_bad_range_arg_9)
-define_integer_guarantee (guarantee_nonnegative_integer_arg_10,
+define_integer_guarantee (guarantee_nonnegative_int_arg_10,
error_wrong_type_arg_10,
error_bad_range_arg_10)
\f
Stop_History();
Store_Return(RC_RESTORE_INT_MASK);
- Store_Expression(FIXNUM_0 + IntEnb);
+ Store_Expression(Make_Unsigned_Fixnum(IntEnb));
Save_Cont();
Push(Make_Unsigned_Fixnum(IntEnb)); /* Arg 2: Int. mask */
Push(Make_Unsigned_Fixnum(Err)); /* Arg 1: Err. No */
Will_Push(HISTORY_SIZE);
Save_History(RC_RESTORE_DONT_COPY_HISTORY);
Pushed();
- Previous_Restore_History_Stacklet = NULL;
- Previous_Restore_History_Offset =
- (Get_End_Of_Stacklet() - Stack_Pointer) +
- CONTINUATION_RETURN_CODE;
+ Prev_Restore_History_Stacklet = NULL;
+ Prev_Restore_History_Offset = ((Get_End_Of_Stacklet() - Stack_Pointer) +
+ CONTINUATION_RETURN_CODE);
Store_Expression(Saved_Expression);
Store_Return(Saved_Return_Code);
return;
int NArgs;
if (Primitive_Number > MAX_PRIMITIVE)
+ {
Primitive_Error(ERR_UNDEFINED_PRIMITIVE);
- NArgs = (int) Arg_Count_Table[Primitive_Number];
- if (Primitive_Debug) Print_Primitive(Primitive_Number);
+ }
+ if (Primitive_Debug)
+ {
+ Print_Primitive(Primitive_Number);
+ }
+ NArgs = N_Args_Primitive(Primitive_Number);
Saved_Stack = Stack_Pointer;
- Result = (*(Primitive_Table[Primitive_Number]))();
+ Result = Internal_Apply_Primitive(Primitive_Number);
if (Saved_Stack != Stack_Pointer)
- { Print_Expression(Make_Non_Pointer(TC_PRIMITIVE, Primitive_Number),
+ {
+ Print_Expression(Make_Non_Pointer(TC_PRIMITIVE, Primitive_Number),
"Stack bad after ");
- printf( "\nStack was 0x%x, now 0x%x, #args=%d.\n",
+ fprintf(stderr,
+ "\nStack was 0x%x, now 0x%x, #args=%d.\n",
Saved_Stack, Stack_Pointer, NArgs);
Microcode_Termination(TERM_EXIT);
}
if (Primitive_Debug)
- { Print_Expression(Result, "Primitive Result");
- printf( "\n");
+ {
+ Print_Expression(Result, "Primitive Result");
+ fprintf(stderr, "\n");
}
return Result;
}
#endif
-
-Built_In_Primitive (Prim_Unused, 0, "Unimplemented Primitive Handler")
-{
- printf("Ignoring missing primitive. Expression = 0x%02x|%06x\n",
- Type_Code(Fetch_Expression()), Datum(Fetch_Expression()));
- Primitive_Error(ERR_UNDEFINED_PRIMITIVE);
-}
\f
Pointer
Allocate_Float (F)
Pointer State_Space = Find_State_Space(Target);
Pointer Current_Location, *Path = Free;
fast Pointer Path_Point, *Path_Ptr;
- long Distance =
- Get_Integer(Fast_Vector_Ref(Target, STATE_POINT_DISTANCE_TO_ROOT));
- long Merge_Depth, From_Depth, i;
+ long Distance, Merge_Depth, From_Depth, i;
guarantee_state_point();
- if (State_Space == NIL) Current_Location = Current_State_Point;
- else Current_Location = Vector_Ref(State_Space, STATE_SPACE_NEAREST_POINT);
- if (Target == Current_Location) longjmp(*Back_To_Eval, PRIM_POP_RETURN);
+ Distance =
+ Get_Integer(Fast_Vector_Ref(Target, STATE_POINT_DISTANCE_TO_ROOT));
+ if (State_Space == NIL)
+ Current_Location = Current_State_Point;
+ else
+ Current_Location = Vector_Ref(State_Space, STATE_SPACE_NEAREST_POINT);
+ if (Target == Current_Location)
+ longjmp(*Back_To_Eval, PRIM_POP_RETURN);
for (Path_Ptr=(&(Path[Distance])), Path_Point=Target, i=0;
i <= Distance;
i++, Path_Point=Fast_Vector_Ref(Path_Point, STATE_POINT_NEARER_POINT))
*Path_Ptr-- = Path_Point;
From_Depth =
Get_Integer(Fast_Vector_Ref(Current_Location, STATE_POINT_DISTANCE_TO_ROOT));
- for (Path_Point=Current_Location, Merge_Depth=From_Depth;
- Merge_Depth > Distance; Merge_Depth--)
+ for (Path_Point=Current_Location, Merge_Depth = From_Depth;
+ Merge_Depth > Distance;
+ Merge_Depth--)
Path_Point = Fast_Vector_Ref(Path_Point, STATE_POINT_NEARER_POINT);
for (Path_Ptr=(&(Path[Merge_Depth])); Merge_Depth >= 0;
Merge_Depth--, Path_Ptr--,
Path_Point=Fast_Vector_Ref(Path_Point, STATE_POINT_NEARER_POINT))
- if (*Path_Ptr == Path_Point) break;
+ if (*Path_Ptr == Path_Point)
+ break;
#ifdef ENABLE_DEBUGGING_TOOLS
if (Merge_Depth < 0)
- { printf("\nMerge_Depth went negative: %d\n", Merge_Depth);
+ {
+ fprintf(stderr, "\nMerge_Depth went negative: %d\n", Merge_Depth);
Microcode_Termination(TERM_EXIT);
}
#endif
Will_Push(2*CONTINUATION_SIZE + 4);
Store_Return(RC_RESTORE_INT_MASK);
- Store_Expression(FIXNUM_0 + IntEnb);
+ Store_Expression(Make_Unsigned_Fixnum(IntEnb));
Save_Cont();
- Push(FIXNUM_0+(Distance-Merge_Depth));
+ Push(Make_Unsigned_Fixnum((Distance-Merge_Depth)));
Push(Target);
- Push(FIXNUM_0+(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);
Pushed();
IntEnb &= (INT_GC<<1) - 1; /* Disable lower than GC level */
longjmp(*Back_To_Eval, 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.21 1987/01/22 14:35:52 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/vector.c,v 9.22 1987/04/16 02:32:44 jinx Exp $
*
* This file contains procedures for handling vectors and conversion
* back and forth to lists.
return Make_Pointer(Result_Type, Orig_Free);
}
-/* (LIST_TO_VECTOR LIST)
- [Primitive number 0x7C]
- Returns a vector made from the items in LIST.
+/* (LIST->VECTOR LIST)
+ Returns a vector made from the items in LIST.
*/
-Built_In_Primitive(Prim_List_To_Vector, 1, "LIST->VECTOR")
-{ Primitive_1_Arg();
+Built_In_Primitive(Prim_List_To_Vector, 1, "LIST->VECTOR", 0x7C)
+{
+ Primitive_1_Arg();
+
return L_To_V(TC_VECTOR, Arg1);
}
\f
-/* (SUBVECTOR_TO_LIST VECTOR FROM TO)
- [Primitive number 0x7D]
- Returns a list of the FROMth through TO-1st items in the vector.
- Thus (SUBVECTOR_TO_LIST V 0 (VECTOR_LENGTH V)) returns a list of
- all the items in V.
+/* (SUBVECTOR->LIST VECTOR FROM TO)
+ Returns a list of the FROMth through TO-1st items in the vector.
+ Thus (SUBVECTOR_TO_LIST V 0 (VECTOR_LENGTH V)) returns a list of
+ all the items in V.
*/
-Built_In_Primitive(Prim_Subvector_To_List, 3, "SUBVECTOR->LIST")
-{ Primitive_3_Args();
+Built_In_Primitive(Prim_Subvector_To_List, 3, "SUBVECTOR->LIST", 0x7D)
+{
+ Primitive_3_Args();
+
Arg_1_Type(TC_VECTOR);
- /* The work is done by Subvector_To_List, in PRIMSUBR.C */
return Subvector_To_List();
}
/* (VECTOR_CONS LENGTH CONTENTS)
- [Primitive number 0x2C]
- Create a new vector to hold LENGTH entries, all of which are
- initialized to CONTENTS.
+ Create a new vector to hold LENGTH entries, all of which are
+ initialized to CONTENTS.
*/
-Built_In_Primitive(Prim_Vector_Cons, 2, "VECTOR-CONS")
-{ long Length, i;
+Built_In_Primitive(Prim_Vector_Cons, 2, "VECTOR-CONS", 0x2C)
+{
+ long Length, i;
Primitive_2_Args();
+
Arg_1_Type(TC_FIXNUM);
Length = Get_Integer(Arg1);
Primitive_GC_If_Needed(Length+1);
*Free++ = Make_Non_Pointer(TC_MANIFEST_VECTOR, Length);
- for (i=0; i < Length; i++) *Free++ = Arg2;
- return Make_Pointer(TC_VECTOR, Free-(Length+1));
+ for (i = 0; i < Length; i++)
+ *Free++ = Arg2;
+ return Make_Pointer(TC_VECTOR, (Free - (Length + 1)));
}
-/* (VECTOR_REF VECTOR OFFSET)
- [Primitive number 0x2E]
- Return the OFFSETth entry in VECTOR. Entries are numbered from
- 0.
+/* (VECTOR-REF VECTOR OFFSET)
+ Return the OFFSETth entry in VECTOR. Entries are numbered from 0.
*/
-Built_In_Primitive(Prim_Vector_Ref, 2, "VECTOR-REF")
-{ long Offset;
+Built_In_Primitive(Prim_Vector_Ref, 2, "VECTOR-REF", 0x2E)
+{
+ long Offset;
Primitive_2_Args();
+
Arg_1_Type(TC_VECTOR);
Arg_2_Type(TC_FIXNUM);
Range_Check(Offset, Arg2,
- 0, Vector_Length(Arg1)-1, ERR_ARG_2_BAD_RANGE);
+ 0, (Vector_Length(Arg1) - 1), ERR_ARG_2_BAD_RANGE);
return User_Vector_Ref(Arg1, Offset);
}
\f
-/* (VECTOR_SET VECTOR OFFSET VALUE)
- [Primitive number 0x30]
- Store VALUE as the OFFSETth entry in VECTOR. Entries are
- numbered from 0. Returns (bad style to rely on this) the
- previous value of the entry.
+/* (VECTOR-SET! VECTOR OFFSET VALUE)
+ Store VALUE as the OFFSETth entry in VECTOR. Entries are
+ numbered from 0. Returns (bad style to rely on this) the
+ previous value of the entry.
*/
-Built_In_Primitive(Prim_Vector_Set, 3, "VECTOR-SET!")
-{ long Offset;
+Built_In_Primitive(Prim_Vector_Set, 3, "VECTOR-SET!", 0x30)
+{
+ long Offset;
Primitive_3_Args();
Arg_1_Type(TC_VECTOR);
Arg_2_Type(TC_FIXNUM);
Range_Check(Offset, Arg2,
- 0, Vector_Length(Arg1)-1, ERR_ARG_2_BAD_RANGE);
+ 0, (Vector_Length(Arg1) - 1), ERR_ARG_2_BAD_RANGE);
Side_Effect_Impurify(Arg1, Arg3);
- return Swap_Pointers(Nth_Vector_Loc(Arg1, Offset+1), Arg3);
+ return Swap_Pointers(Nth_Vector_Loc(Arg1, (Offset + 1)), Arg3);
}
-/* (VECTOR_SIZE VECTOR)
- [Primitive number 0x2D]
- Returns the number of entries in VECTOR.
+/* (VECTOR-LENGTH VECTOR)
+ Returns the number of entries in VECTOR.
*/
-Built_In_Primitive(Prim_Vector_Size, 1, "VECTOR-SIZE")
-{ Primitive_1_Arg();
+Built_In_Primitive(Prim_Vector_Size, 1, "VECTOR-LENGTH", 0x2D)
+{
+ Primitive_1_Arg();
+
Arg_1_Type(TC_VECTOR);
- return FIXNUM_0+Vector_Length(Arg1);
+ return Make_Unsigned_Fixnum(Vector_Length(Arg1));
}
\f
-/* (SYS_LIST_TO_VECTOR GC-LIST)
- [Primitive number 0x97]
- Same as LIST_TO_VECTOR except that the resulting vector has the
- specified type code. This can be used, for example, to create
- an environment from a list of values.
+/* (SYSTEM-LIST-TO-VECTOR GC-LIST)
+ Same as LIST_TO_VECTOR except that the resulting vector has the
+ specified type code. This can be used, for example, to create
+ an environment from a list of values.
*/
-Built_In_Primitive(Prim_Sys_List_To_Vector, 2, "SYSTEM-LIST->VECTOR")
-{ long Type;
+Built_In_Primitive(Prim_Sys_List_To_Vector, 2, "SYSTEM-LIST-TO-VECTOR", 0x97)
+{
+ long Type;
Primitive_2_Args();
+
Arg_1_Type(TC_FIXNUM);
Range_Check(Type, Arg1, 0, MAX_TYPE_CODE, ERR_ARG_1_BAD_RANGE);
- if (GC_Type_Code(Type) == GC_Vector) return L_To_V(Type, Arg2);
- else Primitive_Error(ERR_ARG_1_BAD_RANGE); /*NOTREACHED*/
+ if (GC_Type_Code(Type) == GC_Vector)
+ return L_To_V(Type, Arg2);
+ else
+ Primitive_Error(ERR_ARG_1_BAD_RANGE);
+ /*NOTREACHED*/
}
-/* (SYS_SUBVECTOR_TO_LIST GC-VECTOR FROM TO)
- [Primitive number 0x98]
- Same as SUBVECTOR_TO_LIST, but accepts anything with a GC type
- of VECTOR. Most useful for accessing values from environments.
+/* (SYSTEM-SUBVECTOR-TO-LIST GC-VECTOR FROM TO)
+ Same as SUBVECTOR->LIST, but accepts anything with a GC type
+ of VECTOR.
*/
Built_In_Primitive(Prim_Sys_Subvector_To_List, 3,
- "SYSTEM-SUBVECTOR->LIST")
-{ Primitive_3_Args();
+ "SYSTEM-SUBVECTOR-TO-LIST", 0x98)
+{
+ Primitive_3_Args();
Touch_In_Primitive(Arg1, Arg1);
+
Arg_1_GC_Type(GC_Vector);
- /* The work is done by Subvector_To_List, in PRIMSUBR.C */
return Subvector_To_List();
}
\f
-/* (SYS_VECTOR OBJECT)
- [Primitive number 0x99]
- Returns #!TRUE if OBJECT is of GC type VECTOR. Otherwise
- returns NIL.
+/* (SYSTEM-VECTOR? OBJECT)
+ Returns #!TRUE if OBJECT is of GC type VECTOR. Otherwise
+ returns NIL.
*/
-Built_In_Primitive(Prim_Sys_Vector, 1, "SYSTEM-VECTOR")
-{ Primitive_1_Arg();
+Built_In_Primitive(Prim_Sys_Vector, 1, "SYSTEM-VECTOR?", 0x99)
+{
+ Primitive_1_Arg();
+
Touch_In_Primitive(Arg1, Arg1);
- if (GC_Type_Vector(Arg1)) return TRUTH; else return NIL;
+ if (GC_Type_Vector(Arg1))
+ return TRUTH;
+ else
+ return NIL;
}
-/* (SYS_VECTOR_REF GC-VECTOR OFFSET)
- [Primitive number 0x9A]
- Like VECTOR_REF, but for anything of GC type VECTOR (eg.
- environments)
+/* (SYSTEM-VECTOR-REF GC-VECTOR OFFSET)
+ Like VECTOR_REF, but for anything of GC type VECTOR.
*/
-Built_In_Primitive(Prim_Sys_Vector_Ref, 2, "SYSTEM-VECTOR-REF")
-{ long Offset;
+Built_In_Primitive(Prim_Sys_Vector_Ref, 2, "SYSTEM-VECTOR-REF", 0x9A)
+{
+ long Offset;
Primitive_2_Args();
+
Touch_In_Primitive(Arg1, Arg1);
Arg_1_GC_Type(GC_Vector);
Range_Check(Offset, Arg2, 0,
- Vector_Length(Arg1)-1, ERR_ARG_2_BAD_RANGE);
+ (Vector_Length(Arg1) - 1), ERR_ARG_2_BAD_RANGE);
return User_Vector_Ref(Arg1, Offset);
}
-/* (SYS_VECTOR_SET GC-VECTOR OFFSET VALUE)
- [Primitive number 0x9B]
- Like VECTOR_SET, but for anything of GC type VECTOR (eg.
- environments)
+/* (SYSTEM-VECTOR-SET! GC-VECTOR OFFSET VALUE)
+ Like VECTOR_SET, but for anything of GC type VECTOR.
*/
-Built_In_Primitive(Prim_Sys_Vec_Set, 3, "SYSTEM-VECTOR-SET!")
-{ long Offset;
+Built_In_Primitive(Prim_Sys_Vec_Set, 3, "SYSTEM-VECTOR-SET!", 0x9B)
+{
+ long Offset;
Primitive_3_Args();
+
Touch_In_Primitive(Arg1, Arg1);
Arg_1_GC_Type(GC_Vector);
Range_Check(Offset, Arg2, 0,
Vector_Length(Arg1)-1, ERR_ARG_2_BAD_RANGE);
Side_Effect_Impurify(Arg1, Arg3);
- return Swap_Pointers(Nth_Vector_Loc(Arg1, Offset+1), Arg3);
+ return Swap_Pointers(Nth_Vector_Loc(Arg1, (Offset + 1)), Arg3);
}
\f
-/* (SYS_VECTOR_SIZE GC-VECTOR)
- [Primitive number 0xAE]
- Like VECTOR_SIZE, but for anything of GC type VECTOR (eg.
- environments)
+/* (SYSTEM-VECTOR-SIZE GC-VECTOR)
+ Like VECTOR_SIZE, but for anything of GC type VECTOR.
*/
-Built_In_Primitive(Prim_Sys_Vec_Size, 1, "SYSTEM-VECTOR-SIZE")
-{ Primitive_1_Arg();
+Built_In_Primitive(Prim_Sys_Vec_Size, 1, "SYSTEM-VECTOR-SIZE", 0xAE)
+{
+ Primitive_1_Arg();
+
Touch_In_Primitive(Arg1, Arg1);
Arg_1_GC_Type(GC_Vector);
- return FIXNUM_0+Vector_Length(Arg1);
+ return Make_Unsigned_Fixnum(Vector_Length(Arg1));
}
-
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/version.h,v 9.38 1987/04/11 15:08:34 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/version.h,v 9.39 1987/04/16 02:32:57 jinx Exp $
This file contains version information for the microcode. */
\f
#define VERSION 9
#endif
#ifndef SUBVERSION
-#define SUBVERSION 38
+#define SUBVERSION 39
#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/winder.h,v 9.21 1987/01/22 14:37:23 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/winder.h,v 9.22 1987/04/16 02:33:24 jinx Rel $
Header file for dynamic winder.
*/
\f
-#if defined(butterfly)
+#ifdef butterfly
#define guarantee_state_point() \
{ \
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.23 1987/04/03 00:10:08 jinx Exp $
+/* $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 $
*
* Named constants used throughout the interpreter
*
#define NIL Make_Non_Pointer(TC_NULL, 0)
#define TRUTH Make_Non_Pointer(TC_TRUE, 0)
-#define FIXNUM_0 Make_Non_Pointer(TC_FIXNUM, 0)
-#define BROKEN_HEART_0 Make_Non_Pointer(TC_BROKEN_HEART, 0)
-#define STRING_0 Make_Non_Pointer(TC_CHARACTER_STRING, 0)
+#define FIXNUM_ZERO Make_Non_Pointer(TC_FIXNUM, 0)
+#define BROKEN_HEART_ZERO Make_Non_Pointer(TC_BROKEN_HEART, 0)
#else /* 32 bit word */
#define NIL 0x00000000
#define TRUTH 0x08000000
-#define FIXNUM_0 0x1A000000
-#define BROKEN_HEART_0 0x22000000
-#define STRING_0 0x1E000000
+#define FIXNUM_ZERO 0x1A000000
+#define BROKEN_HEART_ZERO 0x22000000
#endif /* b32 */
#define NOT_THERE -1 /* Command line parser */
#define REGBLOCK_EXPR 5
#define REGBLOCK_RETURN 6
#define REGBLOCK_MINIMUM_LENGTH 7
+\f
+/* Codes specifying how to start scheme at boot time. */
+
+#define BOOT_FASLOAD 0
+#define BOOT_LOAD_BAND 1
+#define BOOT_GET_WORK 2
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.22 1987/04/03 00:14:51 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/interp.c,v 9.23 1987/04/16 02:24:28 jinx Exp $
*
* This file contains the heart of the Scheme Scode
* interpreter
primitive_code = Get_Integer(Fetch_Expression());
- Export_Registers_Before_Primitive();
+ Export_Regs_Before_Primitive();
Metering_Apply_Primitive(Val, primitive_code);
- Import_Registers_After_Primitive();
+ Import_Regs_After_Primitive();
Pop_Primitive_Frame(N_Args_Primitive(primitive_code));
if (Must_Report_References())
{ Store_Expression(Val);
goto return_from_compiled_code; \
}
- define_compiler_restart( RC_COMPILER_INTERRUPT_RESTART,
- compiler_interrupt_restart)
+ define_compiler_restart( RC_COMP_INTERRUPT_RESTART,
+ comp_interrupt_restart)
- define_compiler_restart( RC_COMPILER_LEXPR_INTERRUPT_RESTART,
- compiler_lexpr_interrupt_restart)
+ define_compiler_restart( RC_COMP_LEXPR_INTERRUPT_RESTART,
+ comp_lexpr_interrupt_restart)
- define_compiler_restart( RC_COMPILER_LOOKUP_APPLY_RESTART,
- compiler_lookup_apply_restart)
+ define_compiler_restart( RC_COMP_LOOKUP_APPLY_RESTART,
+ comp_lookup_apply_restart)
- define_compiler_restart( RC_COMPILER_REFERENCE_RESTART,
- compiler_reference_restart)
+ define_compiler_restart( RC_COMP_REFERENCE_RESTART,
+ comp_reference_restart)
- define_compiler_restart( RC_COMPILER_ACCESS_RESTART,
- compiler_access_restart)
+ define_compiler_restart( RC_COMP_ACCESS_RESTART,
+ comp_access_restart)
- define_compiler_restart( RC_COMPILER_UNASSIGNED_P_RESTART,
- compiler_unassigned_p_restart)
+ define_compiler_restart( RC_COMP_UNASSIGNED_P_RESTART,
+ comp_unassigned_p_restart)
- define_compiler_restart( RC_COMPILER_UNBOUND_P_RESTART,
- compiler_unbound_p_restart)
+ define_compiler_restart( RC_COMP_UNBOUND_P_RESTART,
+ comp_unbound_p_restart)
- define_compiler_restart( RC_COMPILER_ASSIGNMENT_RESTART,
- compiler_assignment_restart)
+ define_compiler_restart( RC_COMP_ASSIGNMENT_RESTART,
+ comp_assignment_restart)
- define_compiler_restart( RC_COMPILER_DEFINITION_RESTART,
- compiler_definition_restart)
+ define_compiler_restart( RC_COMP_DEFINITION_RESTART,
+ comp_definition_restart)
case RC_REENTER_COMPILED_CODE:
compiled_code_restart();
{
Apply_Error(ERR_UNDEFINED_PRIMITIVE);
}
- NArgs = Ext_Prim_Desc[Proc].arity;
+ NArgs = N_Args_External(Proc);
if (Get_Integer(Stack_Ref(STACK_ENV_HEADER)) !=
(NArgs + (STACK_ENV_FIRST_ARG - 1)))
{
/* Reinitialize Proc in case we "goto Repeat_External..." */
Proc = Get_Integer(Fetch_Expression());
- Export_Registers_Before_Primitive();
- Val = (*(Ext_Prim_Desc[Proc].proc))();
+ Export_Regs_Before_Primitive();
+ Val = Apply_External(Proc);
Set_Time_Zone(Zone_Working);
- Import_Registers_After_Primitive();
- Pop_Primitive_Frame(Ext_Prim_Desc[Proc].arity);
+ Import_Regs_After_Primitive();
+ Pop_Primitive_Frame(N_Args_External(Proc));
goto Pop_Return;
}
Pointer Thunk, New_Location;
if (From_Count != 0)
{ Pointer Current = Stack_Ref(TRANSLATE_FROM_POINT);
- Stack_Ref(TRANSLATE_FROM_DISTANCE) = FIXNUM_0+(From_Count-1);
+ Stack_Ref(TRANSLATE_FROM_DISTANCE) = Make_Unsigned_Fixnum((From_Count - 1));
Thunk = Fast_Vector_Ref(Current, STATE_POINT_AFTER_THUNK);
New_Location = Fast_Vector_Ref(Current, STATE_POINT_NEARER_POINT);
Stack_Ref(TRANSLATE_FROM_POINT) = New_Location;
if ((From_Count == 1) &&
- (Stack_Ref(TRANSLATE_TO_DISTANCE) == FIXNUM_0))
+ (Stack_Ref(TRANSLATE_TO_DISTANCE) == Make_Unsigned_Fixnum(0)))
Stack_Pointer = Simulate_Popping(4);
else Save_Cont();
}
To_Location = Fast_Vector_Ref(To_Location, STATE_POINT_NEARER_POINT);
Thunk = Fast_Vector_Ref(To_Location, STATE_POINT_BEFORE_THUNK);
New_Location = To_Location;
- Stack_Ref(TRANSLATE_TO_DISTANCE) = FIXNUM_0+To_Count;
+ Stack_Ref(TRANSLATE_TO_DISTANCE) = Make_Unsigned_Fixnum(To_Count);
if (To_Count==0)
Stack_Pointer = Simulate_Popping(4);
else Save_Cont();
case RC_RESTORE_DONT_COPY_HISTORY:
{ Pointer Stacklet;
- Previous_Restore_History_Offset = Get_Integer(Pop());
+ Prev_Restore_History_Offset = Get_Integer(Pop());
Stacklet = Pop();
History = Get_Pointer(Fetch_Expression());
- if (Previous_Restore_History_Offset == 0)
- Previous_Restore_History_Stacklet = NULL;
+ if (Prev_Restore_History_Offset == 0)
+ Prev_Restore_History_Stacklet = NULL;
else if (Stacklet == NIL)
- Previous_Restore_History_Stacklet = NULL;
+ Prev_Restore_History_Stacklet = NULL;
else
- Previous_Restore_History_Stacklet = Get_Pointer(Stacklet);
+ Prev_Restore_History_Stacklet = Get_Pointer(Stacklet);
break;
}
Immediate_GC((Free > MemTop) ? 0 : ((MemTop-Free)+1));
}
Import_Registers();
- Previous_Restore_History_Offset = Get_Integer(Pop());
+ Prev_Restore_History_Offset = Get_Integer(Pop());
Stacklet = Pop();
- if (Previous_Restore_History_Offset == 0)
- Previous_Restore_History_Stacklet = NULL;
+ if (Prev_Restore_History_Offset == 0)
+ Prev_Restore_History_Stacklet = NULL;
else
{ if (Stacklet == NIL)
- { Previous_Restore_History_Stacklet = NULL;
- Get_End_Of_Stacklet()[-Previous_Restore_History_Offset] =
+ { Prev_Restore_History_Stacklet = NULL;
+ Get_End_Of_Stacklet()[-Prev_Restore_History_Offset] =
Make_Non_Pointer(TC_RETURN_CODE, RC_RESTORE_HISTORY);
}
else
- { Previous_Restore_History_Stacklet = Get_Pointer(Stacklet);
- Previous_Restore_History_Stacklet[-Previous_Restore_History_Offset] =
+ { Prev_Restore_History_Stacklet = Get_Pointer(Stacklet);
+ Prev_Restore_History_Stacklet[-Prev_Restore_History_Offset] =
Make_Non_Pointer(TC_RETURN_CODE, RC_RESTORE_HISTORY);
}
}
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.h,v 9.35 1987/04/03 00:47:02 jinx Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/lookup.h,v 9.36 1987/04/16 02:26:04 jinx Exp $ */
/* Macros and declarations for the variable lookup code. */
#define AUX_LIST_TYPE TC_VECTOR
#define AUX_CHUNK_SIZE 20
-#define AUX_LIST_COUNT ENVIRONMENT_EXTENSION_COUNT
-#define AUX_LIST_FIRST ENVIRONMENT_EXTENSION_MIN_SIZE
+#define AUX_LIST_COUNT ENV_EXTENSION_COUNT
+#define AUX_LIST_FIRST ENV_EXTENSION_MIN_SIZE
#define AUX_LIST_INITIAL_SIZE (AUX_LIST_FIRST + AUX_CHUNK_SIZE)
/* Variable compilation types. */
\f
/* The code below depends on the following. */
-#if ((VARIABLE_OFFSET == VARIABLE_COMPILED_TYPE) || \
- (VARIABLE_FRAME_NO != VARIABLE_COMPILED_TYPE))
-#include "error: trap.h inconsistency detected."
+/* Done as follows because of VMS. */
+
+#define lookup_inconsistency_p \
+ ((VARIABLE_OFFSET == VARIABLE_COMPILED_TYPE) || \
+ (VARIABLE_FRAME_NO != VARIABLE_COMPILED_TYPE))
+
+#if (lookup_inconsistency_p)
+#include "error: lookup.h inconsistency detected."
#endif
#define get_offset(hunk) Lexical_Offset(Fetch(hunk[VARIABLE_OFFSET]))
/* Unlike Lock_Cell, cell must be (Pointer *). This currently does
not matter, but might on a machine with address mapping.
*/
+
#define setup_lock(handle, cell) handle = Lock_Cell(cell)
#define remove_lock(handle) Unlock_Cell(handle)
break; \
\
case FORMAL_REF: \
- { \
- fast long depth; \
- \
- verify(FORMAL_REF, offset, get_offset(hunk), label); \
+ lookup_formal(cell, env, hunk, label); \
\
- depth = Get_Integer(frame); \
- frame = env; \
- while(--depth >= 0) \
- { \
- frame = Fast_Vector_Ref(Vector_Ref(frame, ENVIRONMENT_FUNCTION), \
- PROCEDURE_ENVIRONMENT); \
- } \
- \
- cell = Nth_Vector_Loc(frame, \
- verified_offset(offset, get_offset(hunk))); \
- \
- break; \
- } \
-\f \
case AUX_REF: \
- { \
- fast long depth; \
- \
- verify(AUX_REF, offset, get_offset(hunk), label); \
- \
- depth = Get_Integer(frame); \
- frame = env; \
- while(--depth >= 0) \
- { \
- frame = Fast_Vector_Ref(Vector_Ref(frame, ENVIRONMENT_FUNCTION), \
- PROCEDURE_ENVIRONMENT); \
- } \
- \
- frame = Vector_Ref(frame, ENVIRONMENT_FUNCTION); \
- if (Type_Code(frame) != AUX_LIST_TYPE) \
- { \
- cell = uncompiled_trap_object; \
- break; \
- } \
- depth = verified_offset(offset, get_offset(hunk)); \
- if (depth > Vector_Length(frame)) \
- { \
- cell = uncompiled_trap_object; \
- break; \
- } \
- frame = Vector_Ref(frame, depth); \
- if ((frame == NIL) || \
- (Fast_Vector_Ref(frame, CONS_CAR) != hunk[VARIABLE_SYMBOL])) \
- { \
- cell = uncompiled_trap_object; \
- break; \
- } \
- cell = Nth_Vector_Loc(frame, CONS_CDR); \
- break; \
- } \
+ lookup_aux(cell, env, hunk, label); \
\
default: \
/* Done here rather than in a separate case because of \
} \
}
\f
+#define lookup_formal(cell, env, hunk, label) \
+{ \
+ fast long depth; \
+ \
+ verify(FORMAL_REF, offset, get_offset(hunk), label); \
+ depth = Get_Integer(frame); \
+ frame = env; \
+ while(--depth >= 0) \
+ { \
+ frame = Fast_Vector_Ref(Vector_Ref(frame, ENVIRONMENT_FUNCTION), \
+ PROCEDURE_ENVIRONMENT); \
+ } \
+ \
+ cell = Nth_Vector_Loc(frame, \
+ verified_offset(offset, get_offset(hunk))); \
+ \
+ break; \
+}
+
+#define lookup_aux(cell, env, hunk, label) \
+{ \
+ fast long depth; \
+ \
+ verify(AUX_REF, offset, get_offset(hunk), label); \
+ depth = Get_Integer(frame); \
+ frame = env; \
+ while(--depth >= 0) \
+ { \
+ frame = Fast_Vector_Ref(Vector_Ref(frame, ENVIRONMENT_FUNCTION), \
+ PROCEDURE_ENVIRONMENT); \
+ } \
+ \
+ frame = Vector_Ref(frame, ENVIRONMENT_FUNCTION); \
+ if (Type_Code(frame) != AUX_LIST_TYPE) \
+ { \
+ cell = uncompiled_trap_object; \
+ break; \
+ } \
+ depth = verified_offset(offset, get_offset(hunk)); \
+ if (depth > Vector_Length(frame)) \
+ { \
+ cell = uncompiled_trap_object; \
+ break; \
+ } \
+ frame = Vector_Ref(frame, depth); \
+ if ((frame == NIL) || \
+ (Fast_Vector_Ref(frame, CONS_CAR) != hunk[VARIABLE_SYMBOL])) \
+ { \
+ cell = uncompiled_trap_object; \
+ break; \
+ } \
+ cell = Nth_Vector_Loc(frame, CONS_CDR); \
+ break; \
+}
+\f
#define lookup_primitive_type_test() \
{ \
if (Type_Code(Arg1) != GLOBAL_ENV) Arg_1_Type(TC_ENVIRONMENT); \
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/mul.c,v 9.21 1987/01/22 14:29:18 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/mul.c,v 9.22 1987/04/16 02:26:41 jinx Rel $
*
* This file contains the portable fixnum multiplication procedure.
* Returns NIL if the result does not fit in a fixnum.
#define MAX_FIXNUM (1<<ADDRESS_LENGTH)
#define ABS(x) (((x) < 0) ? -(x) : (x))
-Pointer Mul(Arg1, Arg2)
-long Arg1, Arg2;
-{ long A, B, C;
+Pointer
+Mul(Arg1, Arg2)
+ long Arg1, Arg2;
+{
+ long A, B, C;
fast long Hi_A, Hi_B, Lo_A, Lo_B, Lo_C, Middle_C;
Boolean Sign;
- Sign_Extend(Arg1, A); Sign_Extend(Arg2, B);
+
+ Sign_Extend(Arg1, A);
+ Sign_Extend(Arg2, B);
Sign = ((A < 0) == (B < 0));
- A = ABS(A); B = ABS(B);
- Hi_A = (A >> HALF_WORD_SIZE) & HALF_WORD_MASK;
- Hi_B = (B >> HALF_WORD_SIZE) & HALF_WORD_MASK;
- Lo_A = A & HALF_WORD_MASK; Lo_B = B & HALF_WORD_MASK;
- Lo_C = Lo_A * Lo_B;
- if (Lo_C > FIXNUM_SIGN_BIT) return NIL;
- Middle_C = Lo_A * Hi_B + Hi_A * Lo_B;
- if (Middle_C >= MAX_MIDDLE) return NIL;
- if ((Hi_A * Hi_B) > 0) return NIL;
+ A = ABS(A);
+ B = ABS(B);
+ Hi_A = ((A >> HALF_WORD_SIZE) & HALF_WORD_MASK);
+ Hi_B = ((B >> HALF_WORD_SIZE) & HALF_WORD_MASK);
+ Lo_A = (A & HALF_WORD_MASK);
+ Lo_B = (B & HALF_WORD_MASK);
+ Lo_C = (Lo_A * Lo_B);
+ if (Lo_C > FIXNUM_SIGN_BIT)
+ return NIL;
+ Middle_C = (Lo_A * Hi_B) + (Hi_A * Lo_B);
+ if (Middle_C >= MAX_MIDDLE)
+ return NIL;
+ if ((Hi_A > 0) && (Hi_B > 0))
+ return NIL;
C = Lo_C + (Middle_C << HALF_WORD_SIZE);
if (Fixnum_Fits(C))
- { if (Sign || (C == 0)) return FIXNUM_0 + C;
- else return FIXNUM_0 + (MAX_FIXNUM - C);
+ {
+ if (Sign || (C == 0))
+ return Make_Unsigned_Fixnum(C);
+ else
+ return Make_Unsigned_Fixnum(MAX_FIXNUM - C);
}
return NIL;
}
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/object.h,v 9.21 1987/04/03 00:18:15 jinx Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/object.h,v 9.22 1987/04/16 02:27:09 jinx Exp $ */
/* This file contains definitions pertaining to the C view of
Scheme pointers: widths of fields, extraction macros, pre-computed
\f
#define Make_Pointer(TC, A) Make_Object((TC), C_To_Scheme(A))
#define Make_Non_Pointer(TC, D) Make_Object(TC, ((Pointer) (D)))
-#define Make_Unsigned_Fixnum(N) (FIXNUM_0 + (N))
-#define Make_Signed_Fixnum(N) Make_Non_Pointer( TC_FIXNUM, (N))
/* (Make_New_Pointer (TC, A)) may be more efficient than
(Make_Pointer (TC, (Get_Pointer (A)))) */
#define User_Vector_Ref(P, N) Vector_Ref(P, (N)+1)
#define User_Vector_Set(P, N, S) Vector_Set(P, (N)+1, S)
\f
+#define Make_Broken_Heart(N) (BROKEN_HEART_ZERO + (N))
+#define Make_Unsigned_Fixnum(N) (FIXNUM_ZERO + (N))
+#define Make_Signed_Fixnum(N) Make_Non_Pointer( TC_FIXNUM, (N))
#define fixnum_p(P) ((pointer_type (P)) == TC_FIXNUM)
#define Get_Float(P) (* ((double *) (Nth_Vector_Loc ((P), 1))))
#define Get_Integer(P) (pointer_datum (P))
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/returns.h,v 9.21 1987/01/22 14:30:54 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/returns.h,v 9.22 1987/04/16 02:28:30 jinx Exp $
*
* Return codes. These are placed in Return when an
* interpreter operation needs to operate in several
*/
#define RC_END_OF_COMPUTATION 0x00
-/* Used to be RC_RESTORE_CONTROL_POINT */
+/* formerly RC_RESTORE_CONTROL_POINT 0x01 */
#define RC_JOIN_STACKLETS 0x01
#define RC_RESTORE_CONTINUATION 0x02 /* Used for 68000 */
#define RC_INTERNAL_APPLY 0x03
#define RC_BAD_INTERRUPT_CONTINUE 0x04 /* Used for 68000 */
#define RC_RESTORE_HISTORY 0x05
-/* Generated by primitive WITH_HISTORY_DISABLED */
#define RC_INVOKE_STACK_THREAD 0x06
-/* Generated by primitive WITH_THREADED_CONTINUATION */
#define RC_RESTART_EXECUTION 0x07 /* Used for 68000 */
#define RC_EXECUTE_ASSIGNMENT_FINISH 0x08
#define RC_EXECUTE_DEFINITION_FINISH 0x09
#define RC_PCOMB3_APPLY 0x1B
\f
#define RC_SNAP_NEED_THUNK 0x1C
-/* Generated by primitive FORCE */
#define RC_REENTER_COMPILED_CODE 0x1D
-/* Formerly RC_GET_CHAR_REPEAT on 68000 0x1E */
-#define RC_COMPILER_REFERENCE_RESTART 0x1F
+/* formerly RC_GET_CHAR_REPEAT 0x1E */
+#define RC_COMP_REFERENCE_RESTART 0x1F
#define RC_NORMAL_GC_DONE 0x20
#define RC_COMPLETE_GC_DONE 0x21 /* Used for 68000 */
#define RC_PURIFY_GC_1 0x22
-/* Generated by primitive PURIFY */
#define RC_PURIFY_GC_2 0x23
-/* Generated by primitive PURIFY */
#define RC_AFTER_MEMORY_UPDATE 0x24 /* Used for 68000 */
#define RC_RESTARTABLE_EXIT 0x25 /* Used for 68000 */
/* formerly RC_GET_CHAR 0x26 */
/* formerly RC_GET_CHAR_IMMEDIATE 0x27 */
-#define RC_COMPILER_ASSIGNMENT_RESTART 0x28
+#define RC_COMP_ASSIGNMENT_RESTART 0x28
#define RC_POP_FROM_COMPILED_CODE 0x29
#define RC_RETURN_TRAP_POINT 0x2A
#define RC_RESTORE_STEPPER 0x2B /* Used for 68000 */
#define RC_RESTORE_TO_STATE_POINT 0x2C
-/* Generated by primitive EXECUTE_AT_NEW_POINT */
#define RC_MOVE_TO_ADJACENT_POINT 0x2D
#define RC_RESTORE_VALUE 0x2E
#define RC_RESTORE_DONT_COPY_HISTORY 0x2F
#define RC_POP_RETURN_ERROR 0x40
#define RC_EVAL_ERROR 0x41
#define RC_REPEAT_PRIMITIVE 0x42
-#define RC_COMPILER_INTERRUPT_RESTART 0x43
-/* #define RC_COMPILER_RECURSION_GC 0x44 */
+#define RC_COMP_INTERRUPT_RESTART 0x43
+/* formerly RC_COMP_RECURSION_GC 0x44 */
#define RC_RESTORE_INT_MASK 0x45
#define RC_HALT 0x46
#define RC_FINISH_GLOBAL_INT 0x47 /* Multiprocessor */
#define RC_REPEAT_DISPATCH 0x48
#define RC_GC_CHECK 0x49
#define RC_RESTORE_FLUIDS 0x4A
-#define RC_COMPILER_LOOKUP_APPLY_RESTART 0x4B
-#define RC_COMPILER_ACCESS_RESTART 0x4C
-#define RC_COMPILER_UNASSIGNED_P_RESTART 0x4D
-#define RC_COMPILER_UNBOUND_P_RESTART 0x4E
-#define RC_COMPILER_DEFINITION_RESTART 0x4F
-#define RC_COMPILER_LEXPR_INTERRUPT_RESTART 0x50
+#define RC_COMP_LOOKUP_APPLY_RESTART 0x4B
+#define RC_COMP_ACCESS_RESTART 0x4C
+#define RC_COMP_UNASSIGNED_P_RESTART 0x4D
+#define RC_COMP_UNBOUND_P_RESTART 0x4E
+#define RC_COMP_DEFINITION_RESTART 0x4F
+#define RC_COMP_LEXPR_INTERRUPT_RESTART 0x50
#define MAX_RETURN_CODE 0x50
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/trap.h,v 9.36 1987/04/06 11:03:21 jinx Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/trap.h,v 9.37 1987/04/16 02:30:49 jinx Exp $ */
\f
/* Kinds of traps:
#define DANGEROUS_OBJECT Make_Unsigned_Fixnum(TRAP_DANGEROUS)
-#if ((TC_REFERENCE_TRAP != 0x32) || (TC_TRUE != 0x08))
-#include "error: lookup.h and types.h are inconsistent"
+#if (TC_REFERENCE_TRAP != 0x32)
+#include "error: trap.h and types.h are inconsistent"
#endif
;;;; Machine Dependent Type Tables
-;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/utabmd.scm,v 9.24 1987/04/03 00:22:18 jinx Exp $
+;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/utabmd.scm,v 9.25 1987/04/16 02:32:05 jinx Exp $
(declare (usual-integrations))
(CDR FIRST-TAIL) ;$22
(SET-CAR! SET-FIRST!) ;$23
(SET-CDR! SET-FIRST-TAIL!) ;$24
- PRINT-STRING ;$25
+ #F ;$25
TTY-GET-CURSOR ;$26
GENERAL-CAR-CDR ;$27
HUNK3-CONS ;$28
SET-CURRENT-HISTORY! ;$2F
VECTOR-SET! ;$30
NON-MARKED-VECTOR-CONS ;$31
- GET-CHARACTER-FROM-INPUT-CHANNEL ;$32
+ #F ;$32
LEXICAL-UNBOUND? ;$33
INTEGER->CHAR ;$34
CHAR-DOWNCASE ;$35
SYSTEM-PAIR-SET-CAR! ;$88
SYSTEM-PAIR-SET-CDR! ;$89
#F ;$8A
- GET-CHARACTER-FROM-INPUT-CHANNEL-IMMEDIATE ;$8B
+ #F ;$8B
SET-CELL-CONTENTS! ;$8C
&MAKE-OBJECT ;$8D
SYSTEM-HUNK3-CXR0 ;$8E
GREATER-THAN-FLONUM? ;$AA
INTERN-CHARACTER-LIST ;$AB
#F ;$AC
- (STRING-LENGTH STRING-SIZE VECTOR-8B-SIZE) ;$AD
+ (STRING-SIZE VECTOR-8B-SIZE) ;$AD
SYSTEM-VECTOR-SIZE ;$AE
FORCE ;$AF
PRIMITIVE-DATUM ;$B0
FILE-WRITE-CHAR ;$C5
FILE-WRITE-STRING ;$C6
CLOSE-LOST-OPEN-FILES ;$C7
- PUT-CHARACTER-TO-OUTPUT-CHANNEL ;$C8
+ #F ;$C8
WITH-INTERRUPTS-REDUCED ;$C9
PRIMITIVE-EVAL-STEP ;$CA
PRIMITIVE-APPLY-STEP ;$CB
GET-EXTERNAL-COUNTS ;$101
GET-EXTERNAL-NAME ;$102
GET-EXTERNAL-NUMBER ;$103
- OPEN-CHANNEL ;$104
- CLOSE-PHYSICAL-CHANNEL ;$105
+ #F ;$104
+ #F ;$105
GET-NEXT-INTERRUPT-CHARACTER ;$106
CHECK-AND-CLEAN-UP-INPUT-CHANNEL ;$107
#F ;$108
;;; This identification string is saved by the system.
-"$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/utabmd.scm,v 9.24 1987/04/03 00:22:18 jinx Exp $"
+"$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/utabmd.scm,v 9.25 1987/04/16 02:32:05 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 9.38 1987/04/11 15:08:34 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/version.h,v 9.39 1987/04/16 02:32:57 jinx Exp $
This file contains version information for the microcode. */
\f
#define VERSION 9
#endif
#ifndef SUBVERSION
-#define SUBVERSION 38
+#define SUBVERSION 39
#endif
#ifndef UCODE_TABLES_FILENAME
projects / mit-scheme.git / commitdiff