From: Chris Hanson Date: Mon, 23 Nov 1987 05:18:09 +0000 (+0000) Subject: Shorten names of some files to allow Emacs version numbers to be used X-Git-Tag: 20090517-FFI~13038 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=7231e282a562691aa26e25a3121ad15a5dcf661d;p=mit-scheme.git Shorten names of some files to allow Emacs version numbers to be used on ATT file systems. Add alternative primitive definition macro which works correctly with Emacs tags tables. --- diff --git a/v7/src/microcode/bintopsb.c b/v7/src/microcode/bintopsb.c index 39b5eedb1..c58a4a85b 100644 --- a/v7/src/microcode/bintopsb.c +++ b/v7/src/microcode/bintopsb.c @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, 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. @@ -42,7 +42,7 @@ MIT in each case. */ #define Internal_File Input_File #define Portable_File Output_File -#include "translate.h" +#include "psbmap.h" #include "trap.h" long diff --git a/v7/src/microcode/bitstr.c b/v7/src/microcode/bitstr.c index ba7d13e08..28c541811 100644 --- a/v7/src/microcode/bitstr.c +++ b/v7/src/microcode/bitstr.c @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, 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. @@ -54,36 +54,36 @@ allocate_bit_string (length) 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); } void -fill_bit_string( bit_string, sense) +fill_bit_string (bit_string, sense) Pointer bit_string; Boolean sense; { @@ -92,236 +92,231 @@ fill_bit_string( bit_string, 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; } /* (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)))); } -#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); } -#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 (); + } } -#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 (); + } } - } } /* (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() = ~ @@ -330,29 +325,23 @@ Define_Primitive (Prim_bit_string_equal_p, 2, "BIT-STRING=?") #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); } /* (BIT-SUBSTRING-MOVE-RIGHT! source start1 end1 destination start2) Destructively copies the substring of SOURCE between START1 and @@ -360,20 +349,20 @@ Define_Primitive( Prim_bit_string_xor_x, 2, "BIT-STRING-XOR!") 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); @@ -381,9 +370,9 @@ Define_Primitive( Prim_bit_substring_move_right_x, 5, 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); @@ -395,23 +384,25 @@ Define_Primitive( Prim_bit_substring_move_right_x, 5, 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); } -#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 @@ -419,11 +410,11 @@ Define_Primitive( Prim_bit_substring_move_right_x, 5, 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; { - + /* 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 @@ -431,220 +422,229 @@ copy_bits( source, source_offset, destination, destination_offset, nbits) 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)); + } } - } 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); - } - } - - { - 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); + } + } - 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 + + 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); - } - } - - { - 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); + } + } + + { + 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)); + } + } } - } } - } } /* 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)))); } - + Pointer -zero_to_bit_string( length) +zero_to_bit_string (length) long length; { Pointer result; @@ -662,19 +662,19 @@ long_to_bit_string (length, number) 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); + } } /* The bignum <-> bit-string coercion procedures use the following pun: @@ -696,21 +696,21 @@ bignum_to_bit_string (length, bignum) 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); + } } Pointer @@ -724,21 +724,21 @@ bit_string_to_bignum (nbits, bitstr) 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))); } @@ -748,25 +748,24 @@ bit_string_to_bignum (nbits, bitstr) 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); } @@ -774,157 +773,166 @@ Define_Primitive( Prim_unsigned_to_bit_string, 2, 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))); } -#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); } /* 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; \ } \ } -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)); } diff --git a/v7/src/microcode/boot.c b/v7/src/microcode/boot.c index 285ce2db1..dd600d9c1 100644 --- a/v7/src/microcode/boot.c +++ b/v7/src/microcode/boot.c @@ -1,6 +1,6 @@ /* -*-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 @@ -80,7 +80,8 @@ for details. They are created by defining a macro Command_Line_Args. #include "scheme.h" #include "primitive.h" #include "version.h" -#include "character.h" +#include "char.h" +#include "string.h" #ifndef islower #include #endif @@ -610,123 +611,91 @@ Microcode_Termination(code) #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); } -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; - } - + { + 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); } -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); } diff --git a/v7/src/microcode/char.c b/v7/src/microcode/char.c index e1d9e73ab..9b97fd12c 100644 --- a/v7/src/microcode/char.c +++ b/v7/src/microcode/char.c @@ -30,13 +30,13 @@ Technology nor of any adaptation thereof in any advertising, 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 long @@ -69,50 +69,45 @@ arg_ascii_integer (n) return (ascii); } -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)))); } @@ -133,49 +128,49 @@ char_upcase (c) 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") + +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))); } forward Boolean ascii_control_p(); diff --git a/v7/src/microcode/findprim.c b/v7/src/microcode/findprim.c index 5dae4e9d2..e20d1067d 100644 --- a/v7/src/microcode/findprim.c +++ b/v7/src/microcode/findprim.c @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, 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. * @@ -122,11 +122,15 @@ void dump(); 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"; @@ -140,8 +144,6 @@ static char External_Variable[] = "MAX_EXTERNAL_PRIMITIVE"; static FILE *input, *output; static char *name; static char *file_name; - -static pseudo_void (*create_entry)(); main(argc, argv) int argc; @@ -280,21 +282,22 @@ void process_argument(fn) } } -#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; } @@ -304,11 +307,11 @@ process() * 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) @@ -334,17 +337,43 @@ scan() 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); } boolean @@ -510,14 +539,38 @@ create_normal_entry() 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; +} + 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; } @@ -525,10 +578,14 @@ void 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; } @@ -612,10 +669,12 @@ initialize_builtin(arg) 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; diff --git a/v7/src/microcode/intern.c b/v7/src/microcode/intern.c index aca908800..c14c98de2 100644 --- a/v7/src/microcode/intern.c +++ b/v7/src/microcode/intern.c @@ -30,15 +30,14 @@ Technology nor of any adaptation thereof in any advertising, 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" /* Hashing strings and character lists. */ @@ -75,7 +74,7 @@ Hash (string) } Boolean -string_equal(String1, String2) +string_equal (String1, String2) Pointer String1, String2; { fast char *S1, *S2; @@ -154,7 +153,7 @@ Intern (Un_Interned) } Pointer -string_to_symbol(String) +string_to_symbol (String) Pointer String; { Pointer New_Symbol, Interned_Symbol, *Orig_Free; @@ -187,7 +186,7 @@ string_to_symbol(String) */ void -Find_Symbol(scheme_string) +Find_Symbol (scheme_string) Pointer scheme_string; { Pointer the_obarray, symbol, *bucket; @@ -218,15 +217,14 @@ Find_Symbol(scheme_string) /* (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) @@ -235,80 +233,72 @@ Define_Primitive(Prim_String_To_Symbol, 1, "STRING->SYMBOL") 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)))); } /* (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))); } diff --git a/v7/src/microcode/psbtobin.c b/v7/src/microcode/psbtobin.c index 4ded7c8a8..4b0099de1 100644 --- a/v7/src/microcode/psbtobin.c +++ b/v7/src/microcode/psbtobin.c @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, 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. @@ -42,7 +42,7 @@ MIT in each case. */ #define Portable_File Input_File #define Internal_File Output_File -#include "translate.h" +#include "psbmap.h" static long Dumped_Object_Addr, diff --git a/v7/src/microcode/regex.c b/v7/src/microcode/regex.c index 69c5c7f3c..0a4405584 100644 --- a/v7/src/microcode/regex.c +++ b/v7/src/microcode/regex.c @@ -1,6 +1,6 @@ /* -*-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 @@ -35,10 +35,8 @@ MIT in each case. */ /* 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" diff --git a/v7/src/microcode/rgxprim.c b/v7/src/microcode/rgxprim.c index cfc14464b..35262cbc1 100644 --- a/v7/src/microcode/rgxprim.c +++ b/v7/src/microcode/rgxprim.c @@ -1,6 +1,6 @@ /* -*-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 @@ -34,12 +34,10 @@ MIT in each case. */ /* 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" @@ -71,62 +69,65 @@ MIT in each case. */ 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) -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 @@ -142,59 +143,52 @@ Define_Primitive (Prim_re_compile_fastmap, 4, "RE-COMPILE-FASTMAP") 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); } #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; \ @@ -203,23 +197,25 @@ Define_Primitive (Prim_re_search_substr_backward, 7, 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); \ @@ -227,31 +223,23 @@ Define_Primitive (Prim_re_search_substr_backward, 7, 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); } diff --git a/v7/src/microcode/string.c b/v7/src/microcode/string.c index 2156042f3..c959a80d1 100644 --- a/v7/src/microcode/string.c +++ b/v7/src/microcode/string.c @@ -30,14 +30,14 @@ Technology nor of any adaptation thereof in any advertising, 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" Pointer allocate_string (nbytes) @@ -73,55 +73,52 @@ memory_to_string (nbytes, data) /* 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); } -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)); } @@ -136,136 +133,122 @@ substring_length_min (start1, end1, start2, end2) return ((length1 < length2) ? length1 : length2); } -#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); } -#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); } -#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) @@ -275,29 +258,23 @@ Define_Primitive (Prim_Vec_8b_Find_Next_Char, 4, PRIMITIVE_RETURN (NIL); } -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) { @@ -308,17 +285,14 @@ Define_Primitive(Prim_Vec_8b_Find_Next_Char_Ci, 4, 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)); @@ -326,32 +300,29 @@ Define_Primitive(Prim_Vec_8b_Find_Prev_Char_Ci, 4, PRIMITIVE_RETURN (NIL); } -#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') @@ -361,25 +332,22 @@ Define_Primitive(Prim_Find_Next_Char_In_Set, 4, 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); } -#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)); \ @@ -388,54 +356,51 @@ Define_Primitive(Prim_Find_Prev_Char_In_Set, 4, 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); } -Built_In_Primitive (Prim_Substring_Less, 6, "SUBSTRING 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; \ @@ -472,30 +436,24 @@ Define_Primitive (Prim_Substring_Less, 6, "SUBSTRING 0) if ((*scan1++) != (*scan2++)) @@ -503,12 +461,9 @@ Define_Primitive (Prim_Match_Forward, 6, 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++))) @@ -516,12 +471,9 @@ Define_Primitive (Prim_Match_Forward_Ci, 6, 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)) @@ -529,12 +481,9 @@ Define_Primitive (Prim_Match_Backward, 6, 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))) diff --git a/v8/src/microcode/bintopsb.c b/v8/src/microcode/bintopsb.c index 701e1c420..3a2707f3d 100644 --- a/v8/src/microcode/bintopsb.c +++ b/v8/src/microcode/bintopsb.c @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, 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. @@ -42,7 +42,7 @@ MIT in each case. */ #define Internal_File Input_File #define Portable_File Output_File -#include "translate.h" +#include "psbmap.h" #include "trap.h" long diff --git a/v8/src/microcode/psbtobin.c b/v8/src/microcode/psbtobin.c index 23b57d13a..b9dac3643 100644 --- a/v8/src/microcode/psbtobin.c +++ b/v8/src/microcode/psbtobin.c @@ -30,7 +30,7 @@ Technology nor of any adaptation thereof in any advertising, 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. @@ -42,7 +42,7 @@ MIT in each case. */ #define Portable_File Input_File #define Internal_File Output_File -#include "translate.h" +#include "psbmap.h" static long Dumped_Object_Addr,