promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bintopsb.c,v 9.30 1987/11/20 08:21:12 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/bintopsb.c,v 9.31 1987/11/23 05:11:12 cph Exp $
*
* This File contains the code to translate internal format binary
* files to portable format.
#define Internal_File Input_File
#define Portable_File Output_File
-#include "translate.h"
+#include "psbmap.h"
#include "trap.h"
long
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.35 1987/11/17 08:07:17 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/bitstr.c,v 9.36 1987/11/23 05:13:53 cph Rel $
Bit string primitives.
Pointer result;
total_pointers = (1 + (bits_to_pointers (length)));
- result = allocate_non_marked_vector (TC_BIT_STRING, total_pointers, true);
- Fast_Vector_Set(result, BIT_STRING_LENGTH_OFFSET, length);
+ result = (allocate_non_marked_vector (TC_BIT_STRING, total_pointers, true));
+ Fast_Vector_Set (result, BIT_STRING_LENGTH_OFFSET, length);
return (result);
}
/* (BIT-STRING-ALLOCATE length)
Returns an uninitialized bit string of the given length. */
-Built_In_Primitive (Prim_bit_string_allocate, 1, "BIT-STRING-ALLOCATE", 0xD1)
-Define_Primitive (Prim_bit_string_allocate, 1, "BIT-STRING-ALLOCATE")
+DEFINE_PRIMITIVE ("BIT-STRING-ALLOCATE", Prim_bit_string_allocate, 1)
{
- Primitive_1_Arg ();
+ PRIMITIVE_HEADER (1);
- PRIMITIVE_RETURN( allocate_bit_string (arg_nonnegative_integer (1)));
+ PRIMITIVE_RETURN (allocate_bit_string (arg_nonnegative_integer (1)));
}
/* (BIT-STRING? object)
Returns true iff object is a bit string. */
-Built_In_Primitive (Prim_bit_string_p, 1, "BIT-STRING?", 0xD3)
-Define_Primitive (Prim_bit_string_p, 1, "BIT-STRING?")
+DEFINE_PRIMITIVE ("BIT-STRING?", Prim_bit_string_p, 1)
{
- Primitive_1_Arg ();
+ fast Pointer object;
+ PRIMITIVE_HEADER (1);
- Touch_In_Primitive (Arg1, Arg1);
- PRIMITIVE_RETURN( (BIT_STRING_P (Arg1)) ? TRUTH : NIL);
+ object = (ARG_REF (1));
+ Touch_In_Primitive (object, object);
+ PRIMITIVE_RETURN ((BIT_STRING_P (object)) ? TRUTH : NIL);
}
\f
void
-fill_bit_string( bit_string, sense)
+fill_bit_string (bit_string, sense)
Pointer bit_string;
Boolean sense;
{
long i;
filler = ((Pointer) (sense ? (~ 0) : 0));
- scanner = bit_string_high_ptr( bit_string);
- for (i = bits_to_pointers( bit_string_length( bit_string));
+ scanner = bit_string_high_ptr (bit_string);
+ for (i = bits_to_pointers (bit_string_length (bit_string));
(i > 0); i -= 1)
- *(dec_bit_string_ptr(scanner)) = filler;
+ (* (dec_bit_string_ptr (scanner))) = filler;
}
void
-clear_bit_string( bit_string)
+clear_bit_string (bit_string)
Pointer bit_string;
{
Pointer *scanner;
long i;
- scanner = bit_string_high_ptr( bit_string);
- for (i = bits_to_pointers( bit_string_length( bit_string));
+ scanner = bit_string_high_ptr (bit_string);
+ for (i = bits_to_pointers (bit_string_length (bit_string));
(i > 0); i -= 1)
- *(dec_bit_string_ptr(scanner)) = 0;
+ (* (dec_bit_string_ptr (scanner))) = 0;
}
\f
/* (MAKE-BIT-STRING size initialization)
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", 0xD2)
-Define_Primitive (Prim_make_bit_string, 2, "MAKE-BIT-STRING")
+DEFINE_PRIMITIVE ("MAKE-BIT-STRING", Prim_make_bit_string, 2)
{
Pointer result;
- Primitive_2_Args ();
+ PRIMITIVE_HEADER (2);
result = allocate_bit_string (arg_nonnegative_integer (1));
- fill_bit_string (result, (Arg2 != NIL));
- PRIMITIVE_RETURN( result);
+ fill_bit_string (result, ((ARG_REF (2)) != NIL));
+ PRIMITIVE_RETURN (result);
}
/* (BIT-STRING-FILL! bit-string initialization)
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!", 0x197)
-Define_Primitive (Prim_bit_string_fill_x, 2, "BIT-STRING-FILL!")
+DEFINE_PRIMITIVE ("BIT-STRING-FILL!", Prim_bit_string_fill_x, 2)
{
- Primitive_2_Args ();
+ PRIMITIVE_HEADER (2);
CHECK_ARG (1, BIT_STRING_P);
- fill_bit_string (Arg1, (Arg2 != NIL));
- PRIMITIVE_RETURN( NIL);
+ fill_bit_string ((ARG_REF (1)), ((ARG_REF (2)) != NIL));
+ PRIMITIVE_RETURN (NIL);
}
/* (BIT-STRING-LENGTH bit-string)
Returns the number of bits in BIT-STRING. */
-Built_In_Primitive (Prim_bit_string_length, 1, "BIT-STRING-LENGTH", 0xD4)
-Define_Primitive (Prim_bit_string_length, 1, "BIT-STRING-LENGTH")
+DEFINE_PRIMITIVE ("BIT-STRING-LENGTH", Prim_bit_string_length, 1)
{
- Primitive_1_Arg ();
+ PRIMITIVE_HEADER (1);
CHECK_ARG (1, BIT_STRING_P);
- PRIMITIVE_RETURN( Make_Unsigned_Fixnum (bit_string_length (Arg1)));
+ PRIMITIVE_RETURN (Make_Unsigned_Fixnum (bit_string_length (ARG_REF (1))));
}
\f
-#define ref_initialization() \
- long index, mask; \
- Pointer *ptr; \
- Primitive_2_Args (); \
+#define REF_INITIALIZATION() \
+ fast Pointer bit_string; \
+ fast long index; \
+ fast Pointer *ptr; \
+ fast long mask; \
+ PRIMITIVE_HEADER (2); \
\
CHECK_ARG (1, BIT_STRING_P); \
+ bit_string = (ARG_REF (1)); \
index = (arg_nonnegative_integer (2)); \
- if (index >= (bit_string_length (Arg1))) \
+ if (index >= (bit_string_length (bit_string))) \
error_bad_range_arg (1); \
\
- ptr = Nth_Vector_Loc(Arg1, index_to_word(Arg1, index)); \
+ ptr = \
+ (Nth_Vector_Loc (bit_string, (index_to_word (bit_string, index)))); \
mask = (1 << (index % POINTER_LENGTH))
/* (BIT-STRING-REF bit-string index)
Returns the boolean value of the indexed bit. */
-Built_In_Primitive (Prim_bit_string_ref, 2, "BIT-STRING-REF", 0xD5)
-Define_Primitive (Prim_bit_string_ref, 2, "BIT-STRING-REF")
+DEFINE_PRIMITIVE ("BIT-STRING-REF", Prim_bit_string_ref, 2)
{
- ref_initialization ();
+ REF_INITIALIZATION ();
- PRIMITIVE_RETURN( (((bit_string_word( ptr)) & mask) == 0) ? NIL : TRUTH);
+ PRIMITIVE_RETURN ((((bit_string_word (ptr)) & mask) == 0) ? NIL : TRUTH);
}
/* (BIT-STRING-CLEAR! bit-string index)
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!", 0xD8)
-Define_Primitive (Prim_bit_string_clear_x, 2, "BIT-STRING-CLEAR!")
+DEFINE_PRIMITIVE ("BIT-STRING-CLEAR!", Prim_bit_string_clear_x, 2)
{
- ref_initialization ();
+ REF_INITIALIZATION ();
- if (((bit_string_word( ptr)) & mask) == 0)
- PRIMITIVE_RETURN( NIL);
- else
- {
- (bit_string_word( ptr)) &= ~mask;
- PRIMITIVE_RETURN( TRUTH);
- }
+ if (((bit_string_word (ptr)) & mask) == 0)
+ PRIMITIVE_RETURN (NIL);
+ (bit_string_word (ptr)) &= ~mask;
+ PRIMITIVE_RETURN (TRUTH);
}
/* (BIT-STRING-SET! bit-string index)
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!", 0xD7)
-Define_Primitive (Prim_bit_string_set_x, 2, "BIT-STRING-SET!")
+DEFINE_PRIMITIVE ("BIT-STRING-SET!", Prim_bit_string_set_x, 2)
{
- ref_initialization ();
+ REF_INITIALIZATION ();
- if (((bit_string_word( ptr)) & mask) == 0)
- {
- ((bit_string_word( ptr))) |= mask;
- PRIMITIVE_RETURN( NIL);
- }
- else
- PRIMITIVE_RETURN( TRUTH);
+ if (((bit_string_word (ptr)) & mask) != 0)
+ PRIMITIVE_RETURN (TRUTH);
+ ((bit_string_word (ptr))) |= mask;
+ PRIMITIVE_RETURN (NIL);
}
\f
-#define zero_section_p() \
+#define ZERO_SECTION_P() \
{ \
for (i = (length / POINTER_LENGTH); (i > 0); i -= 1) \
- if (*(dec_bit_string_ptr(scan)) != 0) \
- PRIMITIVE_RETURN( NIL); \
- PRIMITIVE_RETURN( TRUTH); \
+ if ((* (dec_bit_string_ptr (scan))) != 0) \
+ PRIMITIVE_RETURN (NIL); \
+ PRIMITIVE_RETURN (TRUTH); \
}
/* (BIT-STRING-ZERO? bit-string)
Returns true the argument has no "set" bits. */
-Built_In_Primitive (Prim_bit_string_zero_p, 1, "BIT-STRING-ZERO?", 0xD9)
-Define_Primitive (Prim_bit_string_zero_p, 1, "BIT-STRING-ZERO?")
+DEFINE_PRIMITIVE ("BIT-STRING-ZERO?", Prim_bit_string_zero_p, 1)
{
+ fast Pointer bit_string;
fast Pointer *scan;
fast long i;
long length, odd_bits;
- Primitive_1_Args ();
+ PRIMITIVE_HEADER (1);
CHECK_ARG (1, BIT_STRING_P);
-
- length = (bit_string_length (Arg1));
+ bit_string = (ARG_REF (1));
+ length = (bit_string_length (bit_string));
odd_bits = (length % POINTER_LENGTH);
- scan = bit_string_high_ptr(Arg1);
+ scan = (bit_string_high_ptr (bit_string));
if (odd_bits == 0)
- {
- zero_section_p();
- }
- else if ((bit_string_word(scan) & (low_mask (odd_bits))) != 0)
- PRIMITIVE_RETURN( NIL);
+ {
+ ZERO_SECTION_P ();
+ }
+ else if (((bit_string_word (scan)) & (low_mask (odd_bits))) != 0)
+ PRIMITIVE_RETURN (NIL);
else
- {
- dec_bit_string_ptr(scan);
- zero_section_p();
- }
+ {
+ dec_bit_string_ptr (scan);
+ ZERO_SECTION_P ();
+ }
}
\f
-#define equal_sections_p() \
+#define EQUAL_SECTIONS_P() \
{ \
for (i = (length / POINTER_LENGTH); (i > 0); i -= 1) \
- if (*(dec_bit_string_ptr(scan1)) != *(dec_bit_string_ptr(scan2))) \
- PRIMITIVE_RETURN( NIL); \
- PRIMITIVE_RETURN( TRUTH); \
+ if ((* (dec_bit_string_ptr (scan1))) != \
+ (* (dec_bit_string_ptr (scan2)))) \
+ PRIMITIVE_RETURN (NIL); \
+ PRIMITIVE_RETURN (TRUTH); \
}
/* (BIT-STRING=? bit-string-1 bit-string-2)
Returns true iff the two bit strings contain the same bits. */
-Built_In_Primitive (Prim_bit_string_equal_p, 2, "BIT-STRING=?", 0x19D)
-Define_Primitive (Prim_bit_string_equal_p, 2, "BIT-STRING=?")
+DEFINE_PRIMITIVE ("BIT-STRING=?", Prim_bit_string_equal_p, 2)
{
+ Pointer bit_string_1, bit_string_2;
long length;
- Primitive_2_Args ();
+ fast Pointer *scan1, *scan2;
+ fast long i;
+ long odd_bits;
+ PRIMITIVE_HEADER (2);
CHECK_ARG (1, BIT_STRING_P);
CHECK_ARG (2, BIT_STRING_P);
- length = bit_string_length( Arg1);
- if (length != bit_string_length( Arg2))
- PRIMITIVE_RETURN( NIL);
- else
- {
- fast Pointer *scan1, *scan2;
- fast long i;
- long odd_bits;
-
- scan1 = bit_string_high_ptr(Arg1);
- scan2 = bit_string_high_ptr(Arg2);
- odd_bits = (length % POINTER_LENGTH);
- if (odd_bits == 0)
+ bit_string_1 = (ARG_REF (1));
+ bit_string_2 = (ARG_REF (2));
+ length = bit_string_length (bit_string_1);
+ if (length != bit_string_length (bit_string_2))
+ PRIMITIVE_RETURN (NIL);
+
+ scan1 = (bit_string_high_ptr (bit_string_1));
+ scan2 = (bit_string_high_ptr (bit_string_2));
+ odd_bits = (length % POINTER_LENGTH);
+ if (odd_bits == 0)
{
- equal_sections_p();
+ EQUAL_SECTIONS_P ();
}
- else
+ else
{
long mask;
- mask = low_mask( odd_bits);
- if (((bit_string_msw(Arg1)) & mask) != ((bit_string_msw(Arg2)) & mask))
- PRIMITIVE_RETURN( NIL);
+ mask = (low_mask (odd_bits));
+ if (((bit_string_msw (bit_string_1)) & mask) !=
+ ((bit_string_msw (bit_string_2)) & mask))
+ PRIMITIVE_RETURN (NIL);
else
- {
- dec_bit_string_ptr(scan1);
- dec_bit_string_ptr(scan2);
- equal_sections_p();
- }
+ {
+ dec_bit_string_ptr (scan1);
+ dec_bit_string_ptr (scan2);
+ EQUAL_SECTIONS_P ();
+ }
}
- }
}
\f
/* (BIT-STRING-OPERATION! destination source)
Modifies destination to be the result of using OPERATION bitwise on
- destination and source.
-*/
+ destination and source. */
-#define bitwise_op( action) \
-{ \
+#define BITWISE_OP(action) \
+ Pointer bit_string_1, bit_string_2; \
fast long i; \
fast Pointer *scan1, *scan2; \
- Primitive_2_Args (); \
+ PRIMITIVE_HEADER (2); \
\
- if ((bit_string_length (Arg1)) != (bit_string_length (Arg2))) \
+ bit_string_1 = (ARG_REF (1)); \
+ bit_string_2 = (ARG_REF (2)); \
+ if ((bit_string_length (bit_string_1)) != \
+ (bit_string_length (bit_string_2))) \
error_bad_range_arg (1); \
\
- scan1 = (bit_string_high_ptr (Arg1)); \
- scan2 = (bit_string_high_ptr (Arg2)); \
- for (i = ((Vector_Length (Arg1)) - 1); (i > 0); i -= 1) \
- (*(dec_bit_string_ptr(scan1))) action() (*(dec_bit_string_ptr(scan2))); \
- PRIMITIVE_RETURN( NIL); \
-}
+ scan1 = (bit_string_high_ptr (bit_string_1)); \
+ scan2 = (bit_string_high_ptr (bit_string_2)); \
+ for (i = ((Vector_Length (bit_string_1)) - 1); (i > 0); i -= 1) \
+ (* (dec_bit_string_ptr (scan1))) action() \
+ (* (dec_bit_string_ptr (scan2))); \
+ PRIMITIVE_RETURN (NIL)
#define bit_string_move_x_action() =
#define bit_string_movec_x_action() = ~
#define bit_string_andc_x_action() &= ~
#define bit_string_xor_x_action() ^=
-Built_In_Primitive( Prim_bit_string_move_x, 2, "BIT-STRING-MOVE!", 0x198)
-Define_Primitive( Prim_bit_string_move_x, 2, "BIT-STRING-MOVE!")
- bitwise_op( bit_string_move_x_action)
+DEFINE_PRIMITIVE ("BIT-STRING-MOVE!", Prim_bit_string_move_x, 2)
+{ BITWISE_OP (bit_string_move_x_action); }
-Built_In_Primitive( Prim_bit_string_movec_x, 2, "BIT-STRING-MOVEC!", 0x199)
-Define_Primitive( Prim_bit_string_movec_x, 2, "BIT-STRING-MOVEC!")
- bitwise_op( bit_string_movec_x_action)
+DEFINE_PRIMITIVE ("BIT-STRING-MOVEC!", Prim_bit_string_movec_x, 2)
+{ BITWISE_OP (bit_string_movec_x_action); }
-Built_In_Primitive( Prim_bit_string_or_x, 2, "BIT-STRING-OR!", 0x19A)
-Define_Primitive( Prim_bit_string_or_x, 2, "BIT-STRING-OR!")
- bitwise_op( bit_string_or_x_action)
+DEFINE_PRIMITIVE ("BIT-STRING-OR!", Prim_bit_string_or_x, 2)
+{ BITWISE_OP (bit_string_or_x_action); }
-Built_In_Primitive( Prim_bit_string_and_x, 2, "BIT-STRING-AND!", 0x19B)
-Define_Primitive( Prim_bit_string_and_x, 2, "BIT-STRING-AND!")
- bitwise_op( bit_string_and_x_action)
+DEFINE_PRIMITIVE ("BIT-STRING-AND!", Prim_bit_string_and_x, 2)
+{ BITWISE_OP (bit_string_and_x_action); }
-Built_In_Primitive( Prim_bit_string_andc_x, 2, "BIT-STRING-ANDC!", 0x19C)
-Define_Primitive( Prim_bit_string_andc_x, 2, "BIT-STRING-ANDC!")
- bitwise_op( bit_string_andc_x_action)
+DEFINE_PRIMITIVE ("BIT-STRING-ANDC!", Prim_bit_string_andc_x, 2)
+{ BITWISE_OP (bit_string_andc_x_action); }
-Built_In_Primitive( Prim_bit_string_xor_x, 2, "BIT-STRING-XOR!", 0x18F)
-Define_Primitive( Prim_bit_string_xor_x, 2, "BIT-STRING-XOR!")
- bitwise_op( bit_string_xor_x_action)
+DEFINE_PRIMITIVE ("BIT-STRING-XOR!", Prim_bit_string_xor_x, 2)
+{ BITWISE_OP (bit_string_xor_x_action); }
\f
/* (BIT-SUBSTRING-MOVE-RIGHT! source start1 end1 destination start2)
Destructively copies the substring of SOURCE between START1 and
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!", 0xD6)
-Define_Primitive( Prim_bit_substring_move_right_x, 5,
- "BIT-SUBSTRING-MOVE-RIGHT!")
+DEFINE_PRIMITIVE ("BIT-SUBSTRING-MOVE-RIGHT!", Prim_bit_substring_move_right_x, 5)
{
+ fast Pointer bit_string_1, bit_string_2;
long start1, end1, start2, end2, nbits;
long end1_mod, end2_mod;
void copy_bits();
- Primitive_5_Args();
+ PRIMITIVE_HEADER (5);
CHECK_ARG (1, BIT_STRING_P);
+ bit_string_1 = (ARG_REF (1));
start1 = (arg_nonnegative_integer (2));
end1 = (arg_nonnegative_integer (3));
- CHECK_ARG (4, BIT_STRING_P);
+ CHECK_ARG (4, BIT_STRING_P);
+ bit_string_2 = (ARG_REF (4));
start2 = (arg_nonnegative_integer (5));
nbits = (end1 - start1);
if ((start1 < 0) || (start1 > end1))
error_bad_range_arg (2);
- if (end1 > (bit_string_length (Arg1)))
+ if (end1 > (bit_string_length (bit_string_1)))
error_bad_range_arg (3);
- if ((start2 < 0) || (end2 > (bit_string_length (Arg4))))
+ if ((start2 < 0) || (end2 > (bit_string_length (bit_string_2))))
error_bad_range_arg (5);
end1_mod = (end1 % POINTER_LENGTH);
the discretion of the C compiler being used. This doesn't
matter because if `end' is zero, then no bits will be moved. */
- copy_bits( Nth_Vector_Loc( Arg1, index_to_word( Arg1, (end1 - 1))),
+ copy_bits ((Nth_Vector_Loc (bit_string_1,
+ (index_to_word (bit_string_1, (end1 - 1))))),
((end1_mod == 0) ? 0 : (POINTER_LENGTH - end1_mod)),
- Nth_Vector_Loc( Arg4, index_to_word( Arg4, (end2 - 1))),
+ (Nth_Vector_Loc (bit_string_2,
+ (index_to_word (bit_string_2, (end2 - 1))))),
((end2_mod == 0) ? 0 : (POINTER_LENGTH - end2_mod)),
nbits);
- PRIMITIVE_RETURN( NIL);
+ PRIMITIVE_RETURN (NIL);
}
\f
-#define masked_transfer( source, destination, nbits, offset) \
+#define MASKED_TRANSFER(source, destination, nbits, offset) do \
{ \
long mask; \
\
- mask = any_mask( nbits, offset); \
- (bit_string_word(destination)) = \
- (((bit_string_word(source)) & mask) | \
- ((bit_string_word(destination)) & ~mask)); \
-}
+ mask = (any_mask (nbits, offset)); \
+ (bit_string_word (destination)) = \
+ (((bit_string_word (source)) & mask) | \
+ ((bit_string_word (destination)) & ~mask)); \
+} while (0)
/* This procedure copies bits from one place to another.
The offsets are measured from the MSB of the first Pointer of
starting with the MSB of a bit string and moving down. */
void
-copy_bits( source, source_offset, destination, destination_offset, nbits)
+copy_bits (source, source_offset, destination, destination_offset, nbits)
Pointer *source, *destination;
long source_offset, destination_offset, nbits;
{
-
+\f
/* This common case can be done very quickly, by splitting the
bit string into three parts. Since the source and destination are
aligned relative to one another, the main body of bits can be
treated specially. */
if (source_offset == destination_offset)
- {
- if (source_offset != 0)
- {
- long head;
-
- head = (POINTER_LENGTH - source_offset);
- if (nbits <= head)
- {
- masked_transfer( source, destination, nbits, (head - nbits));
- nbits = 0;
- }
- else
- {
- Pointer temp;
- long mask;
-
- mask = low_mask( head);
- temp = (bit_string_word(destination));
- *(dec_bit_string_ptr(destination)) =
- ((*(dec_bit_string_ptr(source)) & mask) | (temp & ~mask));
- nbits -= head;
- }
- }
- if (nbits > 0)
{
- long nwords, tail;
+ if (source_offset != 0)
+ {
+ long head;
+
+ head = (POINTER_LENGTH - source_offset);
+ if (nbits <= head)
+ {
+ MASKED_TRANSFER (source, destination, nbits, (head - nbits));
+ nbits = 0;
+ }
+ else
+ {
+ Pointer temp;
+ long mask;
+
+ mask = (low_mask (head));
+ temp = (bit_string_word (destination));
+ (* (dec_bit_string_ptr (destination))) =
+ (((* (dec_bit_string_ptr (source))) & mask) |
+ (temp & (~ mask)));
+ nbits -= head;
+ }
+ }
+ if (nbits > 0)
+ {
+ long nwords, tail;
- for (nwords = (nbits / POINTER_LENGTH); (nwords > 0); nwords -= 1)
- *(dec_bit_string_ptr(destination)) = *(dec_bit_string_ptr(source));
+ for (nwords = (nbits / POINTER_LENGTH); (nwords > 0); nwords -= 1)
+ (* (dec_bit_string_ptr (destination))) =
+ (* (dec_bit_string_ptr (source)));
- tail = (nbits % POINTER_LENGTH);
- if (tail > 0)
- masked_transfer( source, destination, tail,
- (POINTER_LENGTH - tail));
+ tail = (nbits % POINTER_LENGTH);
+ if (tail > 0)
+ MASKED_TRANSFER
+ (source, destination, tail, (POINTER_LENGTH - tail));
+ }
}
- }
\f
else if (source_offset < destination_offset)
- {
- long offset1, offset2, head;
-
- offset1 = (destination_offset - source_offset);
- offset2 = (POINTER_LENGTH - offset1);
- head = (POINTER_LENGTH - destination_offset);
-
- if (nbits <= head)
{
- long mask;
+ long offset1, offset2, head;
- mask = any_mask( nbits, (head - nbits));
- (bit_string_word(destination)) =
- ((((bit_string_word(source)) >> offset1) & mask) |
- ((bit_string_word(destination)) & ~mask));
- }
- else
- {
- long mask1, mask2;
-
- { Pointer temp;
- long mask;
+ offset1 = (destination_offset - source_offset);
+ offset2 = (POINTER_LENGTH - offset1);
+ head = (POINTER_LENGTH - destination_offset);
- mask = low_mask( head);
- temp = (bit_string_word(destination));
- *(dec_bit_string_ptr(destination)) =
- ((((bit_string_word(source)) >> offset1) & mask) | (temp & ~mask));
- }
-
- nbits -= head;
- mask1 = low_mask( offset1);
- mask2 = low_mask( offset2);
-
- {
- long nwords, i;
-
- for (nwords = (nbits / POINTER_LENGTH); (nwords > 0); nwords -= 1)
+ if (nbits <= head)
{
- i = ((*(dec_bit_string_ptr(source)) & mask1) << offset2);
- *(dec_bit_string_ptr(destination)) =
- ((((bit_string_word(source)) >> offset1) & mask2) | i);
- }
- }
-\f
- {
- long tail, dest_tail;
+ long mask;
- tail = (nbits % POINTER_LENGTH);
- dest_tail = ((bit_string_word(destination)) &
- low_mask( POINTER_LENGTH - tail));
- if (tail <= offset1)
- {
- (bit_string_word(destination)) =
- ((((bit_string_word(source)) &
- any_mask( tail, (offset1 - tail))) << offset2)
- | dest_tail);
- }
+ mask = (any_mask (nbits, (head - nbits)));
+ (bit_string_word (destination)) =
+ ((((bit_string_word (source)) >> offset1) & mask) |
+ ((bit_string_word (destination)) & ~mask));
+ }
else
- {
- long i, j;
-
- i = ((*(dec_bit_string_ptr(source)) & mask1) << offset2);
- j = (tail - offset1);
- (bit_string_word(destination)) =
- ((((bit_string_word(source)) &
- any_mask( j, (POINTER_LENGTH - j))) >> offset1)
- | i | dest_tail);
- }
- }
- }
- }
+ {
+ long mask1, mask2;
+
+ { Pointer temp;
+ long mask;
+
+ mask = (low_mask (head));
+ temp = (bit_string_word (destination));
+ (* (dec_bit_string_ptr (destination))) =
+ ((((bit_string_word (source)) >> offset1) & mask) |
+ (temp & ~mask));
+ }
+
+ nbits -= head;
+ mask1 = (low_mask (offset1));
+ mask2 = (low_mask (offset2));
+
+ {
+ long nwords, i;
+
+ for (nwords = (nbits / POINTER_LENGTH); (nwords > 0); nwords -= 1)
+ {
+ i = (((* (dec_bit_string_ptr (source))) & mask1) << offset2);
+ (* (dec_bit_string_ptr (destination))) =
+ ((((bit_string_word (source)) >> offset1) & mask2) | i);
+ }
+ }
\f
- else /* if (source_offset > destination_offset) */
- {
- long offset1, offset2, head;
-
- offset1 = (source_offset - destination_offset);
- offset2 = (POINTER_LENGTH - offset1);
- head = (POINTER_LENGTH - source_offset);
-
- if (nbits <= head)
- {
- long mask;
-
- mask = any_mask( nbits, (offset1 + (head - nbits)));
- (bit_string_word(destination)) =
- ((((bit_string_word(source)) << offset1) & mask) |
- ((bit_string_word(destination)) & ~mask));
+ {
+ long tail, dest_tail;
+
+ tail = (nbits % POINTER_LENGTH);
+ dest_tail =
+ ((bit_string_word (destination)) &
+ (low_mask (POINTER_LENGTH - tail)));
+ if (tail <= offset1)
+ {
+ (bit_string_word (destination)) =
+ ((((bit_string_word (source)) &
+ (any_mask (tail, (offset1 - tail))))
+ << offset2)
+ | dest_tail);
+ }
+ else
+ {
+ long i, j;
+
+ i = (((* (dec_bit_string_ptr (source))) & mask1) << offset2);
+ j = (tail - offset1);
+ (bit_string_word (destination)) =
+ ((((bit_string_word (source)) &
+ (any_mask (j, (POINTER_LENGTH - j))))
+ >> offset1)
+ | i | dest_tail);
+ }
+ }
+ }
}
- else
+\f
+ else /* if (source_offset > destination_offset) */
{
- long dest_buffer, mask1, mask2;
+ long offset1, offset2, head;
- {
- long mask;
-
- mask = any_mask( head, offset1);
- dest_buffer =
- (((bit_string_word(destination)) & ~mask)
- | ((*(dec_bit_string_ptr(source)) << offset1) & mask));
- }
- nbits -= head;
- mask1 = low_mask( offset1);
- mask2 = any_mask( offset2, offset1);
- {
- long nwords;
+ offset1 = (source_offset - destination_offset);
+ offset2 = (POINTER_LENGTH - offset1);
+ head = (POINTER_LENGTH - source_offset);
- nwords = (nbits / POINTER_LENGTH);
- if (nwords > 0)
- dest_buffer &= mask2;
- for (; (nwords > 0); nwords -= 1)
+ if (nbits <= head)
{
- *(dec_bit_string_ptr(destination)) =
- (dest_buffer | (((bit_string_word(source)) >> offset2) & mask1));
- dest_buffer = (*(dec_bit_string_ptr(source)) << offset1);
- }
- }
-\f
- {
- long tail;
+ long mask;
- tail = (nbits % POINTER_LENGTH);
- if (tail <= offset1)
- {
- (bit_string_word(destination)) =
- (dest_buffer
- | ((bit_string_word(destination)) & low_mask( offset1 - tail))
- | (((bit_string_word(source)) >> offset2) &
- any_mask( tail, (offset1 - tail))));
+ mask = (any_mask (nbits, (offset1 + (head - nbits))));
+ (bit_string_word (destination)) =
+ ((((bit_string_word (source)) << offset1) & mask) |
+ ((bit_string_word (destination)) & ~mask));
}
- else
+ else
{
- long mask;
-
- *(dec_bit_string_ptr(destination)) =
- (dest_buffer | (((bit_string_word(source)) >> offset2) & mask1));
- mask = low_mask( POINTER_LENGTH - tail);
- (bit_string_word(destination)) =
- (((bit_string_word(destination)) & ~mask) |
- (((bit_string_word(source)) << offset1) & mask));
+ long dest_buffer, mask1, mask2;
+
+ {
+ long mask;
+
+ mask = (any_mask (head, offset1));
+ dest_buffer =
+ (((bit_string_word (destination)) & ~mask)
+ | (((* (dec_bit_string_ptr (source))) << offset1) & mask));
+ }
+ nbits -= head;
+ mask1 = (low_mask (offset1));
+ mask2 = (any_mask (offset2, offset1));
+ {
+ long nwords;
+
+ nwords = (nbits / POINTER_LENGTH);
+ if (nwords > 0)
+ dest_buffer &= mask2;
+ for (; (nwords > 0); nwords -= 1)
+ {
+ (* (dec_bit_string_ptr (destination))) =
+ (dest_buffer |
+ (((bit_string_word (source)) >> offset2) & mask1));
+ dest_buffer = ((* (dec_bit_string_ptr (source))) << offset1);
+ }
+ }
+\f
+ {
+ long tail;
+
+ tail = (nbits % POINTER_LENGTH);
+ if (tail <= offset1)
+ {
+ (bit_string_word (destination)) =
+ (dest_buffer |
+ ((bit_string_word (destination)) &
+ (low_mask (offset1 - tail))) |
+ (((bit_string_word (source)) >> offset2) &
+ (any_mask (tail, (offset1 - tail)))));
+ }
+ else
+ {
+ long mask;
+
+ (* (dec_bit_string_ptr (destination))) =
+ (dest_buffer |
+ (((bit_string_word (source)) >> offset2) & mask1));
+ mask = (low_mask (POINTER_LENGTH - tail));
+ (bit_string_word (destination)) =
+ (((bit_string_word (destination)) & (~ mask)) |
+ (((bit_string_word (source)) << offset1) & mask));
+ }
+ }
}
- }
}
- }
}
\f
/* Integer <-> Bit-string Conversions */
long
-count_significant_bits( number, start)
+count_significant_bits (number, start)
long number, start;
{
long significant_bits, i;
significant_bits = start;
for (i = (1 << (start - 1)); (i >= 0); i >>= 1)
- {
- if (number >= i)
- break;
- significant_bits -= 1;
- }
- return significant_bits;
+ {
+ if (number >= i)
+ break;
+ significant_bits -= 1;
+ }
+ return (significant_bits);
}
long
-long_significant_bits( number)
+long_significant_bits (number)
long number;
{
- if (number < 0)
- return ULONG_SIZE;
- else
- return count_significant_bits( number, (ULONG_SIZE - 1));
+ return
+ ((number < 0)
+ ? ULONG_SIZE
+ : (count_significant_bits (number, (ULONG_SIZE - 1))));
}
-
+\f
Pointer
-zero_to_bit_string( length)
+zero_to_bit_string (length)
long length;
{
Pointer result;
error_bad_range_arg (2);
if (number == 0)
- {
- return (zero_to_bit_string (length));
- }
+ {
+ return (zero_to_bit_string (length));
+ }
else
- {
- Pointer result;
-
- if (length < (long_significant_bits (number)))
- error_bad_range_arg (2);
- result = (zero_to_bit_string (length));
- bit_string_lsw(result) = number;
- return (result);
- }
+ {
+ Pointer result;
+
+ if (length < (long_significant_bits (number)))
+ error_bad_range_arg (2);
+ result = (zero_to_bit_string (length));
+ (bit_string_lsw (result)) = number;
+ return (result);
+ }
}
\f
/* The bignum <-> bit-string coercion procedures use the following pun:
if (ndigits == 0)
zero_to_bit_string (length);
else
- {
- Pointer result;
- bigdigit *scan1, *scan2;
-
- if (length <
- (count_significant_bits ((*(Bignum_Top (bigptr))), SHIFT)
- + (SHIFT * (ndigits - 1))))
- error_bad_range_arg (2);
- result = (zero_to_bit_string (length));
- scan1 = (Bignum_Bottom (bigptr));
- scan2 = ((bigdigit *) (bit_string_low_ptr (result)));
- for (; (ndigits > 0); ndigits -= 1)
- *(inc_bit_string_ptr(scan2)) = *scan1++;
- return (result);
- }
+ {
+ Pointer result;
+ bigdigit *scan1, *scan2;
+
+ if (length <
+ (count_significant_bits ((* (Bignum_Top (bigptr))), SHIFT)
+ + (SHIFT * (ndigits - 1))))
+ error_bad_range_arg (2);
+ result = (zero_to_bit_string (length));
+ scan1 = (Bignum_Bottom (bigptr));
+ scan2 = ((bigdigit *) (bit_string_low_ptr (result)));
+ for (; (ndigits > 0); ndigits -= 1)
+ (* (inc_bit_string_ptr (scan2))) = (*scan1++);
+ return (result);
+ }
}
\f
Pointer
bigdigit *bignum;
ndigits = ((nbits + (SHIFT - 1)) / SHIFT);
- align_ndigits = Align( ndigits);
- Primitive_GC_If_Needed( align_ndigits);
- bignum = BIGNUM( Free);
+ align_ndigits = (Align (ndigits));
+ Primitive_GC_If_Needed (align_ndigits);
+ bignum = (BIGNUM (Free));
Free += align_ndigits;
- Prepare_Header( bignum, ndigits, POSITIVE);
+ Prepare_Header (bignum, ndigits, POSITIVE);
- scan1 = ((bigdigit *) bit_string_low_ptr( bitstr));
- scan2 = Bignum_Bottom( bignum);
- while (--ndigits > 0)
- *scan2++ = *(inc_bit_string_ptr(scan1));
+ scan1 = ((bigdigit *) (bit_string_low_ptr (bitstr)));
+ scan2 = (Bignum_Bottom (bignum));
+ while ((--ndigits) > 0)
+ (*scan2++) = (* (inc_bit_string_ptr (scan1)));
nbits = (nbits % SHIFT);
- if (nbits == 0)
- *scan2 = (*(inc_bit_string_ptr(scan1)));
- else
- *scan2 = ((*(inc_bit_string_ptr(scan1))) & low_mask( nbits));
+ (*scan2) =
+ ((nbits == 0)
+ ? (* (inc_bit_string_ptr (scan1)))
+ : ((* (inc_bit_string_ptr (scan1))) & (low_mask (nbits))));
return (Make_Pointer (TC_BIG_FIXNUM, ((Pointer *) bignum)));
}
a bit-string of length LENGTH. If INTEGER is too large, an
error is signalled. */
-Built_In_Primitive( Prim_unsigned_to_bit_string, 2,
- "UNSIGNED-INTEGER->BIT-STRING", 0xDC)
-Define_Primitive( Prim_unsigned_to_bit_string, 2,
- "UNSIGNED-INTEGER->BIT-STRING")
+DEFINE_PRIMITIVE ("UNSIGNED-INTEGER->BIT-STRING", Prim_unsigned_to_bit_string, 2)
{
- long length;
- Primitive_2_Args ();
+ fast long length;
+ fast Pointer object;
+ PRIMITIVE_HEADER (2);
length = (arg_nonnegative_integer (1));
+ object = (ARG_REF (2));
- if (FIXNUM_P (Arg2))
- {
- if (FIXNUM_NEGATIVE_P (Arg2))
- error_bad_range_arg (2);
- PRIMITIVE_RETURN( long_to_bit_string (length,
- (UNSIGNED_FIXNUM_VALUE (Arg2))));
- }
- if (BIGNUM_P (Arg2))
- PRIMITIVE_RETURN( bignum_to_bit_string (length, Arg2));
+ if (FIXNUM_P (object))
+ {
+ if (FIXNUM_NEGATIVE_P (object))
+ error_bad_range_arg (2);
+ PRIMITIVE_RETURN (long_to_bit_string (length,
+ (UNSIGNED_FIXNUM_VALUE (object))));
+ }
+ if (BIGNUM_P (object))
+ PRIMITIVE_RETURN (bignum_to_bit_string (length, object));
error_wrong_type_arg (2);
}
\f
BIT-STRING is converted to the appropriate non-negative integer.
This operation is the inverse of `unsigned-integer->bit-string'. */
-Built_In_Primitive( Prim_bit_string_to_unsigned, 1,
- "BIT-STRING->UNSIGNED-INTEGER", 0xDD)
-Define_Primitive( Prim_bit_string_to_unsigned, 1,
- "BIT-STRING->UNSIGNED-INTEGER")
+DEFINE_PRIMITIVE ("BIT-STRING->UNSIGNED-INTEGER", Prim_bit_string_to_unsigned, 1)
{
- fast Pointer *scan;
+ fast Pointer bit_string, *scan;
long nwords, nbits, word;
- Primitive_1_Arg();
+ PRIMITIVE_HEADER (1);
CHECK_ARG (1, BIT_STRING_P);
+ bit_string = (ARG_REF (1));
/* Count the number of significant bits.*/
- scan = bit_string_high_ptr( Arg1);
- nbits = (bit_string_length( Arg1) % POINTER_LENGTH);
- word = ((nbits > 0) ?
- (*(dec_bit_string_ptr(scan)) & low_mask( nbits)) :
- *(dec_bit_string_ptr(scan)));
- for (nwords = (Vector_Length( Arg1) - 1); (nwords > 0); nwords -= 1)
- {
- if (word != 0)
- break;
- else
- word = *(dec_bit_string_ptr(scan));
- }
+ scan = (bit_string_high_ptr (bit_string));
+ nbits = ((bit_string_length (bit_string)) % POINTER_LENGTH);
+ word =
+ ((nbits > 0)
+ ? ((* (dec_bit_string_ptr (scan))) & (low_mask (nbits)))
+ : (* (dec_bit_string_ptr (scan))));
+ for (nwords = ((Vector_Length (bit_string)) - 1); (nwords > 0); nwords -= 1)
+ {
+ if (word != 0)
+ break;
+ word = (* (dec_bit_string_ptr (scan)));
+ }
if (nwords == 0)
- PRIMITIVE_RETURN( Make_Unsigned_Fixnum(0));
- nbits = (((nwords - 1) * POINTER_LENGTH) + long_significant_bits( word));
+ PRIMITIVE_RETURN (Make_Unsigned_Fixnum (0));
+ nbits = (((nwords - 1) * POINTER_LENGTH) + (long_significant_bits (word)));
- if (nbits < FIXNUM_LENGTH)
- PRIMITIVE_RETURN( (Make_Unsigned_Fixnum( word)));
- else
- PRIMITIVE_RETURN( bit_string_to_bignum(nbits, Arg1));
+ PRIMITIVE_RETURN
+ ((nbits < FIXNUM_LENGTH)
+ ? (Make_Unsigned_Fixnum (word))
+ : (bit_string_to_bignum (nbits, bit_string)));
}
\f
-#define read_bits_initialize() \
+#define READ_BITS_INITIALIZE() \
+ Pointer bit_string; \
long end, end_mod, offset; \
Pointer *start; \
- Primitive_3_Args (); \
+ PRIMITIVE_HEADER (3); \
\
CHECK_ARG (3, BIT_STRING_P); \
- end = (bit_string_length (Arg3)); \
+ bit_string = (ARG_REF (3)); \
+ end = (bit_string_length (bit_string)); \
end_mod = (end % POINTER_LENGTH); \
offset = (arg_nonnegative_integer (2)); \
- start = read_bits_ptr(Arg1, offset, end); \
- compute_read_bits_offset(offset, end)
+ start = (read_bits_ptr ((ARG_REF (1)), offset, end)); \
+ compute_read_bits_offset (offset, end)
/* (READ-BITS! pointer offset bit-string)
Read the contents of memory at the address (POINTER,OFFSET)
into BIT-STRING. */
-Built_In_Primitive (Prim_read_bits_x, 3, "READ-BITS!", 0xDF)
-Define_Primitive (Prim_read_bits_x, 3, "READ-BITS!")
+DEFINE_PRIMITIVE ("READ-BITS!", Prim_read_bits_x, 3)
{
- read_bits_initialize();
+ READ_BITS_INITIALIZE ();
copy_bits (start,
offset,
- (Nth_Vector_Loc (Arg3, (index_to_word (Arg3, (end - 1))))),
+ (Nth_Vector_Loc (bit_string,
+ (index_to_word (bit_string, (end - 1))))),
((end_mod == 0) ? 0 : (POINTER_LENGTH - end_mod)),
end);
- PRIMITIVE_RETURN( NIL);
+ PRIMITIVE_RETURN (NIL);
}
/* (WRITE-BITS! pointer offset bit-string)
Write the contents of BIT-STRING in memory at the address
(POINTER,OFFSET). */
-Built_In_Primitive (Prim_write_bits_x, 3, "WRITE-BITS!", 0xE0)
-Define_Primitive (Prim_write_bits_x, 3, "WRITE-BITS!")
+DEFINE_PRIMITIVE ("WRITE-BITS!", Prim_write_bits_x, 3)
{
- read_bits_initialize();
+ READ_BITS_INITIALIZE ();
- copy_bits ((Nth_Vector_Loc (Arg3, (index_to_word (Arg3, (end - 1))))),
+ copy_bits ((Nth_Vector_Loc (bit_string,
+ (index_to_word (bit_string, (end - 1))))),
((end_mod == 0) ? 0 : (POINTER_LENGTH - end_mod)),
start,
offset,
end);
- PRIMITIVE_RETURN( NIL);
+ PRIMITIVE_RETURN (NIL);
}
\f
/* Search Primitives */
-#define substring_find_initialize() \
+#define SUBSTRING_FIND_INITIALIZE() \
+ Pointer bit_string; \
long start, end; \
long word, bit, end_word, end_bit, mask; \
Pointer *scan; \
- Primitive_3_Args (); \
+ PRIMITIVE_HEADER (3); \
\
CHECK_ARG (1, BIT_STRING_P); \
start = (arg_nonnegative_integer (2)); \
end = (arg_nonnegative_integer (3)); \
\
- if (end > (bit_string_length (Arg1))) \
+ if (end > (bit_string_length (bit_string))) \
error_bad_range_arg (3); \
if (start > end) \
error_bad_range_arg (2); \
\
if (start == end) \
- return (NIL);
+ PRIMITIVE_RETURN (NIL)
-#define substring_find_next_initialize() \
- substring_find_initialize (); \
- word = (index_to_word (Arg1, start)); \
+#define SUBSTRING_FIND_NEXT_INITIALIZE() \
+ SUBSTRING_FIND_INITIALIZE (); \
+ word = (index_to_word (bit_string, start)); \
bit = (start % POINTER_LENGTH); \
- end_word = (index_to_word (Arg1, (end - 1))); \
+ end_word = (index_to_word (bit_string, (end - 1))); \
end_bit = (((end - 1) % POINTER_LENGTH) + 1); \
- scan = (Nth_Vector_Loc (Arg1, word));
+ scan = (Nth_Vector_Loc (bit_string, word))
-#define find_next_set_loop(init_bit) \
+#define FIND_NEXT_SET_LOOP(init_bit) \
{ \
bit = (init_bit); \
mask = (1 << (init_bit)); \
- while (1) \
+ while (true) \
{ \
- if ((bit_string_word(scan)) & mask) goto win; \
+ if (((bit_string_word (scan)) & mask) != 0) \
+ goto win; \
bit += 1; \
mask <<= 1; \
} \
}
\f
-Built_In_Primitive (Prim_bitstr_find_next_set_bit, 3,
- "BIT-SUBSTRING-FIND-NEXT-SET-BIT", 0xDA)
-Define_Primitive (Prim_bitstr_find_next_set_bit, 3,
- "BIT-SUBSTRING-FIND-NEXT-SET-BIT")
+DEFINE_PRIMITIVE ("BIT-SUBSTRING-FIND-NEXT-SET-BIT", Prim_bitstr_find_next_set_bit, 3)
{
- substring_find_next_initialize ();
+ SUBSTRING_FIND_NEXT_INITIALIZE ();
if (word == end_word)
{
- if ((((end_bit - bit) == POINTER_LENGTH) && (bit_string_word(scan)))
- || ((bit_string_word(scan)) & (any_mask ((end_bit - bit), bit))))
- find_next_set_loop (bit);
- PRIMITIVE_RETURN( NIL);
+ if ((((end_bit - bit) == POINTER_LENGTH) &&
+ ((bit_string_word (scan)) != 0)) ||
+ (((bit_string_word (scan)) & (any_mask ((end_bit - bit), bit)))
+ != 0))
+ {
+ FIND_NEXT_SET_LOOP (bit);
+ }
+ PRIMITIVE_RETURN (NIL);
+ }
+ else if (((bit_string_word (scan)) &
+ ((bit == 0) ? (~ 0) : (any_mask ((POINTER_LENGTH - bit), bit))))
+ != 0)
+ {
+ FIND_NEXT_SET_LOOP (bit);
}
- else if ((bit_string_word(scan)) &
- ((bit == 0) ? (~ 0) : (any_mask ((POINTER_LENGTH - bit), bit))))
- find_next_set_loop (bit);
- while (--word > end_word)
- {
- if (*(inc_bit_string_ptr(scan)))
- find_next_set_loop (0);
- }
+ while ((--word) > end_word)
+ if ((* (inc_bit_string_ptr (scan))) != 0)
+ {
+ FIND_NEXT_SET_LOOP (0);
+ }
- if ((*(inc_bit_string_ptr(scan))) &
- ((end_bit == POINTER_LENGTH) ? (~ 0) : (low_mask (end_bit))))
- find_next_set_loop (0);
+ if (((* (inc_bit_string_ptr (scan))) &
+ ((end_bit == POINTER_LENGTH) ? (~ 0) : (low_mask (end_bit))))
+ != 0)
+ {
+ FIND_NEXT_SET_LOOP (0);
+ }
- PRIMITIVE_RETURN( NIL);
+ PRIMITIVE_RETURN (NIL);
win:
- PRIMITIVE_RETURN( index_pair_to_bit_fixnum (Arg1, word, bit));
+ PRIMITIVE_RETURN (index_pair_to_bit_fixnum (bit_string, word, bit));
}
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/boot.c,v 9.41 1987/11/18 19:31:34 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/boot.c,v 9.42 1987/11/23 05:16:31 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
#include "scheme.h"
#include "primitive.h"
#include "version.h"
-#include "character.h"
+#include "char.h"
+#include "string.h"
#ifndef islower
#include <ctype.h>
#endif
#define ID_OS_NAME 8 /* OS name (string) */
#define ID_OS_VARIANT 9 /* OS variant (string) */
-Built_In_Primitive (Prim_Microcode_Identify, 0, "MICROCODE-IDENTIFY", 0xE5)
-Define_Primitive (Prim_Microcode_Identify, 0, "MICROCODE-IDENTIFY")
+DEFINE_PRIMITIVE ("MICROCODE-IDENTIFY", Prim_Microcode_Identify, 0)
{
- Pointer *Result;
- long i;
- Primitive_0_Args ();
-
- Primitive_GC_If_Needed (IDENTITY_LENGTH + VECTOR_DATA);
- Result = Free;
- *Free++ = (Make_Non_Pointer (TC_MANIFEST_VECTOR, IDENTITY_LENGTH));
- for (i = 0; (i < IDENTITY_LENGTH); i += 1)
- {
- *Free++ = NIL;
- }
- Result[(ID_RELEASE + VECTOR_DATA)]
- = (C_String_To_Scheme_String (RELEASE));
- Result[(ID_MICRO_VERSION + VECTOR_DATA)]
- = (Make_Unsigned_Fixnum (VERSION));
- Result[(ID_MICRO_MOD + VECTOR_DATA)]
- = (Make_Unsigned_Fixnum (SUBVERSION));
- Result[(ID_PRINTER_WIDTH + VECTOR_DATA)]
- = (Make_Unsigned_Fixnum (NColumns ()));
- Result[(ID_PRINTER_LENGTH + VECTOR_DATA)]
- = (Make_Unsigned_Fixnum (NLines ()));
- Result[(ID_NEW_LINE_CHARACTER + VECTOR_DATA)]
- = (c_char_to_scheme_char ('\n'));
- Result[(ID_FLONUM_PRECISION + VECTOR_DATA)]
- = (Make_Unsigned_Fixnum (FLONUM_MANTISSA_BITS));
- Result[(ID_FLONUM_EXPONENT + VECTOR_DATA)]
- = (Make_Unsigned_Fixnum (FLONUM_EXPT_SIZE));
- Result[(ID_OS_NAME + VECTOR_DATA)]
- = (C_String_To_Scheme_String (OS_Name));
- Result[(ID_OS_VARIANT + VECTOR_DATA)]
- = (C_String_To_Scheme_String (OS_Variant));
- PRIMITIVE_RETURN(Make_Pointer (TC_VECTOR, Result));
+ extern Pointer make_vector ();
+ fast Pointer Result;
+ PRIMITIVE_HEADER (0);
+
+ Result = (make_vector (IDENTITY_LENGTH, NIL));
+ User_Vector_Set
+ (Result, ID_RELEASE, (C_String_To_Scheme_String (RELEASE)));
+ User_Vector_Set
+ (Result, ID_MICRO_VERSION, (MAKE_UNSIGNED_FIXNUM (VERSION)));
+ User_Vector_Set
+ (Result, ID_MICRO_MOD, (MAKE_UNSIGNED_FIXNUM (SUBVERSION)));
+ User_Vector_Set
+ (Result, ID_PRINTER_WIDTH, (MAKE_UNSIGNED_FIXNUM (NColumns ())));
+ User_Vector_Set
+ (Result, ID_PRINTER_LENGTH, (MAKE_UNSIGNED_FIXNUM (NLines ())));
+ User_Vector_Set
+ (Result, ID_NEW_LINE_CHARACTER, (c_char_to_scheme_char ('\n')));
+ User_Vector_Set
+ (Result, ID_FLONUM_PRECISION,
+ (MAKE_UNSIGNED_FIXNUM (FLONUM_MANTISSA_BITS)));
+ User_Vector_Set
+ (Result, ID_FLONUM_EXPONENT, (MAKE_UNSIGNED_FIXNUM (FLONUM_EXPT_SIZE)));
+ User_Vector_Set
+ (Result, ID_OS_NAME, (C_String_To_Scheme_String (OS_Name)));
+ User_Vector_Set
+ (Result, ID_OS_VARIANT, (C_String_To_Scheme_String (OS_Variant)));
+ PRIMITIVE_RETURN (Result);
}
\f
-Built_In_Primitive(Prim_Microcode_Tables_Filename,
- 0, "MICROCODE-TABLES-FILENAME", 0x180)
-Define_Primitive(Prim_Microcode_Tables_Filename,
- 0, "MICROCODE-TABLES-FILENAME")
+DEFINE_PRIMITIVE ("MICROCODE-TABLES-FILENAME", Prim_Microcode_Tables_Filename, 0)
{
fast char *From, *To;
char *Prefix, *Suffix;
fast long Count;
long position;
+ extern Pointer allocate_string ();
Pointer Result;
- Primitive_0_Args();
+ PRIMITIVE_HEADER (0);
- if ((((position = Parse_Option("-utabmd", Saved_argc, Saved_argv, true))
+ if ((((position = (Parse_Option ("-utabmd", Saved_argc, Saved_argv, true)))
!= NOT_THERE) &&
(position != (Saved_argc - 1))) ||
- (((position = Parse_Option("-utab", Saved_argc, Saved_argv, true))
+ (((position = (Parse_Option ("-utab", Saved_argc, Saved_argv, true)))
!= NOT_THERE) &&
(position != (Saved_argc - 1))))
- {
- Prefix = "";
- Suffix = Saved_argv[position + 1];
- }
+ {
+ Prefix = "";
+ Suffix = (Saved_argv [(position + 1)]);
+ }
else
- {
- Prefix = SCHEME_SOURCES_PATH;
- Suffix = UCODE_TABLES_FILENAME;
- }
-\f
+ {
+ Prefix = SCHEME_SOURCES_PATH;
+ Suffix = UCODE_TABLES_FILENAME;
+ }
+
/* Find the length of the combined string, and allocate. */
Count = 0;
- for (From = Prefix; *From++ != '\0'; )
- {
+ for (From = Prefix; ((*From++) != '\0'); )
Count += 1;
- }
- for (From = Suffix; *From++ != '\0'; )
- {
+ for (From = Suffix; ((*From++) != '\0'); )
Count += 1;
- }
- Primitive_GC_If_Needed(STRING_CHARS +
- ((Count + sizeof(Pointer)) /
- sizeof(Pointer)));
/* Append both substrings. */
- Result = Make_Pointer(TC_CHARACTER_STRING, Free);
- To = (char *) &(Free[STRING_CHARS]);
- for (From = &(Prefix[0]); *From != '\0'; )
- {
- *To++ = *From++;
- }
- for (From = &(Suffix[0]); *From != '\0'; )
- {
- *To++ = *From++;
- }
- *To = '\0';
- Free += STRING_CHARS + ((Count + sizeof(Pointer)) / sizeof(Pointer));
- Vector_Set(Result, STRING_LENGTH, ((Pointer) Count));
- Vector_Set(Result, STRING_HEADER,
- Make_Non_Pointer(TC_MANIFEST_NM_VECTOR,
- ((Free - Get_Pointer(Result)) - 1)));
- PRIMITIVE_RETURN(Result);
+ Result = (allocate_string (Count));
+ To = (string_pointer (Result, 0));
+ for (From = (& (Prefix [0])); ((*From) != '\0'); )
+ (*To++) = (*From++);
+ for (From = (& (Suffix [0])); ((*From) != '\0'); )
+ (*To++) = (*From++);
+ PRIMITIVE_RETURN (Result);
}
\f
-Built_In_Primitive(Prim_Get_Command_Line, 0, "GET-COMMAND-LINE", 0x25)
-Define_Primitive(Prim_Get_Command_Line, 0, "GET-COMMAND-LINE")
+DEFINE_PRIMITIVE ("GET-COMMAND-LINE", Prim_Get_Command_Line, 0)
{
fast int i;
- Pointer result;
- Primitive_0_Args();
-
- Primitive_GC_If_Needed(1 + Saved_argc);
-
- result = Make_Pointer(TC_VECTOR, Free);
- *Free = Make_Non_Pointer(TC_MANIFEST_VECTOR, Saved_argc);
- Free += (1 + Saved_argc);
-
- for (i = 0; i < Saved_argc; i++)
- {
- User_Vector_Set(result, i, C_String_To_Scheme_String(Saved_argv[i]));
- }
- PRIMITIVE_RETURN(result);
+ fast Pointer result;
+ extern Pointer allocate_marked_vector ();
+ PRIMITIVE_HEADER (0);
+
+ result = (allocate_marked_vector (TC_VECTOR, Saved_argc, true));
+ for (i = 0; (i < Saved_argc); i += 1)
+ User_Vector_Set (result, i, (C_String_To_Scheme_String (Saved_argv [i])));
+ PRIMITIVE_RETURN (result);
}
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/char.c,v 9.23 1987/11/17 08:07:53 jinx Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/char.c,v 9.24 1987/11/23 05:16:52 cph Rel $ */
/* Character primitives. */
#include "scheme.h"
#include "primitive.h"
-#include "character.h"
+#include "char.h"
#include <ctype.h>
\f
long
return (ascii);
}
\f
-Built_In_Primitive (Prim_Make_Char, 2, "MAKE-CHAR", 0x14)
-Define_Primitive (Prim_Make_Char, 2, "MAKE-CHAR")
+DEFINE_PRIMITIVE ("MAKE-CHAR", Prim_Make_Char, 2)
{
long bucky_bits, code;
- Primitive_2_Args ();
+ PRIMITIVE_HEADER (2);
code = (arg_index_integer (1, MAX_CODE));
bucky_bits = (arg_index_integer (2, MAX_BITS));
- return (make_char (bucky_bits, code));
+ PRIMITIVE_RETURN (make_char (bucky_bits, code));
}
-Built_In_Primitive (Prim_Char_Bits, 1, "CHAR-BITS", 0x15)
-Define_Primitive (Prim_Char_Bits, 1, "CHAR-BITS")
+DEFINE_PRIMITIVE ("CHAR-BITS", Prim_Char_Bits, 1)
{
- Primitive_1_Arg ();
+ PRIMITIVE_HEADER (1);
CHECK_ARG (1, CHARACTER_P);
- return (MAKE_UNSIGNED_FIXNUM (char_bits (Arg1)));
+ PRIMITIVE_RETURN (MAKE_UNSIGNED_FIXNUM (char_bits (ARG_REF (1))));
}
-Built_In_Primitive (Prim_Char_Code, 1, "CHAR-CODE", 0x17)
-Define_Primitive (Prim_Char_Code, 1, "CHAR-CODE")
+DEFINE_PRIMITIVE ("CHAR-CODE", Prim_Char_Code, 1)
{
- Primitive_1_Arg ();
+ PRIMITIVE_HEADER (1);
CHECK_ARG (1, CHARACTER_P);
- return (MAKE_UNSIGNED_FIXNUM (char_code (Arg1)));
+ PRIMITIVE_RETURN (MAKE_UNSIGNED_FIXNUM (char_code (ARG_REF (1))));
}
-Built_In_Primitive (Prim_Char_To_Integer, 1, "CHAR->INTEGER", 0x1B)
-Define_Primitive (Prim_Char_To_Integer, 1, "CHAR->INTEGER")
+DEFINE_PRIMITIVE ("CHAR->INTEGER", Prim_Char_To_Integer, 1)
{
- Primitive_1_Arg ();
+ PRIMITIVE_HEADER (1);
CHECK_ARG (1, CHARACTER_P);
- return (MAKE_UNSIGNED_FIXNUM (Arg1 & MASK_EXTNDD_CHAR));
+ PRIMITIVE_RETURN (MAKE_UNSIGNED_FIXNUM ((ARG_REF (1)) & MASK_EXTNDD_CHAR));
}
-Built_In_Primitive (Prim_Integer_To_Char, 1, "INTEGER->CHAR", 0x34)
-Define_Primitive (Prim_Integer_To_Char, 1, "INTEGER->CHAR")
+DEFINE_PRIMITIVE ("INTEGER->CHAR", Prim_Integer_To_Char, 1)
{
- Primitive_1_Arg ();
+ PRIMITIVE_HEADER (1);
- return
+ PRIMITIVE_RETURN
(Make_Non_Pointer (TC_CHARACTER,
(arg_index_integer (1, MAX_EXTNDD_CHAR))));
}
return ((islower (c)) ? ((c - 'a') + 'A') : c);
}
-Built_In_Primitive (Prim_Char_Downcase, 1, "CHAR-DOWNCASE", 0x35)
-Define_Primitive (Prim_Char_Downcase, 1, "CHAR-DOWNCASE")
+DEFINE_PRIMITIVE ("CHAR-DOWNCASE", Prim_Char_Downcase, 1)
{
- Primitive_1_Arg ();
+ PRIMITIVE_HEADER (1);
CHECK_ARG (1, CHARACTER_P);
- return (make_char ((char_bits (Arg1)), (char_downcase (char_code (Arg1)))));
+ PRIMITIVE_RETURN
+ (make_char ((char_bits (ARG_REF (1))),
+ (char_downcase (char_code (ARG_REF (1))))));
}
-Built_In_Primitive (Prim_Char_Upcase, 1, "CHAR-UPCASE", 0x36)
-Define_Primitive (Prim_Char_Upcase, 1, "CHAR-UPCASE")
+DEFINE_PRIMITIVE ("CHAR-UPCASE", Prim_Char_Upcase, 1)
{
- Primitive_1_Arg ();
+ PRIMITIVE_HEADER (1);
CHECK_ARG (1, CHARACTER_P);
- return (make_char ((char_bits (Arg1)), (char_upcase (char_code (Arg1)))));
+ PRIMITIVE_RETURN
+ (make_char ((char_bits (ARG_REF (1))),
+ (char_upcase (char_code (ARG_REF (1))))));
}
-
-Built_In_Primitive (Prim_Ascii_To_Char, 1, "ASCII->CHAR", 0x37)
-Define_Primitive (Prim_Ascii_To_Char, 1, "ASCII->CHAR")
+\f
+DEFINE_PRIMITIVE ("ASCII->CHAR", Prim_Ascii_To_Char, 1)
{
- Primitive_1_Arg ();
+ PRIMITIVE_HEADER (1);
- return (c_char_to_scheme_char (arg_ascii_integer (1)));
+ PRIMITIVE_RETURN (c_char_to_scheme_char (arg_ascii_integer (1)));
}
-Built_In_Primitive (Prim_Char_To_Ascii, 1, "CHAR->ASCII", 0x39)
-Define_Primitive (Prim_Char_To_Ascii, 1, "CHAR->ASCII")
+DEFINE_PRIMITIVE ("CHAR->ASCII", Prim_Char_To_Ascii, 1)
{
- Primitive_1_Arg ();
+ PRIMITIVE_HEADER (1);
- return (MAKE_UNSIGNED_FIXNUM (arg_ascii_char (1)));
+ PRIMITIVE_RETURN (MAKE_UNSIGNED_FIXNUM (arg_ascii_char (1)));
}
-Built_In_Primitive (Prim_Char_Ascii_P, 1, "CHAR-ASCII?", 0x38)
-Define_Primitive (Prim_Char_Ascii_P, 1, "CHAR-ASCII?")
+DEFINE_PRIMITIVE ("CHAR-ASCII?", Prim_Char_Ascii_P, 1)
{
long ascii;
- Primitive_1_Arg ();
+ PRIMITIVE_HEADER (1);
CHECK_ARG (1, CHARACTER_P);
- ascii = (scheme_char_to_c_char (Arg1));
- return ((ascii == NOT_ASCII) ? NIL : (MAKE_UNSIGNED_FIXNUM (ascii)));
+ ascii = (scheme_char_to_c_char (ARG_REF (1)));
+ PRIMITIVE_RETURN
+ ((ascii == NOT_ASCII) ? NIL : (MAKE_UNSIGNED_FIXNUM (ascii)));
}
\f
forward Boolean ascii_control_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/findprim.c,v 9.29 1987/11/17 08:04:01 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/findprim.c,v 9.30 1987/11/23 05:11:39 cph Exp $
*
* Preprocessor to find and declare defined primitives.
*
static boolean Built_in_p;
static long Built_in_table_size;
-static char *The_Token;
+static char *token_array[4];
static char Default_Token[] = "Define_Primitive";
+static char default_token_alternate[] = "DEFINE_PRIMITIVE";
static char Built_in_Token[] = "Built_In_Primitive";
static char External_Token[] = "Define_Primitive";
+typedef pseudo_void (*TOKEN_PROCESSOR) ();
+static TOKEN_PROCESSOR token_processors[4];
+
static char *The_Kind;
static char Default_Kind[] = "Primitive";
static char Built_in_Kind[] = "Primitive";
static FILE *input, *output;
static char *name;
static char *file_name;
-
-static pseudo_void (*create_entry)();
\f
main(argc, argv)
int argc;
}
}
\f
-#define DONE 0
-#define FOUND 1
-
/* Search for tokens and when found, create primitive entries. */
void
process()
{
- int scan();
+ TOKEN_PROCESSOR scan();
+ TOKEN_PROCESSOR processor;
- while ((scan() != DONE))
- {
- dprintf("Process: place found.%s\n", "");
- (*create_entry)();
- }
+ while (TRUE)
+ {
+ processor = (scan ());
+ if (processor == NULL)
+ break;
+ dprintf("Process: place found.%s\n", "");
+ (*processor)();
+ }
return;
}
* currently the token must always begin a line.
*/
-int
-scan()
+TOKEN_PROCESSOR
+scan ()
{
register int c;
- register char *temp;
+ char compare_buffer[1024];
c = '\n';
while(c != EOF)
else if (c != '\n') break;
case '\n':
- temp = &The_Token[0];
- while ((c = getc(input)) == *temp++) {}
- if (temp[-1] == '\0') return FOUND;
- ungetc(c, input);
- break;
+ {
+ {
+ register char *scan_buffer;
+
+ scan_buffer = (& (compare_buffer [0]));
+ while (TRUE)
+ {
+ c = (getc (input));
+ if (c == EOF)
+ return (NULL);
+ else if ((isalnum (c)) || (c == '_'))
+ (*scan_buffer++) = c;
+ else
+ {
+ ungetc (c, input);
+ (*scan_buffer++) = '\0';
+ break;
+ }
+ }
+ }
+ {
+ register char **scan_tokens;
+
+ for (scan_tokens = (& (token_array [0]));
+ ((*scan_tokens) != NULL);
+ scan_tokens += 1)
+ if ((strcmp ((& (compare_buffer [0])), (*scan_tokens))) == 0)
+ return (token_processors [(scan_tokens - token_array)]);
+ }
+ break;
+ }
default: {}
}
c = getc(input);
}
- return DONE;
+ return (NULL);
}
\f
boolean
return;
}
+pseudo_void
+create_alternate_entry()
+{
+ if (buffer_index >= BUFFER_SIZE)
+ {
+ fprintf(stderr, "Error: %s cannot handle so many primitives.\n", name);
+ fprintf(stderr, "Recompile %s with BUFFER_SIZE larger than %d.\n",
+ name, BUFFER_SIZE);
+ error_exit(FALSE);
+ }
+ scan_to_token_start();
+ copy_symbol((Data_Buffer[buffer_index]).Scheme_Name, &S_Size);
+ scan_to_token_start();
+ copy_token((Data_Buffer[buffer_index]).C_Name, &C_Size);
+ scan_to_token_start();
+ copy_token((Data_Buffer[buffer_index]).Arity, &A_Size);
+ copy_string(file_name, (Data_Buffer[buffer_index]).File_Name, &F_Size);
+ Result_Buffer[buffer_index] = &Data_Buffer[buffer_index];
+ buffer_index++;
+ return;
+}
+\f
void
initialize_external()
{
Built_in_p = FALSE;
- The_Token = &External_Token[0];
+ (token_array [0]) = &External_Token[0];
+ (token_array [1]) = NULL;
+ (token_processors [0]) = create_normal_entry;
+ (token_processors [1]) = NULL;
The_Kind = &External_Kind[0];
The_Variable = &External_Variable[0];
- create_entry = create_normal_entry;
return;
}
initialize_default()
{
Built_in_p = FALSE;
- The_Token = &Default_Token[0];
+ (token_array [0]) = &Default_Token[0];
+ (token_array [1]) = (& (default_token_alternate [0]));
+ (token_array [2]) = NULL;
+ (token_processors [0]) = create_normal_entry;
+ (token_processors [1]) = create_alternate_entry;
+ (token_processors [2]) = NULL;
The_Kind = &Default_Kind[0];
The_Variable = &Default_Variable[0];
- create_entry = create_normal_entry;
return;
}
fprintf(stderr, "Recompile with a larger value of BUFFER_SIZE.\n");
error_exit(FALSE);
}
- The_Token = &Built_in_Token[0];
+ (token_array [0]) = &Built_in_Token[0];
+ (token_array [1]) = NULL;
+ (token_processors [0]) = create_builtin_entry;
+ (token_processors [1]) = NULL;
The_Kind = &Built_in_Kind[0];
The_Variable = &Built_in_Variable[0];
- create_entry = create_builtin_entry;
for (index = Built_in_table_size; --index >= 0; )
{
Result_Buffer[index] = &Inexistent_Entry;
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/intern.c,v 9.43 1987/11/17 08:12:53 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/intern.c,v 9.44 1987/11/23 05:17:30 cph Rel $ */
- Utilities for manipulating symbols.
- */
+/* Utilities for manipulating symbols. */
#include "scheme.h"
#include "primitive.h"
#include "trap.h"
-#include "stringprim.h"
+#include "string.h"
\f
/* Hashing strings and character lists. */
}
Boolean
-string_equal(String1, String2)
+string_equal (String1, String2)
Pointer String1, String2;
{
fast char *S1, *S2;
}
\f
Pointer
-string_to_symbol(String)
+string_to_symbol (String)
Pointer String;
{
Pointer New_Symbol, Interned_Symbol, *Orig_Free;
*/
void
-Find_Symbol(scheme_string)
+Find_Symbol (scheme_string)
Pointer scheme_string;
{
Pointer the_obarray, symbol, *bucket;
\f
/* (STRING->SYMBOL STRING)
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", 0x7)
-Define_Primitive(Prim_String_To_Symbol, 1, "STRING->SYMBOL")
+ instead of a list of ascii values as argument. */
+
+DEFINE_PRIMITIVE ("STRING->SYMBOL", Prim_String_To_Symbol, 1)
{
- Primitive_1_Arg();
+ PRIMITIVE_HEADER (1);
- Arg_1_Type(TC_CHARACTER_STRING);
- PRIMITIVE_RETURN( string_to_symbol(Arg1));
+ CHECK_ARG (1, STRING_P);
+ PRIMITIVE_RETURN (string_to_symbol (ARG_REF (1)));
}
/* (INTERN-CHARACTER-LIST LIST)
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.
-*/
+ be put into symbols this way. */
-Built_In_Primitive(Prim_Intern_Character_List, 1,
- "INTERN-CHARACTER-LIST", 0xAB)
-Define_Primitive(Prim_Intern_Character_List, 1,
- "INTERN-CHARACTER-LIST")
+DEFINE_PRIMITIVE ("INTERN-CHARACTER-LIST", Prim_Intern_Character_List, 1)
{
extern Pointer list_to_string();
- Primitive_1_Arg();
+ PRIMITIVE_HEADER (1);
- PRIMITIVE_RETURN( string_to_symbol(list_to_string(Arg1)));
+ PRIMITIVE_RETURN (string_to_symbol (list_to_string (ARG_REF (1))));
}
/* (STRING-HASH STRING)
Return a hash value for a string. This uses the hashing
algorithm used for interning symbols. It is intended for use by
- the reader in creating interned symbols.
-*/
-Built_In_Primitive(Prim_String_Hash, 1, "STRING-HASH", 0x83)
-Define_Primitive(Prim_String_Hash, 1, "STRING-HASH")
+ the reader in creating interned symbols. */
+
+DEFINE_PRIMITIVE ("STRING-HASH", Prim_String_Hash, 1)
{
- Primitive_1_Arg();
+ PRIMITIVE_HEADER (1);
- Arg_1_Type(TC_CHARACTER_STRING);
- PRIMITIVE_RETURN( Hash(Arg1));
+ CHECK_ARG (1, STRING_P);
+ PRIMITIVE_RETURN (Hash (ARG_REF (1)));
}
-Built_In_Primitive (Prim_string_hash_mod, 2, "STRING-HASH-MOD", 0x8A)
-Define_Primitive (Prim_string_hash_mod, 2, "STRING-HASH-MOD")
+DEFINE_PRIMITIVE ("STRING-HASH-MOD", Prim_string_hash_mod, 2)
{
- Primitive_2_Args ();
- CHECK_ARG (1, STRING_P);
+ PRIMITIVE_HEADER (2);
- PRIMITIVE_RETURN (MAKE_UNSIGNED_FIXNUM
- ((scheme_string_hash (Arg1)) %
- (arg_nonnegative_integer (2))));
+ CHECK_ARG (1, STRING_P);
+ PRIMITIVE_RETURN
+ (MAKE_UNSIGNED_FIXNUM
+ ((scheme_string_hash (ARG_REF (1))) %
+ (arg_nonnegative_integer (2))));
}
\f
/* (CHARACTER-LIST-HASH LIST)
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", 0x65)
-Define_Primitive(Prim_Character_List_Hash, 1,
- "CHARACTER-LIST-HASH")
-{
+ purpose. */
+
+DEFINE_PRIMITIVE ("CHARACTER-LIST-HASH", Prim_Character_List_Hash, 1)
+{
+ fast Pointer char_list;
long Length;
Pointer This_Char;
char String[MAX_HASH_CHARS];
- Primitive_1_Arg();
+ PRIMITIVE_HEADER (1);
- Touch_In_Primitive(Arg1, Arg1);
- for (Length = 0; Type_Code(Arg1) == TC_LIST; Length++)
- {
- if (Length < MAX_HASH_CHARS)
+ char_list = (ARG_REF (1));
+ Touch_In_Primitive (char_list, char_list);
+ for (Length = 0; (PAIR_P (char_list)); Length++)
{
- Touch_In_Primitive(Vector_Ref(Arg1, CONS_CAR), This_Char);
- if (Type_Code(This_Char) != TC_CHARACTER)
- {
- signal_error_from_primitive (ERR_ARG_1_WRONG_TYPE);
- }
- Range_Check(String[Length], This_Char,
- '\0', ((char) MAX_CHAR),
- ERR_ARG_1_WRONG_TYPE);
- Touch_In_Primitive(Vector_Ref(Arg1, CONS_CDR), Arg1);
+ if (Length < MAX_HASH_CHARS)
+ {
+ Touch_In_Primitive
+ ((Vector_Ref (char_list, CONS_CAR)), This_Char);
+ if (! (CHARACTER_P (This_Char)))
+ error_wrong_type_arg (1);
+ Range_Check((String [Length]), This_Char,
+ '\0', ((char) MAX_CHAR),
+ ERR_ARG_1_WRONG_TYPE);
+ Touch_In_Primitive
+ ((Vector_Ref (char_list, CONS_CDR)), char_list);
+ }
}
- }
- if (Arg1 != NIL)
- {
- signal_error_from_primitive (ERR_ARG_1_WRONG_TYPE);
- }
- PRIMITIVE_RETURN (MAKE_SIGNED_FIXNUM(Do_Hash(String, Length)));
+ if (char_list != NIL)
+ error_wrong_type_arg (1);
+ PRIMITIVE_RETURN (MAKE_SIGNED_FIXNUM (Do_Hash (String, Length)));
}
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/psbtobin.c,v 9.29 1987/11/20 08:20:36 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/psbtobin.c,v 9.30 1987/11/23 05:11:58 cph Exp $
*
* This File contains the code to translate portable format binary
* files to internal format.
#define Portable_File Input_File
#define Internal_File Output_File
-#include "translate.h"
+#include "psbmap.h"
static long
Dumped_Object_Addr,
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/regex.c,v 1.4 1987/08/20 21:16:44 jinx Rel $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/regex.c,v 1.5 1987/11/23 05:17:44 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
/* Regular expression matching and search.
Translated from GNU Emacs. */
-/* This code is not yet tested. -- CPH */
-
#include "scheme.h"
-#include "character.h"
+#include "char.h"
#include "syntax.h"
#include "regex.h"
\f
/* -*-C-*-
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/rgxprim.c,v 1.4 1987/11/17 08:16:12 jinx Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/rgxprim.c,v 1.5 1987/11/23 05:18:09 cph Exp $
Copyright (c) 1987 Massachusetts Institute of Technology
/* Primitives for regular expression matching and search. */
-/* This code is not yet tested. -- CPH */
-
#include "scheme.h"
#include "primitive.h"
-#include "stringprim.h"
-#include "character.h"
+#include "string.h"
+#include "char.h"
#include "edwin.h"
#include "syntax.h"
#include "regex.h"
for (i = 0; (i < RE_NREGS); i += 1) \
{ \
index = ((registers . start) [i]); \
- User_Vector_Set (vector, \
- i, \
- ((index == -1) \
- ? NIL \
- : (C_Integer_To_Scheme_Integer (index)))); \
+ User_Vector_Set \
+ (vector, \
+ i, \
+ ((index == -1) \
+ ? NIL \
+ : (C_Integer_To_Scheme_Integer (index)))); \
index = ((registers . end) [i]); \
- User_Vector_Set (vector, \
- (i + RE_NREGS), \
- ((index == -1) \
- ? NIL \
- : (C_Integer_To_Scheme_Integer (index)))); \
+ User_Vector_Set \
+ (vector, \
+ (i + RE_NREGS), \
+ ((index == -1) \
+ ? NIL \
+ : (C_Integer_To_Scheme_Integer (index)))); \
} \
} \
- return (C_Integer_To_Scheme_Integer (result)); \
+ PRIMITIVE_RETURN (C_Integer_To_Scheme_Integer (result)); \
} \
else if ((result) == (-1)) \
- return (NIL); \
+ PRIMITIVE_RETURN (NIL); \
else if ((result) == (-2)) \
error_bad_range_arg (1); \
else \
error_external_return (); \
} while (0)
\f
-Built_In_Primitive (Prim_re_char_set_adjoin, 2, "RE-CHAR-SET-ADJOIN!", 0x190)
-Define_Primitive (Prim_re_char_set_adjoin, 2, "RE-CHAR-SET-ADJOIN!")
+DEFINE_PRIMITIVE ("RE-CHAR-SET-ADJOIN!", Prim_re_char_set_adjoin, 2)
{
int ascii;
- Primitive_2_Args ();
+ PRIMITIVE_HEADER (2);
CHECK_ARG (1, RE_CHAR_SET_P);
ascii = (arg_ascii_char (2));
- (* (string_pointer (Arg1, (ascii / ASCII_LENGTH)))) |=
+ (* (string_pointer ((ARG_REF (1)), (ascii / ASCII_LENGTH)))) |=
(1 << (ascii % ASCII_LENGTH));
- return (NIL);
+ PRIMITIVE_RETURN (NIL);
}
-Built_In_Primitive (Prim_re_compile_fastmap, 4, "RE-COMPILE-FASTMAP", 0x191)
-Define_Primitive (Prim_re_compile_fastmap, 4, "RE-COMPILE-FASTMAP")
+DEFINE_PRIMITIVE ("RE-COMPILE-FASTMAP", Prim_re_compile_fastmap, 4)
{
- int can_be_null;
- Primitive_4_Args ();
+ fast Pointer pattern;
+ fast int can_be_null;
+ PRIMITIVE_HEADER (4);
CHECK_ARG (1, STRING_P);
+ pattern = (ARG_REF (1));
CHECK_ARG (2, CHAR_TRANSLATION_P);
CHECK_ARG (3, SYNTAX_TABLE_P);
CHECK_ARG (4, CHAR_SET_P);
can_be_null =
- (re_compile_fastmap ((string_pointer (Arg1, 0)),
- (string_pointer (Arg1, (string_length (Arg1)))),
- (string_pointer (Arg2, 0)),
- Arg3,
- (string_pointer (Arg4, 0))));
+ (re_compile_fastmap
+ ((string_pointer (pattern, 0)),
+ (string_pointer (pattern, (string_length (pattern)))),
+ (string_pointer ((ARG_REF (2)), 0)),
+ (ARG_REF (3)),
+ (string_pointer ((ARG_REF (4)), 0))));
if (can_be_null >= 0)
- return (C_Integer_To_Scheme_Integer (can_be_null));
+ PRIMITIVE_RETURN (C_Integer_To_Scheme_Integer (can_be_null));
else if (can_be_null == (-2))
error_bad_range_arg (1);
else
the appropriate indices for the match registers. */
#define RE_SUBSTRING_PRIMITIVE(procedure) \
-{ \
+ fast Pointer regexp; \
long match_start, match_end, text_end; \
char *text; \
struct re_buffer buffer; \
struct re_registers registers; \
int result; \
- Primitive_7_Args (); \
+ PRIMITIVE_HEADER (7); \
\
CHECK_ARG (1, STRING_P); \
+ regexp = (ARG_REF (1)); \
CHECK_ARG (2, CHAR_TRANSLATION_P); \
CHECK_ARG (3, SYNTAX_TABLE_P); \
CHECK_ARG (4, RE_REGISTERS_P); \
CHECK_ARG (5, STRING_P); \
match_start = (arg_nonnegative_integer (6)); \
match_end = (arg_nonnegative_integer (7)); \
- text = (string_pointer (Arg5, 0)); \
- text_end = (string_length (Arg5)); \
+ text = (string_pointer ((ARG_REF (5)), 0)); \
+ text_end = (string_length (ARG_REF (5))); \
\
if (match_end > text_end) error_bad_range_arg (7); \
if (match_start > match_end) error_bad_range_arg (6); \
\
re_buffer_initialize \
- ((& buffer), (string_pointer (Arg2, 0)), Arg3, text, 0, text_end, \
- text_end, text_end); \
+ ((& buffer), (string_pointer ((ARG_REF (2)), 0)), (ARG_REF (3)), \
+ text, 0, text_end, text_end, text_end); \
\
result = \
- (procedure ((string_pointer (Arg1, 0)), \
- (string_pointer (Arg1, (string_length (Arg1)))), \
+ (procedure ((string_pointer (regexp, 0)), \
+ (string_pointer (regexp, (string_length (regexp)))), \
(& buffer), \
- ((Arg4 == NIL) ? NULL : (& registers)), \
+ (((ARG_REF (4)) == NIL) ? NULL : (& registers)), \
(& (text [match_start])), \
(& (text [match_end])))); \
- RE_MATCH_RESULTS (result, Arg4); \
-}
+ RE_MATCH_RESULTS (result, (ARG_REF (4)))
-Built_In_Primitive (Prim_re_match_substring, 7, "RE-MATCH-SUBSTRING", 0x118)
-Define_Primitive (Prim_re_match_substring, 7, "RE-MATCH-SUBSTRING")
- RE_SUBSTRING_PRIMITIVE (re_match)
+DEFINE_PRIMITIVE ("RE-MATCH-SUBSTRING", Prim_re_match_substring, 7)
+{ RE_SUBSTRING_PRIMITIVE (re_match); }
-Built_In_Primitive (Prim_re_search_substr_forward, 7,
- "RE-SEARCH-SUBSTRING-FORWARD", 0x119)
-Define_Primitive (Prim_re_search_substr_forward, 7,
- "RE-SEARCH-SUBSTRING-FORWARD")
- RE_SUBSTRING_PRIMITIVE (re_search_forward)
+DEFINE_PRIMITIVE ("RE-SEARCH-SUBSTRING-FORWARD", Prim_re_search_substr_forward, 7)
+{ RE_SUBSTRING_PRIMITIVE (re_search_forward); }
-Built_In_Primitive (Prim_re_search_substr_backward, 7,
- "RE-SEARCH-SUBSTRING-BACKWARD", 0x11A)
-Define_Primitive (Prim_re_search_substr_backward, 7,
- "RE-SEARCH-SUBSTRING-BACKWARD")
- RE_SUBSTRING_PRIMITIVE (re_search_backward)
+DEFINE_PRIMITIVE ("RE-SEARCH-SUBSTRING-BACKWARD", Prim_re_search_substr_backward, 7)
+{ RE_SUBSTRING_PRIMITIVE (re_search_backward); }
\f
#define RE_BUFFER_PRIMITIVE(procedure) \
-{ \
+ fast Pointer regexp, group; \
long match_start, match_end, text_start, text_end, gap_start; \
char *text; \
struct re_buffer buffer; \
Primitive_7_Args (); \
\
CHECK_ARG (1, STRING_P); \
+ regexp = (ARG_REF (1)); \
CHECK_ARG (2, CHAR_TRANSLATION_P); \
CHECK_ARG (3, SYNTAX_TABLE_P); \
CHECK_ARG (4, RE_REGISTERS_P); \
CHECK_ARG (5, GROUP_P); \
+ group = (ARG_REF (5)); \
match_start = (arg_nonnegative_integer (6)); \
match_end = (arg_nonnegative_integer (7)); \
\
- text = (string_pointer ((GROUP_TEXT (Arg5)), 0)); \
- text_start = (MARK_POSITION (GROUP_START_MARK (Arg5))); \
- text_end = (MARK_POSITION (GROUP_END_MARK (Arg5))); \
- gap_start = (GROUP_GAP_START (Arg5)); \
+ text = (string_pointer ((GROUP_TEXT (group)), 0)); \
+ text_start = (MARK_POSITION (GROUP_START_MARK (group))); \
+ text_end = (MARK_POSITION (GROUP_END_MARK (group))); \
+ gap_start = (GROUP_GAP_START (group)); \
\
if (match_end > gap_start) \
{ \
- match_end += (GROUP_GAP_LENGTH (Arg5)); \
+ match_end += (GROUP_GAP_LENGTH (group)); \
if (match_start >= gap_start) \
- match_start += (GROUP_GAP_LENGTH (Arg5)); \
+ match_start += (GROUP_GAP_LENGTH (group)); \
} \
\
if (match_start > match_end) error_bad_range_arg (6); \
if (match_start < text_start) error_bad_range_arg (6); \
\
re_buffer_initialize \
- ((& buffer), (string_pointer (Arg2, 0)), Arg3, text, text_start, \
- text_end, gap_start, (GROUP_GAP_END (Arg5))); \
+ ((& buffer), (string_pointer ((ARG_REF (2)), 0)), (ARG_REF (3)), \
+ text, text_start, text_end, gap_start, (GROUP_GAP_END (group))); \
\
result = \
- (procedure ((string_pointer (Arg1, 0)), \
- (string_pointer (Arg1, (string_length (Arg1)))), \
+ (procedure ((string_pointer (regexp, 0)), \
+ (string_pointer (regexp, (string_length (regexp)))), \
(& buffer), \
- ((Arg4 == NIL) ? NULL : (& registers)), \
+ (((ARG_REF (4)) == NIL) ? NULL : (& registers)), \
(& (text [match_start])), \
(& (text [match_end])))); \
- RE_MATCH_RESULTS (result, Arg4); \
-}
+ RE_MATCH_RESULTS (result, (ARG_REF (4)))
-Built_In_Primitive (Prim_re_match_buffer, 7, "RE-MATCH-BUFFER", 0x192)
-Define_Primitive (Prim_re_match_buffer, 7, "RE-MATCH-BUFFER")
- RE_BUFFER_PRIMITIVE (re_match)
+DEFINE_PRIMITIVE ("RE-MATCH-BUFFER", Prim_re_match_buffer, 7)
+{ RE_BUFFER_PRIMITIVE (re_match); }
-Built_In_Primitive (Prim_re_search_buffer_forward, 7,
- "RE-SEARCH-BUFFER-FORWARD", 0x193)
-Define_Primitive (Prim_re_search_buffer_forward, 7,
- "RE-SEARCH-BUFFER-FORWARD")
- RE_BUFFER_PRIMITIVE (re_search_forward)
+DEFINE_PRIMITIVE ("RE-SEARCH-BUFFER-FORWARD", Prim_re_search_buffer_forward, 7)
+{ RE_BUFFER_PRIMITIVE (re_search_forward); }
-Built_In_Primitive (Prim_re_search_buffer_backward, 7,
- "RE-SEARCH-BUFFER-BACKWARD", 0x194)
-Define_Primitive (Prim_re_search_buffer_backward, 7,
- "RE-SEARCH-BUFFER-BACKWARD")
- RE_BUFFER_PRIMITIVE (re_search_backward)
+DEFINE_PRIMITIVE ("RE-SEARCH-BUFFER-BACKWARD", Prim_re_search_buffer_backward, 7)
+{ RE_BUFFER_PRIMITIVE (re_search_backward); }
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/string.c,v 9.28 1987/11/17 08:17:44 jinx Exp $ */
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/string.c,v 9.29 1987/11/23 05:08:56 cph Rel $ */
/* String primitives. */
#include "scheme.h"
#include "primitive.h"
-#include "character.h"
-#include "stringprim.h"
+#include "char.h"
+#include "string.h"
\f
Pointer
allocate_string (nbytes)
/* 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", 0x13E)
-Define_Primitive (Prim_String_Allocate, 1, "STRING-ALLOCATE")
+DEFINE_PRIMITIVE ("STRING-ALLOCATE", Prim_String_Allocate, 1)
{
PRIMITIVE_HEADER (1);
PRIMITIVE_RETURN (allocate_string (arg_nonnegative_integer (1)));
}
-Built_In_Primitive (Prim_String_P, 1, "STRING?", 0x138)
-Define_Primitive (Prim_String_P, 1, "STRING?")
+DEFINE_PRIMITIVE ("STRING?", Prim_String_P, 1)
{
- Primitive_1_Arg ();
+ PRIMITIVE_HEADER (1);
- PRIMITIVE_RETURN ((STRING_P (Arg1)) ? TRUTH : NIL);
+ PRIMITIVE_RETURN ((STRING_P (ARG_REF (1))) ? TRUTH : NIL);
}
\f
-Built_In_Primitive (Prim_String_Length, 1, "STRING-LENGTH", 0x139)
-Define_Primitive (Prim_String_Length, 1, "STRING-LENGTH")
+DEFINE_PRIMITIVE ("STRING-LENGTH", Prim_String_Length, 1)
{
- Primitive_1_Arg ();
+ PRIMITIVE_HEADER (1);
CHECK_ARG (1, STRING_P);
- PRIMITIVE_RETURN (Make_Unsigned_Fixnum (string_length (Arg1)));
+ PRIMITIVE_RETURN (Make_Unsigned_Fixnum (string_length (ARG_REF (1))));
}
-Built_In_Primitive (Prim_String_Maximum_Length, 1,
- "STRING-MAXIMUM-LENGTH", 0x13F)
-Define_Primitive (Prim_String_Maximum_Length, 1,
- "STRING-MAXIMUM-LENGTH")
+DEFINE_PRIMITIVE ("STRING-MAXIMUM-LENGTH", Prim_String_Maximum_Length, 1)
{
- Primitive_1_Arg ();
+ PRIMITIVE_HEADER (1);
CHECK_ARG (1, STRING_P);
- PRIMITIVE_RETURN (Make_Unsigned_Fixnum ((maximum_string_length (Arg1)) - 1));
+ PRIMITIVE_RETURN
+ (Make_Unsigned_Fixnum ((maximum_string_length (ARG_REF (1))) - 1));
}
-Built_In_Primitive (Prim_Set_String_Length, 2, "SET-STRING-LENGTH!", 0x140)
-Define_Primitive (Prim_Set_String_Length, 2, "SET-STRING-LENGTH!")
+DEFINE_PRIMITIVE ("SET-STRING-LENGTH!", Prim_Set_String_Length, 2)
{
- long length, result;
- Primitive_2_Args ();
+ fast Pointer string;
+ fast long length;
+ fast long result;
+ PRIMITIVE_HEADER (2);
CHECK_ARG (1, STRING_P);
+ string = (ARG_REF (1));
length = (arg_nonnegative_integer (2));
- if (length > (maximum_string_length (Arg1)))
+ if (length > (maximum_string_length (string)))
error_bad_range_arg (2);
- result = (string_length (Arg1));
- set_string_length (Arg1, length);
+ result = (string_length (string));
+ set_string_length (string, length);
PRIMITIVE_RETURN (Make_Unsigned_Fixnum (result));
}
return ((length1 < length2) ? length1 : length2);
}
\f
-#define string_ref_body(process_result) \
-{ \
- long index; \
- long result; \
- Primitive_2_Args (); \
- \
- CHECK_ARG (1, STRING_P); \
- index = (arg_index_integer (2, (string_length (Arg1)))); \
- \
- PRIMITIVE_RETURN (process_result (string_ref (Arg1, index))); \
-}
+#define STRING_REF_BODY(process_result) \
+ fast Pointer string; \
+ fast long index; \
+ PRIMITIVE_HEADER (2); \
+ \
+ CHECK_ARG (1, STRING_P); \
+ string = (ARG_REF (1)); \
+ index = (arg_index_integer (2, (string_length (string)))); \
+ \
+ PRIMITIVE_RETURN (process_result (string_ref (string, index)))
-Built_In_Primitive (Prim_String_Ref, 2, "STRING-REF", 0x13A)
-Define_Primitive (Prim_String_Ref, 2, "STRING-REF")
- string_ref_body (c_char_to_scheme_char)
+DEFINE_PRIMITIVE ("STRING-REF", Prim_String_Ref, 2)
+{ STRING_REF_BODY (c_char_to_scheme_char); }
-Built_In_Primitive (Prim_Vec_8b_Ref, 2, "VECTOR-8B-REF", 0xA5)
-Define_Primitive (Prim_Vec_8b_Ref, 2, "VECTOR-8B-REF")
- string_ref_body (Make_Unsigned_Fixnum)
+DEFINE_PRIMITIVE ("VECTOR-8B-REF", Prim_Vec_8b_Ref, 2)
+{ STRING_REF_BODY (Make_Unsigned_Fixnum); }
-#define string_set_body(get_ascii, process_result) \
-{ \
- long index, ascii; \
- char *char_pointer; \
- Pointer result; \
- Primitive_3_Args (); \
- \
- CHECK_ARG (1, STRING_P); \
- index = (arg_index_integer (2, (string_length (Arg1)))); \
- ascii = (get_ascii (3)); \
- \
- char_pointer = (string_pointer (Arg1, index)); \
- result = (char_to_long (*char_pointer)); \
- *char_pointer = ascii; \
- PRIMITIVE_RETURN (process_result (result)); \
-}
+#define STRING_SET_BODY(get_ascii, process_result) \
+ fast Pointer string; \
+ fast long index; \
+ long ascii; \
+ char *char_pointer; \
+ Pointer result; \
+ PRIMITIVE_HEADER (3); \
+ \
+ CHECK_ARG (1, STRING_P); \
+ string = (ARG_REF (1)); \
+ index = (arg_index_integer (2, (string_length (string)))); \
+ ascii = (get_ascii (3)); \
+ \
+ char_pointer = (string_pointer (string, index)); \
+ result = (char_to_long (*char_pointer)); \
+ (*char_pointer) = ascii; \
+ PRIMITIVE_RETURN (process_result (result))
-Built_In_Primitive (Prim_String_Set, 3, "STRING-SET!", 0x13B)
-Define_Primitive (Prim_String_Set, 3, "STRING-SET!")
- string_set_body (arg_ascii_char, c_char_to_scheme_char)
+DEFINE_PRIMITIVE ("STRING-SET!", Prim_String_Set, 3)
+{ STRING_SET_BODY (arg_ascii_char, c_char_to_scheme_char); }
-Built_In_Primitive (Prim_Vec_8b_Set, 3, "VECTOR-8B-SET!", 0xA6)
-Define_Primitive (Prim_Vec_8b_Set, 3, "VECTOR-8B-SET!")
- string_set_body (arg_ascii_integer, MAKE_UNSIGNED_FIXNUM)
+DEFINE_PRIMITIVE ("VECTOR-8B-SET!", Prim_Vec_8b_Set, 3)
+{ STRING_SET_BODY (arg_ascii_integer, MAKE_UNSIGNED_FIXNUM); }
\f
-#define substring_move_prefix() \
- long start1, end1, start2, end2, length; \
- fast char *scan1, *scan2; \
- Primitive_5_Args (); \
- \
- CHECK_ARG (1, STRING_P); \
- start1 = (arg_nonnegative_integer (2)); \
- end1 = (arg_nonnegative_integer (3)); \
- CHECK_ARG (4, STRING_P); \
- start2 = (arg_nonnegative_integer (5)); \
- \
- if (end1 > (string_length (Arg1))) \
- error_bad_range_arg (2); \
- if (start1 > end1) \
- error_bad_range_arg (1); \
- length = (end1 - start1); \
- \
- end2 = (start2 + length); \
- if (end2 > (string_length (Arg4))) \
- error_bad_range_arg (3);
-
-Built_In_Primitive (Prim_Substring_Move_Right, 5,
- "SUBSTRING-MOVE-RIGHT!", 0x13C)
-Define_Primitive (Prim_Substring_Move_Right, 5,
- "SUBSTRING-MOVE-RIGHT!")
+#define SUBSTRING_MOVE_PREFIX() \
+ long start1, end1, start2, end2, length; \
+ fast char *scan1, *scan2; \
+ PRIMITIVE_HEADER (5); \
+ \
+ CHECK_ARG (1, STRING_P); \
+ start1 = (arg_nonnegative_integer (2)); \
+ end1 = (arg_nonnegative_integer (3)); \
+ CHECK_ARG (4, STRING_P); \
+ start2 = (arg_nonnegative_integer (5)); \
+ \
+ if (end1 > (string_length (ARG_REF (1)))) \
+ error_bad_range_arg (2); \
+ if (start1 > end1) \
+ error_bad_range_arg (1); \
+ length = (end1 - start1); \
+ \
+ end2 = (start2 + length); \
+ if (end2 > (string_length (ARG_REF (4)))) \
+ error_bad_range_arg (3)
+
+DEFINE_PRIMITIVE ("SUBSTRING-MOVE-RIGHT!", Prim_Substring_Move_Right, 5)
{
- substring_move_prefix()
+ SUBSTRING_MOVE_PREFIX ();
- scan1 = (string_pointer (Arg1, end1));
- scan2 = (string_pointer (Arg4, end2));
- while (length-- > 0)
- *--scan2 = *--scan1;
+ scan1 = (string_pointer ((ARG_REF (1)), end1));
+ scan2 = (string_pointer ((ARG_REF (4)), end2));
+ while ((length--) > 0)
+ (*--scan2) = (*--scan1);
PRIMITIVE_RETURN (NIL);
}
-Built_In_Primitive (Prim_Substring_Move_Left, 5,
- "SUBSTRING-MOVE-LEFT!", 0x13D)
-Define_Primitive (Prim_Substring_Move_Left, 5,
- "SUBSTRING-MOVE-LEFT!")
+DEFINE_PRIMITIVE ("SUBSTRING-MOVE-LEFT!", Prim_Substring_Move_Left, 5)
{
- substring_move_prefix()
+ SUBSTRING_MOVE_PREFIX ();
- scan1 = (string_pointer (Arg1, start1));
- scan2 = (string_pointer (Arg4, start2));
- while (length-- > 0)
- *scan2++ = *scan1++;
+ scan1 = (string_pointer ((ARG_REF (1)), start1));
+ scan2 = (string_pointer ((ARG_REF (4)), start2));
+ while ((length--) > 0)
+ (*scan2++) = (*scan1++);
PRIMITIVE_RETURN (NIL);
}
\f
-#define vector_8b_substring_prefix() \
- long start, end, ascii; \
- long length; \
- char *scan; \
- Primitive_4_Args (); \
- \
- CHECK_ARG (1, STRING_P); \
- start = (arg_nonnegative_integer (2)); \
- end = (arg_nonnegative_integer (3)); \
- ascii = (arg_ascii_integer (4)); \
- \
- if (end > (string_length (Arg1))) \
- error_bad_range_arg (3); \
- if (start > end) \
- error_bad_range_arg (2);
+#define VECTOR_8B_SUBSTRING_PREFIX() \
+ long start, end, ascii; \
+ fast long length; \
+ fast char *scan; \
+ PRIMITIVE_HEADER (4); \
+ \
+ CHECK_ARG (1, STRING_P); \
+ start = (arg_nonnegative_integer (2)); \
+ end = (arg_nonnegative_integer (3)); \
+ ascii = (arg_ascii_integer (4)); \
+ \
+ if (end > (string_length (ARG_REF (1)))) \
+ error_bad_range_arg (3); \
+ if (start > end) \
+ error_bad_range_arg (2)
-Built_In_Primitive (Prim_Vec_8b_Fill, 4, "VECTOR-8B-FILL!", 0x141)
-Define_Primitive (Prim_Vec_8b_Fill, 4, "VECTOR-8B-FILL!")
+DEFINE_PRIMITIVE ("VECTOR-8B-FILL!", Prim_Vec_8b_Fill, 4)
{
- vector_8b_substring_prefix ();
+ VECTOR_8B_SUBSTRING_PREFIX ();
length = (end - start);
- scan = (string_pointer (Arg1, start));
- while (length-- > 0)
- *scan++ = ascii;
+ scan = (string_pointer ((ARG_REF (1)), start));
+ while ((length--) > 0)
+ (*scan++) = ascii;
PRIMITIVE_RETURN (NIL);
}
-Built_In_Primitive (Prim_Vec_8b_Find_Next_Char, 4,
- "VECTOR-8B-FIND-NEXT-CHAR", 0x142)
-Define_Primitive (Prim_Vec_8b_Find_Next_Char, 4,
- "VECTOR-8B-FIND-NEXT-CHAR")
+DEFINE_PRIMITIVE ("VECTOR-8B-FIND-NEXT-CHAR", Prim_Vec_8b_Find_Next_Char, 4)
{
- vector_8b_substring_prefix ();
+ VECTOR_8B_SUBSTRING_PREFIX ();
- scan = (string_pointer (Arg1, start));
+ scan = (string_pointer ((ARG_REF (1)), start));
while (start < end)
{
if ((char_to_long (*scan++)) == ascii)
PRIMITIVE_RETURN (NIL);
}
\f
-Built_In_Primitive (Prim_Vec_8b_Find_Prev_Char, 4,
- "VECTOR-8B-FIND-PREVIOUS-CHAR", 0x143)
-Define_Primitive (Prim_Vec_8b_Find_Prev_Char, 4,
- "VECTOR-8B-FIND-PREVIOUS-CHAR")
+DEFINE_PRIMITIVE ("VECTOR-8B-FIND-PREVIOUS-CHAR", Prim_Vec_8b_Find_Prev_Char, 4)
{
- vector_8b_substring_prefix ();
+ VECTOR_8B_SUBSTRING_PREFIX ();
- scan = (string_pointer (Arg1, end));
- while (end-- > start)
+ scan = (string_pointer ((ARG_REF (1)), end));
+ while ((end--) > start)
if ((char_to_long (*--scan)) == ascii)
PRIMITIVE_RETURN (Make_Unsigned_Fixnum (end));
PRIMITIVE_RETURN (NIL);
}
-Built_In_Primitive(Prim_Vec_8b_Find_Next_Char_Ci, 4,
- "VECTOR-8B-FIND-NEXT-CHAR-CI", 0x144)
-Define_Primitive(Prim_Vec_8b_Find_Next_Char_Ci, 4,
- "VECTOR-8B-FIND-NEXT-CHAR-CI")
+DEFINE_PRIMITIVE ("VECTOR-8B-FIND-NEXT-CHAR-CI", Prim_Vec_8b_Find_Next_Char_Ci, 4)
{
char char1;
- vector_8b_substring_prefix ();
+ VECTOR_8B_SUBSTRING_PREFIX ();
- scan = (string_pointer (Arg1, start));
+ scan = (string_pointer ((ARG_REF (1)), start));
char1 = (char_upcase (ascii));
while (start < end)
{
PRIMITIVE_RETURN (NIL);
}
-Built_In_Primitive(Prim_Vec_8b_Find_Prev_Char_Ci, 4,
- "VECTOR-8B-FIND-PREVIOUS-CHAR-CI", 0x145)
-Define_Primitive(Prim_Vec_8b_Find_Prev_Char_Ci, 4,
- "VECTOR-8B-FIND-PREVIOUS-CHAR-CI")
+DEFINE_PRIMITIVE ("VECTOR-8B-FIND-PREVIOUS-CHAR-CI", Prim_Vec_8b_Find_Prev_Char_Ci, 4)
{
char char1;
- vector_8b_substring_prefix ();
+ VECTOR_8B_SUBSTRING_PREFIX ();
- scan = (string_pointer (Arg1, end));
+ scan = (string_pointer ((ARG_REF (1)), end));
char1 = (char_upcase (ascii));
- while (end-- > start)
+ while ((end--) > start)
{
if ((char_upcase (*--scan)) == char1)
PRIMITIVE_RETURN (Make_Unsigned_Fixnum (end));
PRIMITIVE_RETURN (NIL);
}
\f
-#define substr_find_char_in_set_prefix() \
- long start, end, length; \
- char *char_set, *scan; \
- Primitive_4_Args (); \
- \
- CHECK_ARG (1, STRING_P); \
- start = (arg_nonnegative_integer (2)); \
- end = (arg_nonnegative_integer (3)); \
- CHECK_ARG (4, STRING_P); \
- \
- if (end > (string_length (Arg1))) \
- error_bad_range_arg (3); \
- if (start > end) \
- error_bad_range_arg (2); \
- if ((string_length (Arg4)) != MAX_ASCII) \
- error_bad_range_arg (4);
+#define SUBSTR_FIND_CHAR_IN_SET_PREFIX() \
+ long start, end, length; \
+ char *char_set, *scan; \
+ PRIMITIVE_HEADER (4); \
+ \
+ CHECK_ARG (1, STRING_P); \
+ start = (arg_nonnegative_integer (2)); \
+ end = (arg_nonnegative_integer (3)); \
+ CHECK_ARG (4, STRING_P); \
+ \
+ if (end > (string_length (ARG_REF (1)))) \
+ error_bad_range_arg (3); \
+ if (start > end) \
+ error_bad_range_arg (2); \
+ if ((string_length (ARG_REF (4))) != MAX_ASCII) \
+ error_bad_range_arg (4)
-Built_In_Primitive(Prim_Find_Next_Char_In_Set, 4,
- "SUBSTRING-FIND-NEXT-CHAR-IN-SET", 0x146)
-Define_Primitive(Prim_Find_Next_Char_In_Set, 4,
- "SUBSTRING-FIND-NEXT-CHAR-IN-SET")
+DEFINE_PRIMITIVE ("SUBSTRING-FIND-NEXT-CHAR-IN-SET", Prim_Find_Next_Char_In_Set, 4)
{
- substr_find_char_in_set_prefix ();
+ SUBSTR_FIND_CHAR_IN_SET_PREFIX ();
- char_set = (Scheme_String_To_C_String (Arg4));
- scan = (string_pointer (Arg1, start));
+ char_set = (Scheme_String_To_C_String (ARG_REF (4)));
+ scan = (string_pointer ((ARG_REF (1)), start));
while (start < end)
{
if (char_set[(char_to_long (*scan++))] != '\0')
PRIMITIVE_RETURN (NIL);
}
-Built_In_Primitive(Prim_Find_Prev_Char_In_Set, 4,
- "SUBSTRING-FIND-PREVIOUS-CHAR-IN-SET", 0x147)
-Define_Primitive(Prim_Find_Prev_Char_In_Set, 4,
- "SUBSTRING-FIND-PREVIOUS-CHAR-IN-SET")
+DEFINE_PRIMITIVE ("SUBSTRING-FIND-PREVIOUS-CHAR-IN-SET", Prim_Find_Prev_Char_In_Set, 4)
{
- substr_find_char_in_set_prefix ();
+ SUBSTR_FIND_CHAR_IN_SET_PREFIX ();
- char_set = Scheme_String_To_C_String(Arg4);
- scan = (string_pointer (Arg1, end));
+ char_set = Scheme_String_To_C_String(ARG_REF (4));
+ scan = (string_pointer ((ARG_REF (1)), end));
while (end-- > start)
if (char_set[(char_to_long (*--scan))] != '\0')
PRIMITIVE_RETURN (Make_Unsigned_Fixnum (end));
PRIMITIVE_RETURN (NIL);
}
\f
-#define substring_compare_prefix(index1, index2) \
+#define SUBSTRING_COMPARE_PREFIX(index1, index2) \
long start1, end1, start2, end2; \
- char *scan1, *scan2; \
- Primitive_6_Args (); \
+ fast char *scan1, *scan2; \
+ PRIMITIVE_HEADER (6); \
\
CHECK_ARG (1, STRING_P); \
start1 = (arg_nonnegative_integer (2)); \
start2 = (arg_nonnegative_integer (5)); \
end2 = (arg_nonnegative_integer (6)); \
\
- if (end1 > (string_length (Arg1))) \
+ if (end1 > (string_length (ARG_REF (1)))) \
error_bad_range_arg (3); \
if (start1 > end1) \
error_bad_range_arg (2); \
\
- if (end2 > (string_length (Arg4))) \
+ if (end2 > (string_length (ARG_REF (4)))) \
error_bad_range_arg (6); \
if (start2 > end2) \
error_bad_range_arg (5); \
\
- scan1 = (string_pointer (Arg1, index1)); \
- scan2 = (string_pointer (Arg4, index2));
+ scan1 = (string_pointer ((ARG_REF (1)), index1)); \
+ scan2 = (string_pointer ((ARG_REF (4)), index2))
-#define substring_equal_prefix() \
+#define SUBSTRING_EQUAL_PREFIX() \
long length; \
- substring_compare_prefix (start1, start2); \
+ SUBSTRING_COMPARE_PREFIX (start1, start2); \
\
length = (end1 - start1); \
if (length != (end2 - start2)) \
PRIMITIVE_RETURN (NIL);
-Built_In_Primitive(Prim_Substring_Equal, 6, "SUBSTRING=?", 0x148)
-Define_Primitive(Prim_Substring_Equal, 6, "SUBSTRING=?")
+DEFINE_PRIMITIVE ("SUBSTRING=?", Prim_Substring_Equal, 6)
{
- substring_equal_prefix ();
+ SUBSTRING_EQUAL_PREFIX ();
- while (length-- > 0)
+ while ((length--) > 0)
if ((*scan1++) != (*scan2++))
PRIMITIVE_RETURN (NIL);
PRIMITIVE_RETURN (TRUTH);
}
-Built_In_Primitive(Prim_Substring_Ci_Equal, 6, "SUBSTRING-CI=?", 0x149)
-Define_Primitive(Prim_Substring_Ci_Equal, 6, "SUBSTRING-CI=?")
+DEFINE_PRIMITIVE ("SUBSTRING-CI=?", Prim_Substring_Ci_Equal, 6)
{
- substring_equal_prefix ();
+ SUBSTRING_EQUAL_PREFIX ();
- while (length-- > 0)
+ while ((length--) > 0)
if ((char_upcase (*scan1++)) != (char_upcase (*scan2++)))
PRIMITIVE_RETURN (NIL);
PRIMITIVE_RETURN (TRUTH);
}
\f
-Built_In_Primitive (Prim_Substring_Less, 6, "SUBSTRING<?", 0x14A)
-Define_Primitive (Prim_Substring_Less, 6, "SUBSTRING<?")
+DEFINE_PRIMITIVE ("SUBSTRING<?", Prim_Substring_Less, 6)
{
long length, length1, length2;
- substring_compare_prefix (start1, start2);
+ SUBSTRING_COMPARE_PREFIX (start1, start2);
length1 = (end1 - start1);
length2 = (end2 - start2);
while ((length--) > 0)
if ((*scan1++) != (*scan2++))
- PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT ((scan1[-1]) < (scan2[-1])));
+ PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT ((scan1 [-1]) < (scan2 [-1])));
PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (length1 < length2));
}
#define SUBSTRING_MODIFIER(char_map) \
-{ \
Pointer string; \
long start, end; \
fast long length; \
temp = (*scan); \
(*scan++) = (char_map (temp)); \
} \
- PRIMITIVE_RETURN (NIL); \
-}
+ PRIMITIVE_RETURN (NIL)
-Built_In_Primitive(Prim_Substring_Upcase, 3, "SUBSTRING-UPCASE!", 0x14B)
-Define_Primitive(Prim_Substring_Upcase, 3, "SUBSTRING-UPCASE!")
- SUBSTRING_MODIFIER (char_upcase)
+DEFINE_PRIMITIVE ("SUBSTRING-UPCASE!", Prim_Substring_Upcase, 3)
+{ SUBSTRING_MODIFIER (char_upcase); }
-Built_In_Primitive(Prim_Substring_Downcase, 3, "SUBSTRING-DOWNCASE!", 0x14C)
-Define_Primitive(Prim_Substring_Downcase, 3, "SUBSTRING-DOWNCASE!")
- SUBSTRING_MODIFIER (char_downcase)
+DEFINE_PRIMITIVE ("SUBSTRING-DOWNCASE!", Prim_Substring_Downcase, 3)
+{ SUBSTRING_MODIFIER (char_downcase); }
\f
-#define substring_match_prefix(index1, index2) \
+#define SUBSTRING_MATCH_PREFIX(index1, index2) \
long length, unmatched; \
- substring_compare_prefix (index1, index2); \
+ SUBSTRING_COMPARE_PREFIX (index1, index2); \
\
length = (substring_length_min (start1, end1, start2, end2)); \
unmatched = length;
-Built_In_Primitive (Prim_Match_Forward, 6,
- "SUBSTRING-MATCH-FORWARD", 0x14D)
-Define_Primitive (Prim_Match_Forward, 6,
- "SUBSTRING-MATCH-FORWARD")
+DEFINE_PRIMITIVE ("SUBSTRING-MATCH-FORWARD", Prim_Match_Forward, 6)
{
- substring_match_prefix (start1, start2);
+ SUBSTRING_MATCH_PREFIX (start1, start2);
while (unmatched-- > 0)
if ((*scan1++) != (*scan2++))
PRIMITIVE_RETURN (Make_Unsigned_Fixnum (length));
}
-Built_In_Primitive (Prim_Match_Forward_Ci, 6,
- "SUBSTRING-MATCH-FORWARD-CI", 0x14F)
-Define_Primitive (Prim_Match_Forward_Ci, 6,
- "SUBSTRING-MATCH-FORWARD-CI")
+DEFINE_PRIMITIVE ("SUBSTRING-MATCH-FORWARD-CI", Prim_Match_Forward_Ci, 6)
{
- substring_match_prefix (start1, start2);
+ SUBSTRING_MATCH_PREFIX (start1, start2);
while (unmatched-- > 0)
if ((char_upcase (*scan1++)) != (char_upcase (*scan2++)))
PRIMITIVE_RETURN (Make_Unsigned_Fixnum (length));
}
-Built_In_Primitive (Prim_Match_Backward, 6,
- "SUBSTRING-MATCH-BACKWARD", 0x14E)
-Define_Primitive (Prim_Match_Backward, 6,
- "SUBSTRING-MATCH-BACKWARD")
+DEFINE_PRIMITIVE ("SUBSTRING-MATCH-BACKWARD", Prim_Match_Backward, 6)
{
- substring_match_prefix (end1, end2);
+ SUBSTRING_MATCH_PREFIX (end1, end2);
while (unmatched-- > 0)
if ((*--scan1) != (*--scan2))
PRIMITIVE_RETURN (Make_Unsigned_Fixnum (length));
}
-Built_In_Primitive(Prim_Match_Backward_Ci, 6,
- "SUBSTRING-MATCH-BACKWARD-CI", 0x150)
-Define_Primitive(Prim_Match_Backward_Ci, 6,
- "SUBSTRING-MATCH-BACKWARD-CI")
+DEFINE_PRIMITIVE ("SUBSTRING-MATCH-BACKWARD-CI", Prim_Match_Backward_Ci, 6)
{
- substring_match_prefix (end1, end2);
+ SUBSTRING_MATCH_PREFIX (end1, end2);
while (unmatched-- > 0)
if ((char_upcase (*--scan1)) != (char_upcase (*--scan2)))
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/bintopsb.c,v 9.30 1987/11/20 08:21:12 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/bintopsb.c,v 9.31 1987/11/23 05:11:12 cph Exp $
*
* This File contains the code to translate internal format binary
* files to portable format.
#define Internal_File Input_File
#define Portable_File Output_File
-#include "translate.h"
+#include "psbmap.h"
#include "trap.h"
long
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/psbtobin.c,v 9.29 1987/11/20 08:20:36 jinx Exp $
+/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/psbtobin.c,v 9.30 1987/11/23 05:11:58 cph Exp $
*
* This File contains the code to translate portable format binary
* files to internal format.
#define Portable_File Input_File
#define Internal_File Output_File
-#include "translate.h"
+#include "psbmap.h"
static long
Dumped_Object_Addr,
projects / mit-scheme.git / commitdiff