From: Chris Hanson Date: Thu, 14 May 1987 13:51:20 +0000 (+0000) Subject: Implement new primitive argument checking interface and argument error X-Git-Tag: 20090517-FFI~13518 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=d0c1ffa0ecbf28475e5cd5db49e2f1012db9a5b7;p=mit-scheme.git Implement new primitive argument checking interface and argument error signalling procedures. Start using convention that macro names are all upper case. --- diff --git a/v7/src/microcode/bitstr.c b/v7/src/microcode/bitstr.c index b34da0741..3f409fbf2 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.28 1987/05/09 05:25:54 cph Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/bitstr.c,v 9.29 1987/05/14 13:46:57 cph Exp $ Bit string primitives. */ @@ -95,7 +95,7 @@ Built_In_Primitive (Prim_bit_string_allocate, 1, "BIT-STRING-ALLOCATE", 0xD1) { Primitive_1_Arg (); - return (allocate_bit_string (guarantee_nonnegative_int_arg_1 (Arg1))); + return (allocate_bit_string (arg_nonnegative_integer (1))); } /* (BIT-STRING? object) @@ -106,7 +106,7 @@ Built_In_Primitive (Prim_bit_string_p, 1, "BIT-STRING?", 0xD3) Primitive_1_Arg (); Touch_In_Primitive (Arg1, Arg1); - return ((bit_string_p (Arg1)) ? TRUTH : NIL); + return ((BIT_STRING_P (Arg1)) ? TRUTH : NIL); } void @@ -147,7 +147,7 @@ Built_In_Primitive (Prim_make_bit_string, 2, "MAKE-BIT-STRING", 0xD2) Pointer result; Primitive_2_Args (); - result = allocate_bit_string (guarantee_nonnegative_int_arg_1 (Arg1)); + result = allocate_bit_string (arg_nonnegative_integer (1)); fill_bit_string (result, (Arg2 != NIL)); return (result); } @@ -160,7 +160,7 @@ Built_In_Primitive (Prim_bit_string_fill_x, 2, "BIT-STRING-FILL!", 0x197) { Primitive_2_Args (); - guarantee_bit_string_arg_1 (); + CHECK_ARG (1, BIT_STRING_P); fill_bit_string (Arg1, (Arg2 != NIL)); return (NIL); } @@ -172,20 +172,19 @@ Built_In_Primitive (Prim_bit_string_length, 1, "BIT-STRING-LENGTH", 0xD4) { Primitive_1_Arg (); - guarantee_bit_string_arg_1 (); + CHECK_ARG (1, BIT_STRING_P); return (Make_Unsigned_Fixnum (bit_string_length (Arg1))); } -#define ref_initialization() \ - long index, word, mask; \ - Primitive_2_Args (); \ - \ - guarantee_bit_string_arg_1 (); \ - index = (guarantee_nonnegative_int_arg_2 (Arg2)); \ - if (index > (bit_string_length (Arg1))) \ - Primitive_Error (ERR_ARG_2_BAD_RANGE); \ - \ - word = (index_to_word (Arg1, index)); \ +#define ref_initialization() \ + long index, word, mask; \ + Primitive_2_Args (); \ + \ + CHECK_ARG (1, BIT_STRING_P); \ + index = (arg_nonnegative_integer (2)); \ + if (index > (bit_string_length (Arg1))) error_bad_range_arg (1); \ + \ + word = (index_to_word (Arg1, index)); \ mask = (1 << (index % POINTER_LENGTH)) /* (BIT-STRING-REF bit-string index) @@ -252,7 +251,7 @@ Built_In_Primitive (Prim_bit_string_zero_p, 1, "BIT-STRING-ZERO?", 0xD9) long length, odd_bits; Primitive_1_Args (); - guarantee_bit_string_arg_1 (); + CHECK_ARG (1, BIT_STRING_P); length = (bit_string_length (Arg1)); odd_bits = (length % POINTER_LENGTH); @@ -285,8 +284,8 @@ Built_In_Primitive (Prim_bit_string_equal_p, 2, "BIT-STRING=?", 0x19D) long length; Primitive_2_Args (); - guarantee_bit_string_arg_1 (); - guarantee_bit_string_arg_2 (); + CHECK_ARG (1, BIT_STRING_P); + CHECK_ARG (2, BIT_STRING_P); length = bit_string_length( Arg1); if (length != bit_string_length( Arg2)) @@ -312,23 +311,20 @@ Built_In_Primitive (Prim_bit_string_equal_p, 2, "BIT-STRING=?", 0x19D) } } -#define bitwise_op( action) \ -{ \ - Primitive_2_Args(); \ - \ - if (bit_string_length( Arg1) != bit_string_length( Arg2)) \ - Primitive_Error( ERR_ARG_1_BAD_RANGE) \ - else \ - { \ - long i; \ - Pointer *scan1, *scan2; \ - \ - scan1 = bit_string_start_ptr( Arg1); \ - scan2 = bit_string_start_ptr( Arg2); \ - for (i = (Vector_Length( Arg1) - 1); (i > 0); i -= 1) \ - *scan1++ action() (*scan2++); \ - } \ - return (NIL); \ +#define bitwise_op( action) \ +{ \ + long i; \ + Pointer *scan1, *scan2; \ + Primitive_2_Args (); \ + \ + if ((bit_string_length (Arg1)) != (bit_string_length (Arg2))) \ + error_bad_range_arg (1); \ + \ + scan1 = (bit_string_start_ptr (Arg1)); \ + scan2 = (bit_string_start_ptr (Arg2)); \ + for (i = ((Vector_Length (Arg1)) - 1); (i > 0); i -= 1) \ + (*scan1++) action() (*scan2++); \ + return (NIL); \ } #define bit_string_move_x_action() = @@ -366,21 +362,21 @@ Built_In_Primitive( Prim_bit_substring_move_right_x, 5, void copy_bits(); Primitive_5_Args(); - guarantee_bit_string_arg_1 (); - start1 = (guarantee_nonnegative_int_arg_2 (Arg2)); - end1 = (guarantee_nonnegative_int_arg_3 (Arg3)); - guarantee_bit_string_arg_4 (); - start2 = (guarantee_nonnegative_int_arg_5 (Arg5)); + CHECK_ARG (1, BIT_STRING_P); + start1 = (arg_nonnegative_integer (2)); + end1 = (arg_nonnegative_integer (3)); + CHECK_ARG (4, BIT_STRING_P); + start2 = (arg_nonnegative_integer (5)); nbits = (end1 - start1); end2 = (start2 + nbits); if ((start1 < 0) || (start1 > end1)) - Primitive_Error (ERR_ARG_2_BAD_RANGE); - if (end1 > bit_string_length( Arg1)) - Primitive_Error (ERR_ARG_3_BAD_RANGE); - if ((start2 < 0) || (end2 > bit_string_length( Arg4))) - Primitive_Error (ERR_ARG_5_BAD_RANGE); + error_bad_range_arg (2); + if (end1 > (bit_string_length (Arg1))) + error_bad_range_arg (3); + if ((start2 < 0) || (end2 > (bit_string_length (Arg4)))) + error_bad_range_arg (5); end1_mod = (end1 % POINTER_LENGTH); end2_mod = (end2 % POINTER_LENGTH); @@ -399,12 +395,12 @@ Built_In_Primitive( Prim_bit_substring_move_right_x, 5, return (NIL); } -#define masked_transfer( source, destination, nbits, offset) \ -{ \ - long mask; \ - \ - mask = any_mask( nbits, offset); \ - *destination = ((*source & mask) | (*destination & ~mask)); \ +#define masked_transfer( source, destination, nbits, offset) \ +{ \ + long mask; \ + \ + mask = any_mask( nbits, offset); \ + *destination = ((*source & mask) | (*destination & ~mask)); \ } /* This procedure copies bits from one place to another. @@ -637,21 +633,19 @@ long_to_bit_string (length, number) long length, number; { if (number < 0) - Primitive_Error (ERR_ARG_2_BAD_RANGE) - else if (number == 0) + error_bad_range_arg (2); + + if (number == 0) zero_to_bit_string (length); else { - if (length < (long_significant_bits (number))) - Primitive_Error (ERR_ARG_2_BAD_RANGE) - else - { - Pointer result; + Pointer result; - result = (zero_to_bit_string (length)); - Fast_Vector_Set (result, (Vector_Length (result)), number); - return (result); - } + if (length < (long_significant_bits (number))) + error_bad_range_arg (2); + result = (zero_to_bit_string (length)); + Fast_Vector_Set (result, (Vector_Length (result)), number); + return (result); } } @@ -665,28 +659,25 @@ bignum_to_bit_string (length, bignum) bigptr = (BIGNUM (Get_Pointer (bignum))); if (NEG_BIGNUM (bigptr)) - Primitive_Error (ERR_ARG_2_BAD_RANGE); + error_bad_range_arg (2); ndigits = (LEN (bigptr)); 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)))) - Primitive_Error (ERR_ARG_2_BAD_RANGE) - else - { - Pointer result; - bigdigit *scan1, *scan2; - - result = (zero_to_bit_string (length)); - scan1 = (Bignum_Bottom (bigptr)); - scan2 = ((bigdigit *) (bit_string_end_ptr (result))); - for (; (ndigits > 0); ndigits -= 1) - *--scan2 = *scan1++; - return (result); - } + error_bad_range_arg (2); + result = (zero_to_bit_string (length)); + scan1 = (Bignum_Bottom (bigptr)); + scan2 = ((bigdigit *) (bit_string_end_ptr (result))); + for (; (ndigits > 0); ndigits -= 1) + *--scan2 = *scan1++; + return (result); } } @@ -701,15 +692,17 @@ Built_In_Primitive( Prim_unsigned_to_bit_string, 2, long length; Primitive_2_Args (); - length = (guarantee_nonnegative_int_arg_1 (Arg1)); - if (length < 0) - Primitive_Error (ERR_ARG_1_BAD_RANGE) - else if ((Type_Code (Arg2)) == TC_FIXNUM) - return (long_to_bit_string (length, (Get_Integer (Arg2)))); - else if ((Type_Code (Arg2)) == TC_BIG_FIXNUM) + length = (arg_nonnegative_integer (1)); + + if (FIXNUM_P (Arg2)) + { + if (FIXNUM_NEGATIVE_P (Arg2)) + error_bad_range_arg (2); + return (long_to_bit_string (length, (UNSIGNED_FIXNUM_VALUE (Arg2)))); + } + if (BIGNUM_P (Arg2)) return (bignum_to_bit_string (length, Arg2)); - else - Primitive_Error (ERR_ARG_2_WRONG_TYPE) + error_wrong_type_arg (2); } /* (BIT-STRING->UNSIGNED-INTEGER bit-string) @@ -725,7 +718,7 @@ Built_In_Primitive( Prim_bit_string_to_unsigned, 1, Primitive_1_Arg(); - guarantee_bit_string_arg_1 (); + CHECK_ARG (1, BIT_STRING_P); /* Count the number of significant bits.*/ scan = bit_string_start_ptr( Arg1); @@ -777,11 +770,11 @@ Built_In_Primitive (Prim_read_bits_x, 3, "READ-BITS!", 0xDF) long end, end_mod; Primitive_3_Args (); - guarantee_bit_string_arg_3 (); + CHECK_ARG (3, BIT_STRING_P); end = (bit_string_length (Arg3)); end_mod = (end % POINTER_LENGTH); copy_bits ((Nth_Vector_Loc (Arg1, 0)), - (guarantee_nonnegative_int_arg_2 (Arg2)), + (arg_nonnegative_integer (2)), (Nth_Vector_Loc (Arg3, (index_to_word (Arg3, (end - 1))))), ((end_mod == 0) ? 0 : (POINTER_LENGTH - end_mod)), end); @@ -797,35 +790,35 @@ Built_In_Primitive (Prim_write_bits_x, 3, "WRITE-BITS!", 0xE0) long end, end_mod; Primitive_3_Args (); - guarantee_bit_string_arg_3 (); + CHECK_ARG (3, BIT_STRING_P); end = (bit_string_length (Arg3)); end_mod = (end % POINTER_LENGTH); copy_bits ((Nth_Vector_Loc (Arg3, (index_to_word (Arg3, (end - 1))))), ((end_mod == 0) ? 0 : (POINTER_LENGTH - end_mod)), (Nth_Vector_Loc (Arg1, 0)), - (guarantee_nonnegative_int_arg_2 (Arg2)), + (arg_nonnegative_integer (2)), end); return (NIL); } /* Search Primitives */ -#define substring_find_initialize() \ - long start, end; \ - long word, bit, end_word, end_bit, mask; \ - Pointer *scan; \ - Primitive_3_Args (); \ - \ - guarantee_bit_string_arg_1 (); \ - start = (guarantee_nonnegative_int_arg_2 (Arg2)); \ - end = (guarantee_nonnegative_int_arg_3 (Arg3)); \ - \ - if (end > (bit_string_length (Arg1))) \ - error_bad_range_arg_3 (); \ - if (start > end) \ - error_bad_range_arg_2 (); \ - \ - if (start == end) \ +#define substring_find_initialize() \ + long start, end; \ + long word, bit, end_word, end_bit, mask; \ + Pointer *scan; \ + Primitive_3_Args (); \ + \ + CHECK_ARG (1, BIT_STRING_P); \ + start = (arg_nonnegative_integer (2)); \ + end = (arg_nonnegative_integer (3)); \ + \ + if (end > (bit_string_length (Arg1))) \ + error_bad_range_arg (3); \ + if (start > end) \ + error_bad_range_arg (2); \ + \ + if (start == end) \ return (NIL); #define substring_find_next_initialize() \ diff --git a/v7/src/microcode/bitstr.h b/v7/src/microcode/bitstr.h index 4832bc446..0b8f44de5 100644 --- a/v7/src/microcode/bitstr.h +++ b/v7/src/microcode/bitstr.h @@ -1,6 +1,6 @@ /* -*-C-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/bitstr.h,v 1.1 1987/04/25 20:24:49 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/bitstr.h,v 1.2 1987/05/14 13:47:34 cph Rel $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -34,23 +34,6 @@ MIT in each case. */ /* Bit string macros. */ -#define bit_string_p(P) ((pointer_type (P)) == TC_BIT_STRING) - -#define guarantee_bit_string_arg_1() \ -if (! (bit_string_p (Arg1))) error_wrong_type_arg_1 () - -#define guarantee_bit_string_arg_2() \ -if (! (bit_string_p (Arg2))) error_wrong_type_arg_2 () - -#define guarantee_bit_string_arg_3() \ -if (! (bit_string_p (Arg3))) error_wrong_type_arg_3 () - -#define guarantee_bit_string_arg_4() \ -if (! (bit_string_p (Arg4))) error_wrong_type_arg_4 () - -#define guarantee_bit_string_arg_5() \ -if (! (bit_string_p (Arg5))) error_wrong_type_arg_5 () - #define bit_string_length(bit_string) \ (Fast_Vector_Ref (bit_string, NM_ENTRY_COUNT)) diff --git a/v7/src/microcode/char.c b/v7/src/microcode/char.c index eb0eab590..4275499b7 100644 --- a/v7/src/microcode/char.c +++ b/v7/src/microcode/char.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/char.c,v 9.21 1987/04/16 02:18:50 jinx Exp $ */ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/char.c,v 9.22 1987/05/14 13:47:45 cph Rel $ */ /* Character primitives. */ @@ -39,122 +39,43 @@ MIT in each case. */ #include "character.h" #include -#define define_ascii_char_guarantee(procedure_name, wta, bra) \ -long \ -procedure_name (argument) \ - Pointer argument; \ -{ \ - fast long ascii; \ - \ - if (! (character_p (argument))) \ - wta (); \ - ascii = (scheme_char_to_c_char (argument)); \ - if (ascii == NOT_ASCII) \ - bra (); \ - return (ascii); \ -} - -define_ascii_char_guarantee (guarantee_ascii_char_arg_1, - error_wrong_type_arg_1, - error_bad_range_arg_1) - -define_ascii_char_guarantee (guarantee_ascii_char_arg_2, - error_wrong_type_arg_2, - error_bad_range_arg_2) - -define_ascii_char_guarantee (guarantee_ascii_char_arg_3, - error_wrong_type_arg_3, - error_bad_range_arg_3) - -define_ascii_char_guarantee (guarantee_ascii_char_arg_4, - error_wrong_type_arg_4, - error_bad_range_arg_4) - -define_ascii_char_guarantee (guarantee_ascii_char_arg_5, - error_wrong_type_arg_5, - error_bad_range_arg_5) - -define_ascii_char_guarantee (guarantee_ascii_char_arg_6, - error_wrong_type_arg_6, - error_bad_range_arg_6) - -define_ascii_char_guarantee (guarantee_ascii_char_arg_7, - error_wrong_type_arg_7, - error_bad_range_arg_7) - -define_ascii_char_guarantee (guarantee_ascii_char_arg_8, - error_wrong_type_arg_8, - error_bad_range_arg_8) - -define_ascii_char_guarantee (guarantee_ascii_char_arg_9, - error_wrong_type_arg_9, - error_bad_range_arg_9) +long +arg_ascii_char (n) + int n; +{ + fast long ascii; -define_ascii_char_guarantee (guarantee_ascii_char_arg_10, - error_wrong_type_arg_10, - error_bad_range_arg_10) - -#define define_ascii_integer_guarantee(procedure_name, wta, bra) \ -long \ -procedure_name (argument) \ - Pointer argument; \ -{ \ - fast long ascii; \ - \ - if (! (fixnum_p (argument))) wta (); \ - if (fixnum_negative_p (argument)) bra (); \ - ascii = (pointer_datum (argument)); \ - if (ascii >= MAX_ASCII) bra (); \ - return (ascii); \ + CHECK_ARG (n, CHARACTER_P); + ascii = (scheme_char_to_c_char (ARG_REF (n))); + if (ascii == NOT_ASCII) + error_bad_range_arg (n); + return (ascii); } -define_ascii_integer_guarantee (guarantee_ascii_integer_arg_1, - error_wrong_type_arg_1, - error_bad_range_arg_1) - -define_ascii_integer_guarantee (guarantee_ascii_integer_arg_2, - error_wrong_type_arg_2, - error_bad_range_arg_2) - -define_ascii_integer_guarantee (guarantee_ascii_integer_arg_3, - error_wrong_type_arg_3, - error_bad_range_arg_3) - -define_ascii_integer_guarantee (guarantee_ascii_integer_arg_4, - error_wrong_type_arg_4, - error_bad_range_arg_4) - -define_ascii_integer_guarantee (guarantee_ascii_integer_arg_5, - error_wrong_type_arg_5, - error_bad_range_arg_5) - -define_ascii_integer_guarantee (guarantee_ascii_integer_arg_6, - error_wrong_type_arg_6, - error_bad_range_arg_6) - -define_ascii_integer_guarantee (guarantee_ascii_integer_arg_7, - error_wrong_type_arg_7, - error_bad_range_arg_7) - -define_ascii_integer_guarantee (guarantee_ascii_integer_arg_8, - error_wrong_type_arg_8, - error_bad_range_arg_8) - -define_ascii_integer_guarantee (guarantee_ascii_integer_arg_9, - error_wrong_type_arg_9, - error_bad_range_arg_9) - -define_ascii_integer_guarantee (guarantee_ascii_integer_arg_10, - error_wrong_type_arg_10, - error_bad_range_arg_10) +long +arg_ascii_integer (n) + int n; +{ + fast Pointer arg; + fast long ascii; + + CHECK_ARG (n, FIXNUM_P); + arg = (ARG_REF (n)); + if (FIXNUM_NEGATIVE_P (arg)) + error_bad_range_arg (n); + FIXNUM_VALUE (arg, ascii); + if (ascii >= MAX_ASCII) + error_bad_range_arg (n); + return (ascii); +} Built_In_Primitive (Prim_Make_Char, 2, "MAKE-CHAR", 0x14) { long bucky_bits, code; Primitive_2_Args (); - code = (guarantee_index_arg_1 (Arg1, MAX_CODE)); - bucky_bits = (guarantee_index_arg_2 (Arg2, MAX_BITS)); + code = (arg_index_integer (1, MAX_CODE)); + bucky_bits = (arg_index_integer (2, MAX_BITS)); return (make_char (bucky_bits, code)); } @@ -162,24 +83,24 @@ Built_In_Primitive (Prim_Char_Bits, 1, "CHAR-BITS", 0x15) { Primitive_1_Arg (); - guarantee_char_arg_1 (); - return (Make_Unsigned_Fixnum (char_bits (Arg1))); + CHECK_ARG (1, CHARACTER_P); + return (MAKE_UNSIGNED_FIXNUM (char_bits (Arg1))); } Built_In_Primitive (Prim_Char_Code, 1, "CHAR-CODE", 0x17) { Primitive_1_Arg (); - guarantee_char_arg_1 (); - return (Make_Unsigned_Fixnum (char_code (Arg1))); + CHECK_ARG (1, CHARACTER_P); + return (MAKE_UNSIGNED_FIXNUM (char_code (Arg1))); } Built_In_Primitive (Prim_Char_To_Integer, 1, "CHAR->INTEGER", 0x1B) { Primitive_1_Arg (); - guarantee_char_arg_1 (); - return (Make_Unsigned_Fixnum (Arg1 & MASK_EXTNDD_CHAR)); + CHECK_ARG (1, CHARACTER_P); + return (MAKE_UNSIGNED_FIXNUM (Arg1 & MASK_EXTNDD_CHAR)); } Built_In_Primitive (Prim_Integer_To_Char, 1, "INTEGER->CHAR", 0x34) @@ -188,7 +109,7 @@ Built_In_Primitive (Prim_Integer_To_Char, 1, "INTEGER->CHAR", 0x34) return (Make_Non_Pointer (TC_CHARACTER, - (guarantee_index_arg_1 (Arg1, MAX_EXTNDD_CHAR)))); + (arg_index_integer (1, MAX_EXTNDD_CHAR)))); } long @@ -211,7 +132,7 @@ Built_In_Primitive (Prim_Char_Downcase, 1, "CHAR-DOWNCASE", 0x35) { Primitive_1_Arg (); - guarantee_char_arg_1 (); + CHECK_ARG (1, CHARACTER_P); return (make_char ((char_bits (Arg1)), (char_downcase (char_code (Arg1))))); } @@ -219,7 +140,7 @@ Built_In_Primitive (Prim_Char_Upcase, 1, "CHAR-UPCASE", 0x36) { Primitive_1_Arg (); - guarantee_char_arg_1 (); + CHECK_ARG (1, CHARACTER_P); return (make_char ((char_bits (Arg1)), (char_upcase (char_code (Arg1))))); } @@ -227,14 +148,14 @@ Built_In_Primitive (Prim_Ascii_To_Char, 1, "ASCII->CHAR", 0x37) { Primitive_1_Arg (); - return (c_char_to_scheme_char (guarantee_ascii_integer_arg_1 (Arg1))); + return (c_char_to_scheme_char (arg_ascii_integer (1))); } Built_In_Primitive (Prim_Char_To_Ascii, 1, "CHAR->ASCII", 0x39) { Primitive_1_Arg (); - return (Make_Unsigned_Fixnum (guarantee_ascii_char_arg_1 (Arg1))); + return (MAKE_UNSIGNED_FIXNUM (arg_ascii_char (1))); } Built_In_Primitive (Prim_Char_Ascii_P, 1, "CHAR-ASCII?", 0x38) @@ -242,9 +163,9 @@ Built_In_Primitive (Prim_Char_Ascii_P, 1, "CHAR-ASCII?", 0x38) long ascii; Primitive_1_Arg (); - guarantee_char_arg_1 (); + CHECK_ARG (1, CHARACTER_P); ascii = (scheme_char_to_c_char (Arg1)); - return ((ascii == NOT_ASCII) ? NIL : (Make_Unsigned_Fixnum (ascii))); + return ((ascii == NOT_ASCII) ? NIL : (MAKE_UNSIGNED_FIXNUM (ascii))); } forward Boolean ascii_control_p(); diff --git a/v7/src/microcode/fixnum.c b/v7/src/microcode/fixnum.c index 9ec60cabf..eba6b8ad1 100644 --- a/v7/src/microcode/fixnum.c +++ b/v7/src/microcode/fixnum.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fixnum.c,v 9.23 1987/05/09 18:27:24 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/fixnum.c,v 9.24 1987/05/14 13:48:41 cph Rel $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -43,28 +43,20 @@ MIT in each case. */ #define FIXNUM_PRIMITIVE_1(parameter_1) \ fast long parameter_1; \ Primitive_1_Arg (); \ - FIXNUM_ARG_1 (); \ + CHECK_ARG (1, FIXNUM_P); \ Sign_Extend (Arg1, parameter_1) #define FIXNUM_PRIMITIVE_2(parameter_1, parameter_2) \ fast long parameter_1, parameter_2; \ Primitive_2_Args (); \ - FIXNUM_ARG_1 (parameter_1); \ - FIXNUM_ARG_2 (parameter_2); \ + CHECK_ARG (1, FIXNUM_P); \ + CHECK_ARG (2, FIXNUM_P); \ Sign_Extend (Arg1, parameter_1); \ Sign_Extend (Arg2, parameter_2) -#define FIXNUM_ARG_1(parameter) \ - if (! (fixnum_p (Arg1))) \ - error_wrong_type_arg_1 () - -#define FIXNUM_ARG_2(parameter) \ - if (! (fixnum_p (Arg2))) \ - error_wrong_type_arg_2 () - #define FIXNUM_RESULT(fixnum) \ if (! (Fixnum_Fits (fixnum))) \ - error_bad_range_arg_1 (); \ + error_bad_range_arg (1); \ return (Make_Signed_Fixnum (fixnum)); #define BOOLEAN_RESULT(x) \ @@ -150,11 +142,11 @@ Built_In_Primitive (Prim_Multiply_Fixnum, 2, "MULTIPLY-FIXNUM", 0x3D) fast long result; Primitive_2_Args (); - FIXNUM_ARG_1 (); - FIXNUM_ARG_2 (); + CHECK_ARG (1, FIXNUM_P); + CHECK_ARG (2, FIXNUM_P); result = (Mul (Arg1, Arg2)); if (result == NIL) - error_bad_range_arg_1 (); + error_bad_range_arg (1); return (result); } @@ -165,11 +157,11 @@ Built_In_Primitive (Prim_Divide_Fixnum, 2, "DIVIDE-FIXNUM", 0x3E) FIXNUM_PRIMITIVE_2 (numerator, denominator); if (denominator == 0) - error_bad_range_arg_2 (); + error_bad_range_arg (2); Primitive_GC_If_Needed (2); quotient = (numerator / denominator); if (! (Fixnum_Fits (quotient))) - error_bad_range_arg_1 (); + error_bad_range_arg (1); Free[CONS_CAR] = (Make_Signed_Fixnum (quotient)); Free[CONS_CDR] = (Make_Signed_Fixnum (numerator % denominator)); Free += 2; diff --git a/v7/src/microcode/hooks.c b/v7/src/microcode/hooks.c index 8ffa26132..b9e51b26d 100644 --- a/v7/src/microcode/hooks.c +++ b/v7/src/microcode/hooks.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/hooks.c,v 9.23 1987/04/16 02:23:49 jinx Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/hooks.c,v 9.24 1987/05/14 13:48:56 cph Rel $ * * This file contains various hooks and handles which connect the * primitives with the main interpreter. @@ -504,7 +504,7 @@ Built_In_Primitive(Prim_Set_Current_History, 1, "SET-CURRENT-HISTORY!", 0x2F) */ if ((safe_pointer_type (Arg1)) != TC_HUNK3) - error_wrong_type_arg_1 (); + error_wrong_type_arg (1); Val = *History; #ifdef COMPILE_HISTORY diff --git a/v7/src/microcode/object.h b/v7/src/microcode/object.h index 938fdcd00..b1cc2ce8c 100644 --- a/v7/src/microcode/object.h +++ b/v7/src/microcode/object.h @@ -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/object.h,v 9.22 1987/04/16 02:27:09 jinx Exp $ */ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/object.h,v 9.23 1987/05/14 13:49:24 cph Rel $ */ /* This file contains definitions pertaining to the C view of Scheme pointers: widths of fields, extraction macros, pre-computed @@ -83,22 +83,25 @@ MIT in each case. */ #endif #ifndef UNSIGNED_SHIFT /* Safe version */ -#define pointer_type(P) (((P) >> ADDRESS_LENGTH) & MAX_TYPE_CODE) +#define OBJECT_TYPE(P) (((P) >> ADDRESS_LENGTH) & MAX_TYPE_CODE) #define safe_pointer_type(P) (((P) >> ADDRESS_LENGTH) & SAFE_TYPE_MASK) #else /* Faster for logical shifts */ -#define pointer_type(P) ((P) >> ADDRESS_LENGTH) +#define OBJECT_TYPE(P) ((P) >> ADDRESS_LENGTH) #define safe_pointer_type(P) ((pointer_type (P)) & SAFE_TYPE_MASK) #endif -#define pointer_datum(P) ((P) & ADDRESS_MASK) +#define OBJECT_DATUM(P) ((P) & ADDRESS_MASK) /* compatibility definitions */ -#define Type_Code(P) (pointer_type (P)) +#define Type_Code(P) (OBJECT_TYPE (P)) #define Safe_Type_Code(P) (safe_pointer_type (P)) -#define Datum(P) (pointer_datum (P)) +#define Datum(P) (OBJECT_DATUM (P)) + +#define pointer_type(P) (OBJECT_TYPE (P)) +#define pointer_datum(P) (OBJECT_DATUM (P)) #define Make_Object(TC, D) \ -((((unsigned) (TC)) << ADDRESS_LENGTH) | (pointer_datum (D))) +((((unsigned) (TC)) << ADDRESS_LENGTH) | (OBJECT_DATUM (D))) #ifndef Heap_In_Low_Memory /* Safe version */ @@ -114,7 +117,7 @@ extern Pointer *Memory_Base; Heap = Memory_Base, \ ((Memory_Base + (space)) - 1)) -#define Get_Pointer(P) ((Pointer *) (Memory_Base + (pointer_datum (P)))) +#define Get_Pointer(P) ((Pointer *) (Memory_Base + (OBJECT_DATUM (P)))) #define C_To_Scheme(P) ((Pointer) ((P) - Memory_Base)) #else /* Storing absolute addresses */ @@ -133,7 +136,7 @@ typedef long relocation_type; /* Used to relocate pointers on fasload */ #else /* Not Spectrum, fast case */ -#define Get_Pointer(P) ((Pointer *) (pointer_datum (P))) +#define Get_Pointer(P) ((Pointer *) (OBJECT_DATUM (P))) #define C_To_Scheme(P) ((Pointer) (P)) #endif /* spectrum */ @@ -150,9 +153,9 @@ typedef long relocation_type; /* Used to relocate pointers on fasload */ #define Store_Type_Code(P, TC) P = (Make_Object ((TC), (P))) #define Store_Address(P, A) \ - P = (((P) & TYPE_CODE_MASK) | (pointer_datum ((Pointer) (A)))) + P = (((P) & TYPE_CODE_MASK) | (OBJECT_DATUM ((Pointer) (A)))) -#define Address(P) (pointer_datum (P)) +#define Address(P) (OBJECT_DATUM (P)) /* These are used only where the object is known to be immutable. On a parallel processor they don't require atomic references */ @@ -171,14 +174,55 @@ typedef long relocation_type; /* Used to relocate pointers on fasload */ #define User_Vector_Ref(P, N) Vector_Ref(P, (N)+1) #define User_Vector_Set(P, N, S) Vector_Set(P, (N)+1, S) +#define FIXNUM_P(object) ((OBJECT_TYPE (object)) == TC_FIXNUM) +#define BIGNUM_P(object) ((OBJECT_TYPE (object)) == TC_BIG_FIXNUM) +#define FLONUM_P(object) ((OBJECT_TYPE (object)) == TC_BIG_FLONUM) +#define COMPLEX_P(object) ((OBJECT_TYPE (object)) == TC_COMPLEX) +#define CHARACTER_P(object) ((OBJECT_TYPE (object)) == TC_CHARACTER) +#define STRING_P(object) ((OBJECT_TYPE (object)) == TC_CHARACTER_STRING) +#define BIT_STRING_P(object) ((OBJECT_TYPE (object)) == TC_BIT_STRING) +#define CELL_P(object) ((OBJECT_TYPE (object)) == TC_CELL) +#define PAIR_P(object) ((OBJECT_TYPE (object)) == TC_LIST) +#define WEAK_PAIR_P(object) ((OBJECT_TYPE (object)) == TC_WEAK_CONS) +#define VECTOR_P(object) ((OBJECT_TYPE (object)) == TC_VECTOR) + +#define SYMBOL_P(object) \ + (((OBJECT_TYPE (object)) == TC_INTERNED_SYMBOL) || \ + ((OBJECT_TYPE (object)) == TC_UNINTERNED_SYMBOL)) + +#define INTEGER_P(object) \ + (((OBJECT_TYPE (object)) == TC_FIXNUM) || \ + ((OBJECT_TYPE (object)) == TC_BIG_FIXNUM)) + +#define REAL_P(object) \ + (((OBJECT_TYPE (object)) == TC_FIXNUM) || \ + ((OBJECT_TYPE (object)) == TC_BIG_FIXNUM) || \ + ((OBJECT_TYPE (object)) == TC_BIG_FLONUM)) + +#define NUMBER_P(object) \ + (((OBJECT_TYPE (object)) == TC_FIXNUM) || \ + ((OBJECT_TYPE (object)) == TC_BIG_FIXNUM) || \ + ((OBJECT_TYPE (object)) == TC_BIG_FLONUM) \ + ((OBJECT_TYPE (object)) == TC_COMPLEX)) + +#define MAKE_FIXNUM(N) (Make_Non_Pointer (TC_FIXNUM, (N))) +#define FIXNUM_NEGATIVE_P(fixnum) (((fixnum) & FIXNUM_SIGN_BIT) != 0) +#define MAKE_UNSIGNED_FIXNUM(N) (FIXNUM_ZERO + (N)) +#define UNSIGNED_FIXNUM_VALUE(fixnum) (OBJECT_DATUM (fixnum)) + +#define FIXNUM_VALUE(fixnum, target) \ +do \ +{ \ + (target) = (UNSIGNED_FIXNUM_VALUE (fixnum)); \ + if (FIXNUM_NEGATIVE_P (target)) \ + (target) |= (-1 << ADDRESS_LENGTH); \ +} while (0) + #define Make_Broken_Heart(N) (BROKEN_HEART_ZERO + (N)) #define Make_Unsigned_Fixnum(N) (FIXNUM_ZERO + (N)) #define Make_Signed_Fixnum(N) Make_Non_Pointer( TC_FIXNUM, (N)) -#define fixnum_p(P) ((pointer_type (P)) == TC_FIXNUM) #define Get_Float(P) (* ((double *) (Nth_Vector_Loc ((P), 1)))) -#define Get_Integer(P) (pointer_datum (P)) - -#define fixnum_negative_p(P) (((P) & FIXNUM_SIGN_BIT) != 0) +#define Get_Integer(P) (OBJECT_DATUM (P)) #define Sign_Extend(P, S) \ { \ diff --git a/v7/src/microcode/prims.h b/v7/src/microcode/prims.h index b54d73a0d..a5558f227 100644 --- a/v7/src/microcode/prims.h +++ b/v7/src/microcode/prims.h @@ -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/prims.h,v 9.23 1987/04/29 13:50:24 cph Exp $ */ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/prims.h,v 9.24 1987/05/14 13:49:36 cph Exp $ */ /* This file contains some macros for defining primitives, for argument type or value checking, and for accessing @@ -141,83 +141,57 @@ if (GC_Check (Amount)) Primitive_GC(Amount) if ((To_Where < (Low)) || (To_Where > (High))) \ Primitive_Error (Error); \ } + +#define CHECK_ARG(argument, type_p) \ +do \ +{ \ + if (! (type_p (ARG_REF (argument)))) \ + error_wrong_type_arg (argument); \ +} while (0) + +#define ARG_REF(argument) (Stack_Ref (argument - 1)) + +extern long arg_nonnegative_integer (); +extern long arg_index_integer (); +/* Instances of the following should be flushed. */ + #define Arg_1_Type(TC) \ -if ((pointer_type (Arg1)) != (TC)) error_wrong_type_arg_1 () +do { if ((pointer_type (Arg1)) != (TC)) error_wrong_type_arg (1); } while (0) #define Arg_2_Type(TC) \ -if ((pointer_type (Arg2)) != (TC)) error_wrong_type_arg_2 () +do { if ((pointer_type (Arg2)) != (TC)) error_wrong_type_arg (2); } while (0) #define Arg_3_Type(TC) \ -if ((pointer_type (Arg3)) != (TC)) error_wrong_type_arg_3 () +do { if ((pointer_type (Arg3)) != (TC)) error_wrong_type_arg (3); } while (0) #define Arg_4_Type(TC) \ -if ((pointer_type (Arg4)) != (TC)) error_wrong_type_arg_4 () +do { if ((pointer_type (Arg4)) != (TC)) error_wrong_type_arg (4); } while (0) #define Arg_5_Type(TC) \ -if ((pointer_type (Arg5)) != (TC)) error_wrong_type_arg_5 () +do { if ((pointer_type (Arg5)) != (TC)) error_wrong_type_arg (5); } while (0) #define Arg_6_Type(TC) \ -if ((pointer_type (Arg6)) != (TC)) error_wrong_type_arg_6 () +do { if ((pointer_type (Arg6)) != (TC)) error_wrong_type_arg (6); } while (0) #define Arg_7_Type(TC) \ -if ((pointer_type (Arg7)) != (TC)) error_wrong_type_arg_7 () +do { if ((pointer_type (Arg7)) != (TC)) error_wrong_type_arg (7); } while (0) #define Arg_8_Type(TC) \ -if ((pointer_type (Arg8)) != (TC)) error_wrong_type_arg_8 () +do { if ((pointer_type (Arg8)) != (TC)) error_wrong_type_arg (8); } while (0) #define Arg_9_Type(TC) \ -if ((pointer_type (Arg9)) != (TC)) error_wrong_type_arg_9 () +do { if ((pointer_type (Arg9)) != (TC)) error_wrong_type_arg (9); } while (0) #define Arg_10_Type(TC) \ -if ((pointer_type (Arg10)) != (TC)) error_wrong_type_arg_10 () +do { if ((pointer_type (Arg10)) != (TC)) error_wrong_type_arg (10); } while (0) #define Arg_1_GC_Type(GCTC) \ -if ((GC_Type (Arg1)) != GCTC) error_wrong_type_arg_1 () +do { if ((GC_Type (Arg1)) != GCTC) error_wrong_type_arg (1); } while (0) #define Arg_2_GC_Type(GCTC) \ -if ((GC_Type (Arg2)) != GCTC) error_wrong_type_arg_2 () +do { if ((GC_Type (Arg2)) != GCTC) error_wrong_type_arg (2); } while (0) #define Arg_3_GC_Type(GCTC) \ -if ((GC_Type (Arg3)) != GCTC) error_wrong_type_arg_3 () - -#define guarantee_fixnum_arg_1() \ -if (! (fixnum_p (Arg1))) error_wrong_type_arg_1 () - -#define guarantee_fixnum_arg_2() \ -if (! (fixnum_p (Arg2))) error_wrong_type_arg_2 () - -#define guarantee_fixnum_arg_3() \ -if (! (fixnum_p (Arg3))) error_wrong_type_arg_3 () - -#define guarantee_fixnum_arg_4() \ -if (! (fixnum_p (Arg4))) error_wrong_type_arg_4 () - -#define guarantee_fixnum_arg_5() \ -if (! (fixnum_p (Arg5))) error_wrong_type_arg_5 () - -#define guarantee_fixnum_arg_6() \ -if (! (fixnum_p (Arg6))) error_wrong_type_arg_6 () - -extern long guarantee_nonnegative_int_arg_1(); -extern long guarantee_nonnegative_int_arg_2(); -extern long guarantee_nonnegative_int_arg_3(); -extern long guarantee_nonnegative_int_arg_4(); -extern long guarantee_nonnegative_int_arg_5(); -extern long guarantee_nonnegative_int_arg_6(); -extern long guarantee_nonnegative_int_arg_7(); -extern long guarantee_nonnegative_int_arg_8(); -extern long guarantee_nonnegative_int_arg_9(); -extern long guarantee_nonnegative_int_arg_10(); - -extern long guarantee_index_arg_1(); -extern long guarantee_index_arg_2(); -extern long guarantee_index_arg_3(); -extern long guarantee_index_arg_4(); -extern long guarantee_index_arg_5(); -extern long guarantee_index_arg_6(); -extern long guarantee_index_arg_7(); -extern long guarantee_index_arg_8(); -extern long guarantee_index_arg_9(); -extern long guarantee_index_arg_10(); +do { if ((GC_Type (Arg3)) != GCTC) error_wrong_type_arg (3); } while (0) diff --git a/v7/src/microcode/string.c b/v7/src/microcode/string.c index 594c10496..cc1701d68 100644 --- a/v7/src/microcode/string.c +++ b/v7/src/microcode/string.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/string.c,v 9.23 1987/04/16 02:30:34 jinx Exp $ */ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/string.c,v 9.24 1987/05/14 13:49:47 cph Exp $ */ /* String primitives. */ @@ -48,7 +48,7 @@ Built_In_Primitive (Prim_String_Allocate, 1, "STRING-ALLOCATE", 0x13E) Pointer result; Primitive_1_Arg (); - length = (guarantee_nonnegative_int_arg_1 (Arg1)); + length = (arg_nonnegative_integer (1)); /* Add 1 to length to account for '\0' at end of string. Add 2 to count to account for string header words. */ count = @@ -69,14 +69,14 @@ Built_In_Primitive (Prim_String_P, 1, "STRING?", 0x138) { Primitive_1_Arg (); - return ((string_p (Arg1)) ? TRUTH : NIL); + return ((STRING_P (Arg1)) ? TRUTH : NIL); } Built_In_Primitive (Prim_String_Length, 1, "STRING-LENGTH", 0x139) { Primitive_1_Arg (); - guarantee_string_arg_1 (); + CHECK_ARG (1, STRING_P); return (Make_Unsigned_Fixnum (string_length (Arg1))); } @@ -85,7 +85,7 @@ Built_In_Primitive (Prim_String_Maximum_Length, 1, { Primitive_1_Arg (); - guarantee_string_arg_1 (); + CHECK_ARG (1, STRING_P); return (Make_Unsigned_Fixnum ((maximum_string_length (Arg1)) - 1)); } @@ -94,10 +94,10 @@ Built_In_Primitive (Prim_Set_String_Length, 2, "SET-STRING-LENGTH!", 0x140) long length, result; Primitive_2_Args (); - guarantee_string_arg_1 (); - length = (guarantee_nonnegative_int_arg_2 (Arg2)); + CHECK_ARG (1, STRING_P); + length = (arg_nonnegative_integer (2)); if (length > (maximum_string_length (Arg1))) - error_bad_range_arg_2 (); + error_bad_range_arg (2); result = (string_length (Arg1)); set_string_length (Arg1, length); @@ -121,8 +121,8 @@ substring_length_min (start1, end1, start2, end2) long result; \ Primitive_2_Args (); \ \ - guarantee_string_arg_1 (); \ - index = (guarantee_index_arg_2 (Arg2, (string_length (Arg1)))); \ + CHECK_ARG (1, STRING_P); \ + index = (arg_index_integer (2, (string_length (Arg1)))); \ \ return (process_result (string_ref (Arg1, index))); \ } @@ -140,9 +140,9 @@ Built_In_Primitive (Prim_Vec_8b_Ref, 2, "VECTOR-8B-REF", 0xA5) Pointer result; \ Primitive_3_Args (); \ \ - guarantee_string_arg_1 (); \ - index = (guarantee_index_arg_2 (Arg2, (string_length (Arg1)))); \ - ascii = (get_ascii (Arg3)); \ + 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)); \ @@ -151,31 +151,31 @@ Built_In_Primitive (Prim_Vec_8b_Ref, 2, "VECTOR-8B-REF", 0xA5) } Built_In_Primitive (Prim_String_Set, 3, "STRING-SET!", 0x13B) - string_set_body (guarantee_ascii_char_arg_3, c_char_to_scheme_char) + string_set_body (arg_ascii_char, c_char_to_scheme_char) Built_In_Primitive (Prim_Vec_8b_Set, 3, "VECTOR-8B-SET!", 0xA6) - string_set_body (guarantee_ascii_integer_arg_3, Make_Unsigned_Fixnum) + 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 (); \ \ - guarantee_string_arg_1 (); \ - start1 = (guarantee_nonnegative_int_arg_2 (Arg2)); \ - end1 = (guarantee_nonnegative_int_arg_3 (Arg3)); \ - guarantee_string_arg_4 (); \ - start2 = (guarantee_nonnegative_int_arg_5 (Arg5)); \ + 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 (); \ + error_bad_range_arg (2); \ if (start1 > end1) \ - error_bad_range_arg_1 (); \ + error_bad_range_arg (1); \ length = (end1 - start1); \ \ end2 = (start2 + length); \ if (end2 > (string_length (Arg4))) \ - error_bad_range_arg_3 (); + error_bad_range_arg (3); Built_In_Primitive (Prim_Substring_Move_Right, 5, "SUBSTRING-MOVE-RIGHT!", 0x13C) @@ -207,15 +207,15 @@ Built_In_Primitive (Prim_Substring_Move_Left, 5, char *scan; \ Primitive_4_Args (); \ \ - guarantee_string_arg_1 (); \ - start = (guarantee_nonnegative_int_arg_2 (Arg2)); \ - end = (guarantee_nonnegative_int_arg_3 (Arg3)); \ - ascii = (guarantee_ascii_integer_arg_4 (Arg4)); \ + 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 (); \ + error_bad_range_arg (3); \ if (start > end) \ - error_bad_range_arg_2 (); + error_bad_range_arg (2); Built_In_Primitive (Prim_Vec_8b_Fill, 4, "VECTOR-8B-FILL!", 0x141) { @@ -293,17 +293,17 @@ Built_In_Primitive(Prim_Vec_8b_Find_Prev_Char_Ci, 4, char *char_set, *scan; \ Primitive_4_Args (); \ \ - guarantee_string_arg_1 (); \ - start = (guarantee_nonnegative_int_arg_2 (Arg2)); \ - end = (guarantee_nonnegative_int_arg_3 (Arg3)); \ - guarantee_string_arg_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 (Arg1))) \ - error_bad_range_arg_3 (); \ + error_bad_range_arg (3); \ if (start > end) \ - error_bad_range_arg_2 (); \ + error_bad_range_arg (2); \ if ((string_length (Arg4)) != MAX_ASCII) \ - error_bad_range_arg_4 (); + error_bad_range_arg (4); Built_In_Primitive(Prim_Find_Next_Char_In_Set, 4, "SUBSTRING-FIND-NEXT-CHAR-IN-SET", 0x146) @@ -339,22 +339,22 @@ Built_In_Primitive(Prim_Find_Prev_Char_In_Set, 4, char *scan1, *scan2; \ Primitive_6_Args (); \ \ - guarantee_string_arg_1 (); \ - start1 = (guarantee_nonnegative_int_arg_2 (Arg2)); \ - end1 = (guarantee_nonnegative_int_arg_3 (Arg3)); \ - guarantee_string_arg_4 (); \ - start2 = (guarantee_nonnegative_int_arg_5 (Arg5)); \ - end2 = (guarantee_nonnegative_int_arg_6 (Arg6)); \ + 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)); \ + end2 = (arg_nonnegative_integer (6)); \ \ if (end1 > (string_length (Arg1))) \ - error_bad_range_arg_3 (); \ + error_bad_range_arg (3); \ if (start1 > end1) \ - error_bad_range_arg_2 (); \ + error_bad_range_arg (2); \ \ if (end2 > (string_length (Arg4))) \ - error_bad_range_arg_6 (); \ + error_bad_range_arg (6); \ if (start2 > end2) \ - error_bad_range_arg_5 (); \ + error_bad_range_arg (5); \ \ scan1 = (string_pointer (Arg1, index1)); \ scan2 = (string_pointer (Arg4, index2)); @@ -409,14 +409,14 @@ Built_In_Primitive (Prim_Substring_Less, 6, "SUBSTRING (string_length (Arg1))) \ - error_bad_range_arg_3 (); \ + error_bad_range_arg (3); \ if (start > end) \ - error_bad_range_arg_2 (); \ + error_bad_range_arg (2); \ \ length = (end - start); \ scan = (string_pointer (Arg1, start)); diff --git a/v7/src/microcode/syntax.c b/v7/src/microcode/syntax.c index 532fe2b58..2e028f2c6 100644 --- a/v7/src/microcode/syntax.c +++ b/v7/src/microcode/syntax.c @@ -1,6 +1,6 @@ /* -*-C-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/syntax.c,v 1.1 1987/05/11 17:47:12 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/syntax.c,v 1.2 1987/05/14 13:50:15 cph Exp $ Copyright (c) 1987 Massachusetts Institute of Technology @@ -96,17 +96,17 @@ Built_In_Primitive (Prim_String_To_Syntax_Entry, 1, "STRING->SYNTAX-ENTRY", char *scan; Primitive_1_Arg (); - guarantee_string_arg_1 (); + CHECK_ARG (1, STRING_P); length = (string_length (Arg1)); - if (length > 6) error_bad_range_arg_1 (); + if (length > 6) error_bad_range_arg (1); scan = (string_pointer (Arg1, 0)); if (length-- > 0) { c = (char_to_long (*scan++)); - if (c >= 0200) error_bad_range_arg_1 (); + if (c >= 0200) error_bad_range_arg (1); result = (char_to_long (syntax_spec_code[c])); - if (result == ILLEGAL) error_bad_range_arg_1 (); + if (result == ILLEGAL) error_bad_range_arg (1); } else result = ((long) syntaxcode_whitespace); @@ -124,7 +124,7 @@ Built_In_Primitive (Prim_String_To_Syntax_Entry, 1, "STRING->SYNTAX-ENTRY", case '2': result |= (1 << 17); break; case '3': result |= (1 << 18); break; case '4': result |= (1 << 19); break; - default: error_bad_range_arg_1 (); + default: error_bad_range_arg (1); } return (Make_Unsigned_Fixnum (result)); @@ -134,13 +134,12 @@ Built_In_Primitive (Prim_Char_To_Syntax_Code, 2, "CHAR->SYNTAX-CODE", 0x17E) { Primitive_2_Args (); - if (! (SYNTAX_TABLE_P (Arg1))) - error_wrong_type_arg_1 (); + CHECK_ARG (1, SYNTAX_TABLE_P); return (c_char_to_scheme_char ((char) (SYNTAX_ENTRY_CODE - (SYNTAX_TABLE_REF (Arg1, (guarantee_ascii_char_arg_2 (Arg2))))))); + (SYNTAX_TABLE_REF (Arg1, (arg_ascii_char (2))))))); } /* Parser Initialization */ @@ -152,14 +151,12 @@ Built_In_Primitive (Prim_Char_To_Syntax_Code, 2, "CHAR->SYNTAX-CODE", 0x17E) long gap_length; \ primitive_initialization (); \ \ - if (! (SYNTAX_TABLE_P (Arg1))) \ - error_wrong_type_arg_1 (); \ - if (! (GROUP_P (Arg2))) \ - error_wrong_type_arg_2 (); \ + CHECK_ARG (1, SYNTAX_TABLE_P); \ + CHECK_ARG (2, GROUP_P); \ \ first_char = (string_pointer ((GROUP_TEXT (Arg2)), 0)); \ - start = (first_char + (guarantee_nonnegative_int_arg_3 (Arg3))); \ - end = (first_char + (guarantee_nonnegative_int_arg_4 (Arg4))); \ + start = (first_char + (arg_nonnegative_integer (3))); \ + end = (first_char + (arg_nonnegative_integer (4))); \ gap_start = (first_char + (GROUP_GAP_START (Arg2))); \ gap_length = (GROUP_GAP_LENGTH (Arg2)); \ gap_end = (first_char + (GROUP_GAP_END (Arg2))) @@ -188,8 +185,8 @@ Built_In_Primitive (Prim_Char_To_Syntax_Code, 2, "CHAR->SYNTAX-CODE", 0x17E) Boolean sexp_flag, ignore_comments, math_exit; \ char c; \ initialization (Primitive_7_Args); \ - guarantee_fixnum_arg_5 (); \ - Sign_Extend (Arg5, depth); \ + CHECK_ARG (5, FIXNUM_P); \ + FIXNUM_VALUE (Arg5, depth); \ min_depth = ((depth >= 0) ? 0 : depth); \ sexp_flag = (Arg6 != NIL); \ ignore_comments = (Arg7 != NIL); \ @@ -200,14 +197,14 @@ Built_In_Primitive (Prim_Char_To_Syntax_Code, 2, "CHAR->SYNTAX-CODE", 0x17E) #define PEEK_RIGHT(scan) (SYNTAX_TABLE_REF (Arg1, (*scan))) #define PEEK_LEFT(scan) (SYNTAX_TABLE_REF (Arg1, (scan[-1]))) -#define INCREMENT_SCAN(scan) \ +#define MOVE_RIGHT(scan) \ do \ { \ if (++scan == gap_start) \ scan = gap_end; \ } while (0) -#define DECREMENT_SCAN(scan) \ +#define MOVE_LEFT(scan) \ do \ { \ if (--scan == gap_end) \ @@ -288,7 +285,7 @@ do \ char *scan; \ \ scan = (scan_init); \ - DECREMENT_SCAN (scan); \ + MOVE_LEFT (scan); \ RIGHT_QUOTED_P_INTERNAL (scan, quoted); \ } while (0) @@ -316,7 +313,7 @@ Built_In_Primitive (Prim_Scan_Backward_Prefix_Chars, 4, LEFT_QUOTED_P (start, quoted); WIN_IF (quoted || ((SYNTAX_ENTRY_CODE (PEEK_LEFT (start))) != syntaxcode_quote)); - DECREMENT_SCAN (start); + MOVE_LEFT (start); } } @@ -331,7 +328,7 @@ Built_In_Primitive { LOSE_IF_RIGHT_END (start); WIN_IF ((SYNTAX_ENTRY_CODE (PEEK_RIGHT (start))) == syntaxcode_word); - INCREMENT_SCAN (start); + MOVE_RIGHT (start); } } @@ -350,7 +347,7 @@ Built_In_Primitive (Prim_Scan_Word_Forward, 4, "SCAN-WORD-FORWARD", 0x177) { WIN_IF_RIGHT_END (start); WIN_IF ((SYNTAX_ENTRY_CODE (PEEK_RIGHT (start))) != syntaxcode_word); - INCREMENT_SCAN (start); + MOVE_RIGHT (start); } } @@ -369,7 +366,7 @@ Built_In_Primitive (Prim_Scan_Word_Backward, 4, "SCAN-WORD-BACKWARD", 0x178) { WIN_IF_LEFT_END (start); WIN_IF ((SYNTAX_ENTRY_CODE (PEEK_LEFT (start))) != syntaxcode_word); - DECREMENT_SCAN (start); + MOVE_LEFT (start); } } @@ -389,7 +386,7 @@ Built_In_Primitive (Prim_Scan_List_Forward, 7, "SCAN-LIST-FORWARD", 0x179) (SYNTAX_ENTRY_COMSTART_FIRST (entry)) && (SYNTAX_ENTRY_COMSTART_SECOND (PEEK_RIGHT (start)))) { - INCREMENT_SCAN (start); + MOVE_RIGHT (start); LOSE_IF_RIGHT_END (start); while (true) { @@ -398,7 +395,7 @@ Built_In_Primitive (Prim_Scan_List_Forward, 7, "SCAN-LIST-FORWARD", 0x179) if ((SYNTAX_ENTRY_COMEND_FIRST (entry)) && (SYNTAX_ENTRY_COMEND_SECOND (PEEK_RIGHT (start)))) { - INCREMENT_SCAN (start); + MOVE_RIGHT (start); break; } } @@ -410,7 +407,7 @@ Built_In_Primitive (Prim_Scan_List_Forward, 7, "SCAN-LIST-FORWARD", 0x179) case syntaxcode_escape: case syntaxcode_charquote: LOSE_IF_RIGHT_END (start); - INCREMENT_SCAN (start); + MOVE_RIGHT (start); case syntaxcode_word: case syntaxcode_symbol: @@ -423,12 +420,12 @@ Built_In_Primitive (Prim_Scan_List_Forward, 7, "SCAN-LIST-FORWARD", 0x179) { case syntaxcode_escape: case syntaxcode_charquote: - INCREMENT_SCAN (start); + MOVE_RIGHT (start); LOSE_IF_RIGHT_END (start); case syntaxcode_word: case syntaxcode_symbol: - INCREMENT_SCAN (start); + MOVE_RIGHT (start); break; default: @@ -445,7 +442,7 @@ Built_In_Primitive (Prim_Scan_List_Forward, 7, "SCAN-LIST-FORWARD", 0x179) if ((SYNTAX_ENTRY_CODE (PEEK_RIGHT (start))) == syntaxcode_endcomment) break; - INCREMENT_SCAN (start); + MOVE_RIGHT (start); } break; @@ -453,7 +450,7 @@ Built_In_Primitive (Prim_Scan_List_Forward, 7, "SCAN-LIST-FORWARD", 0x179) if (! sexp_flag) break; if ((! (RIGHT_END_P (start))) && (c == *start)) - INCREMENT_SCAN (start); + MOVE_RIGHT (start); if (math_exit) { WIN_IF (--depth == 0); @@ -486,10 +483,10 @@ Built_In_Primitive (Prim_Scan_List_Forward, 7, "SCAN-LIST-FORWARD", 0x179) if (SYNTAX_ENTRY_QUOTE (entry)) { LOSE_IF_RIGHT_END (start); - INCREMENT_SCAN (start); + MOVE_RIGHT (start); } } - INCREMENT_SCAN (start); + MOVE_RIGHT (start); WIN_IF ((depth == 0) || sexp_flag); break; @@ -509,7 +506,7 @@ Built_In_Primitive (Prim_Scan_List_Backward, 7, "SCAN-LIST-BACKWARD", 0x17A) LEFT_QUOTED_P (start, quoted); if (quoted) { - DECREMENT_SCAN (start); + MOVE_LEFT (start); /* existence of this character is guaranteed by LEFT_QUOTED_P. */ READ_LEFT (start, entry); goto word_entry; @@ -523,7 +520,7 @@ Built_In_Primitive (Prim_Scan_List_Backward, 7, "SCAN-LIST-BACKWARD", 0x17A) LEFT_QUOTED_P (start, quoted); if (! quoted) { - DECREMENT_SCAN (start); + MOVE_LEFT (start); LOSE_IF_LEFT_END (start); while (true) { @@ -532,7 +529,7 @@ Built_In_Primitive (Prim_Scan_List_Backward, 7, "SCAN-LIST-BACKWARD", 0x17A) if ((SYNTAX_ENTRY_COMSTART_SECOND (entry)) && (SYNTAX_ENTRY_COMSTART_SECOND (PEEK_LEFT (start)))) { - DECREMENT_SCAN (start); + MOVE_LEFT (start); break; } } @@ -552,21 +549,21 @@ word_entry: WIN_IF_LEFT_END (start); LEFT_QUOTED_P (start, quoted); if (quoted) - DECREMENT_SCAN (start); + MOVE_LEFT (start); else { entry = (PEEK_LEFT (start)); WIN_IF (((SYNTAX_ENTRY_CODE (entry)) != syntaxcode_word) && ((SYNTAX_ENTRY_CODE (entry)) != syntaxcode_symbol)); } - DECREMENT_SCAN (start); + MOVE_LEFT (start); } case syntaxcode_math: if (! sexp_flag) break; if ((! (LEFT_END_P (start))) && (c == start[-1])) - DECREMENT_SCAN (start); + MOVE_LEFT (start); if (math_exit) { WIN_IF (--depth == 0); @@ -596,9 +593,9 @@ word_entry: LEFT_QUOTED_P (start, quoted); if ((! quoted) && (c == start[-1])) break; - DECREMENT_SCAN (start); + MOVE_LEFT (start); } - DECREMENT_SCAN (start); + MOVE_LEFT (start); WIN_IF ((depth == 0) && sexp_flag); break; @@ -611,7 +608,7 @@ word_entry: if ((SYNTAX_ENTRY_CODE (PEEK_LEFT (start))) == syntaxcode_comment) break; - DECREMENT_SCAN (start); + MOVE_LEFT (start); } break; @@ -654,8 +651,8 @@ Built_In_Primitive (Prim_Scan_Sexps_Forward, 7, "SCAN-SEXPS-FORWARD", 0x17B) Pointer result; STANDARD_INITIALIZATION_FORWARD (Primitive_7_Args); - guarantee_fixnum_arg_5 (); - Sign_Extend (Arg5, target_depth); + CHECK_ARG (5, FIXNUM_P); + FIXNUM_VALUE (Arg5, target_depth); stop_before = (Arg6 != NIL); level = level_start; @@ -677,20 +674,20 @@ Built_In_Primitive (Prim_Scan_Sexps_Forward, 7, "SCAN-SEXPS-FORWARD", 0x17B) Pointer temp; temp = (User_Vector_Ref (Arg7, 0)); - if (fixnum_p (temp)) + if (FIXNUM_P (temp)) { Sign_Extend (temp, depth); } else - error_bad_range_arg_7 (); + error_bad_range_arg (7); temp = (User_Vector_Ref (Arg7, 1)); if (temp == NIL) in_string = -1; - else if ((fixnum_p (temp)) && ((pointer_datum (temp)) < MAX_ASCII)) + else if ((FIXNUM_P (temp)) && ((pointer_datum (temp)) < MAX_ASCII)) in_string = (pointer_datum (temp)); else - error_bad_range_arg_7 (); + error_bad_range_arg (7); temp = (User_Vector_Ref (Arg7, 2)); if (temp == NIL) @@ -700,16 +697,16 @@ Built_In_Primitive (Prim_Scan_Sexps_Forward, 7, "SCAN-SEXPS-FORWARD", 0x17B) else if (temp == (Make_Unsigned_Fixnum (2))) in_comment = 2; else - error_bad_range_arg_7 (); + error_bad_range_arg (7); quoted = ((User_Vector_Ref (Arg7, 3)) != NIL); if ((in_comment != 0) && ((in_string != -1) || (quoted != false))) - error_bad_range_arg_7 (); + error_bad_range_arg (7); } else - error_wrong_type_arg_7 (); + error_bad_range_arg (7); /* Make sure there is enough room for the result before we start. */ @@ -741,7 +738,7 @@ Built_In_Primitive (Prim_Scan_Sexps_Forward, 7, "SCAN-SEXPS-FORWARD", 0x17B) (SYNTAX_ENTRY_COMSTART_FIRST (entry)) && (SYNTAX_ENTRY_COMSTART_FIRST (PEEK_RIGHT (start)))) { - INCREMENT_SCAN (start); + MOVE_RIGHT (start); in_comment = 2; start_in_comment2: while (true) @@ -755,7 +752,7 @@ start_in_comment2: DONE_IF_RIGHT_END (start); if (SYNTAX_ENTRY_COMEND_SECOND (PEEK_RIGHT (start))) { - INCREMENT_SCAN (start); + MOVE_RIGHT (start); break; } } @@ -775,7 +772,7 @@ start_quoted: quoted = true; DONE_IF (true); } - INCREMENT_SCAN (start); + MOVE_RIGHT (start); goto start_atom; case syntaxcode_word: @@ -788,7 +785,7 @@ start_atom: { case syntaxcode_escape: case syntaxcode_charquote: - INCREMENT_SCAN (start); + MOVE_RIGHT (start); if (RIGHT_END_P (start)) { quoted = true; @@ -797,7 +794,7 @@ start_atom: case syntaxcode_word: case syntaxcode_symbol: - INCREMENT_SCAN (start); + MOVE_RIGHT (start); break; default: @@ -826,7 +823,7 @@ start_in_comment: depth += 1; level += 1; if (level == level_end) - error_bad_range_arg_5 (); /* random error */ + error_bad_range_arg (5); /* random error */ level->last = NULL; level->previous = NULL; DONE_IF ((--target_depth) == 0); @@ -862,7 +859,7 @@ start_quoted_in_string: } in_string = -1; level->previous = level->last; - INCREMENT_SCAN (start); + MOVE_RIGHT (start); break; } } diff --git a/v7/src/microcode/utils.c b/v7/src/microcode/utils.c index 8c78f6cae..d50f59339 100644 --- a/v7/src/microcode/utils.c +++ b/v7/src/microcode/utils.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/utils.c,v 9.27 1987/04/29 20:12:20 cph Exp $ */ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/utils.c,v 9.28 1987/05/14 13:50:45 cph Exp $ */ /* This file contains utilities for interrupts, errors, etc. */ @@ -253,26 +253,9 @@ Back_Out_Of_Primitive () extern void signal_error_from_primitive(), signal_interrupt_from_primitive(), - error_wrong_type_arg_1(), - error_wrong_type_arg_2(), - error_wrong_type_arg_3(), - error_wrong_type_arg_4(), - error_wrong_type_arg_5(), - error_wrong_type_arg_6(), - error_wrong_type_arg_7(), - error_wrong_type_arg_8(), - error_wrong_type_arg_9(), - error_wrong_type_arg_10(), - error_bad_range_arg_1(), - error_bad_range_arg_2(), - error_bad_range_arg_3(), - error_bad_range_arg_4(), - error_bad_range_arg_5(), - error_bad_range_arg_6(), - error_bad_range_arg_7(), - error_bad_range_arg_8(), - error_bad_range_arg_9(), - error_bad_range_arg_10(), + special_interrupt_from_primitive(), + error_wrong_type_arg(), + error_bad_range_arg(), error_external_return(); void @@ -304,242 +287,90 @@ special_interrupt_from_primitive(local_mask) longjmp(*Back_To_Eval, PRIM_INTERRUPT); /*NOTREACHED*/ } - -void -error_wrong_type_arg_1 () -{ - signal_error_from_primitive (ERR_ARG_1_WRONG_TYPE); -} - -void -error_wrong_type_arg_2 () -{ - signal_error_from_primitive (ERR_ARG_2_WRONG_TYPE); -} - -void -error_wrong_type_arg_3 () -{ - signal_error_from_primitive (ERR_ARG_3_WRONG_TYPE); -} - -void -error_wrong_type_arg_4 () -{ - signal_error_from_primitive (ERR_ARG_4_WRONG_TYPE); -} - -void -error_wrong_type_arg_5 () -{ - signal_error_from_primitive (ERR_ARG_5_WRONG_TYPE); -} void -error_wrong_type_arg_6 () +error_wrong_type_arg (n) + int n; { - signal_error_from_primitive (ERR_ARG_6_WRONG_TYPE); -} + fast long error_code; -void -error_wrong_type_arg_7 () -{ - signal_error_from_primitive (ERR_ARG_7_WRONG_TYPE); -} - -void -error_wrong_type_arg_8 () -{ - signal_error_from_primitive (ERR_ARG_8_WRONG_TYPE); -} - -void -error_wrong_type_arg_9 () -{ - signal_error_from_primitive (ERR_ARG_9_WRONG_TYPE); -} - -void -error_wrong_type_arg_10 () -{ - signal_error_from_primitive (ERR_ARG_10_WRONG_TYPE); -} - -void -error_bad_range_arg_1 () -{ - signal_error_from_primitive (ERR_ARG_1_BAD_RANGE); + switch (n) + { + case 1: error_code = ERR_ARG_1_WRONG_TYPE; + case 2: error_code = ERR_ARG_2_WRONG_TYPE; + case 3: error_code = ERR_ARG_3_WRONG_TYPE; + case 4: error_code = ERR_ARG_4_WRONG_TYPE; + case 5: error_code = ERR_ARG_5_WRONG_TYPE; + case 6: error_code = ERR_ARG_6_WRONG_TYPE; + case 7: error_code = ERR_ARG_7_WRONG_TYPE; + case 8: error_code = ERR_ARG_8_WRONG_TYPE; + case 9: error_code = ERR_ARG_9_WRONG_TYPE; + case 10: error_code = ERR_ARG_10_WRONG_TYPE; + default: error_code = ERR_EXTERNAL_RETURN; + } + signal_error_from_primitive (error_code); } void -error_bad_range_arg_2 () +error_bad_range_arg (n) + int n; { - signal_error_from_primitive (ERR_ARG_2_BAD_RANGE); -} + fast long error_code; -void -error_bad_range_arg_3 () -{ - signal_error_from_primitive (ERR_ARG_3_BAD_RANGE); + switch (n) + { + case 1: error_code = ERR_ARG_1_BAD_RANGE; + case 2: error_code = ERR_ARG_2_BAD_RANGE; + case 3: error_code = ERR_ARG_3_BAD_RANGE; + case 4: error_code = ERR_ARG_4_BAD_RANGE; + case 5: error_code = ERR_ARG_5_BAD_RANGE; + case 6: error_code = ERR_ARG_6_BAD_RANGE; + case 7: error_code = ERR_ARG_7_BAD_RANGE; + case 8: error_code = ERR_ARG_8_BAD_RANGE; + case 9: error_code = ERR_ARG_9_BAD_RANGE; + case 10: error_code = ERR_ARG_10_BAD_RANGE; + default: error_code = ERR_EXTERNAL_RETURN; + } + signal_error_from_primitive (error_code); } void -error_bad_range_arg_4 () +error_external_return () { - signal_error_from_primitive (ERR_ARG_4_BAD_RANGE); + signal_error_from_primitive (ERR_EXTERNAL_RETURN); } -void -error_bad_range_arg_5 () -{ - signal_error_from_primitive (ERR_ARG_5_BAD_RANGE); -} - -void -error_bad_range_arg_6 () -{ - signal_error_from_primitive (ERR_ARG_6_BAD_RANGE); -} - -void -error_bad_range_arg_7 () -{ - signal_error_from_primitive (ERR_ARG_7_BAD_RANGE); -} - -void -error_bad_range_arg_8 () +long +arg_nonnegative_integer (n) + int n; { - signal_error_from_primitive (ERR_ARG_8_BAD_RANGE); -} + fast Pointer argument; -void -error_bad_range_arg_9 () -{ - signal_error_from_primitive (ERR_ARG_9_BAD_RANGE); + CHECK_ARG (n, FIXNUM_P); + argument = (ARG_REF (n)); + if (FIXNUM_NEGATIVE_P (argument)) + error_bad_range_arg (n); + return (UNSIGNED_FIXNUM_VALUE (argument)); } -void -error_bad_range_arg_10 () +long +arg_index_integer (n, upper_limit) + int n; + long upper_limit; { - signal_error_from_primitive (ERR_ARG_10_BAD_RANGE); -} + fast Pointer argument; + fast long result; -void -error_external_return () -{ - signal_error_from_primitive (ERR_EXTERNAL_RETURN); + CHECK_ARG (n, FIXNUM_P); + argument = (ARG_REF (n)); + if (FIXNUM_NEGATIVE_P (argument)) + error_bad_range_arg (n); + result = (UNSIGNED_FIXNUM_VALUE (argument)); + if (result >= upper_limit) + error_bad_range_arg (n); + return (result); } -#define define_integer_guarantee(procedure_name, wta, bra) \ -long \ -procedure_name (argument) \ - Pointer argument; \ -{ \ - if (! (fixnum_p (argument))) \ - wta (); \ - if (fixnum_negative_p (argument)) \ - bra (); \ - return (pointer_datum (argument)); \ -} - -define_integer_guarantee (guarantee_nonnegative_int_arg_1, - error_wrong_type_arg_1, - error_bad_range_arg_1) - -define_integer_guarantee (guarantee_nonnegative_int_arg_2, - error_wrong_type_arg_2, - error_bad_range_arg_2) - -define_integer_guarantee (guarantee_nonnegative_int_arg_3, - error_wrong_type_arg_3, - error_bad_range_arg_3) - -define_integer_guarantee (guarantee_nonnegative_int_arg_4, - error_wrong_type_arg_4, - error_bad_range_arg_4) - -define_integer_guarantee (guarantee_nonnegative_int_arg_5, - error_wrong_type_arg_5, - error_bad_range_arg_5) - -define_integer_guarantee (guarantee_nonnegative_int_arg_6, - error_wrong_type_arg_6, - error_bad_range_arg_6) - -define_integer_guarantee (guarantee_nonnegative_int_arg_7, - error_wrong_type_arg_7, - error_bad_range_arg_7) - -define_integer_guarantee (guarantee_nonnegative_int_arg_8, - error_wrong_type_arg_8, - error_bad_range_arg_8) - -define_integer_guarantee (guarantee_nonnegative_int_arg_9, - error_wrong_type_arg_9, - error_bad_range_arg_9) - -define_integer_guarantee (guarantee_nonnegative_int_arg_10, - error_wrong_type_arg_10, - error_bad_range_arg_10) - -#define define_index_guarantee(procedure_name, wta, bra) \ -long \ -procedure_name (argument, upper_limit) \ - Pointer argument, upper_limit; \ -{ \ - fast long index; \ - \ - if (! (fixnum_p (argument))) \ - wta (); \ - if (fixnum_negative_p (argument)) \ - bra (); \ - index = (pointer_datum (argument)); \ - if (index >= upper_limit) \ - bra (); \ - return (index); \ -} - -define_index_guarantee (guarantee_index_arg_1, - error_wrong_type_arg_1, - error_bad_range_arg_1) - -define_index_guarantee (guarantee_index_arg_2, - error_wrong_type_arg_2, - error_bad_range_arg_2) - -define_index_guarantee (guarantee_index_arg_3, - error_wrong_type_arg_3, - error_bad_range_arg_3) - -define_index_guarantee (guarantee_index_arg_4, - error_wrong_type_arg_4, - error_bad_range_arg_4) - -define_index_guarantee (guarantee_index_arg_5, - error_wrong_type_arg_5, - error_bad_range_arg_5) - -define_index_guarantee (guarantee_index_arg_6, - error_wrong_type_arg_6, - error_bad_range_arg_6) - -define_index_guarantee (guarantee_index_arg_7, - error_wrong_type_arg_7, - error_bad_range_arg_7) - -define_index_guarantee (guarantee_index_arg_8, - error_wrong_type_arg_8, - error_bad_range_arg_8) - -define_index_guarantee (guarantee_index_arg_9, - error_wrong_type_arg_9, - error_bad_range_arg_9) - -define_index_guarantee (guarantee_index_arg_10, - error_wrong_type_arg_10, - error_bad_range_arg_10) - void Do_Micro_Error (Err, From_Pop_Return) long Err; diff --git a/v7/src/microcode/vector.c b/v7/src/microcode/vector.c index c776056f8..5d180cf5d 100644 --- a/v7/src/microcode/vector.c +++ b/v7/src/microcode/vector.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/vector.c,v 9.23 1987/04/25 20:26:27 cph Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/vector.c,v 9.24 1987/05/14 13:51:07 cph Exp $ * * This file contains procedures for handling vectors and conversion * back and forth to lists. @@ -38,39 +38,6 @@ MIT in each case. */ #include "scheme.h" #include "primitive.h" - -#define vector_p(object) \ - ((Type_Code (object)) == TC_VECTOR) - -#define guarantee_vector_arg_1() \ -if (! (vector_p (Arg1))) error_wrong_type_arg_1 () - -#define guarantee_vector_arg_2() \ -if (! (vector_p (Arg2))) error_wrong_type_arg_2 () - -#define guarantee_vector_arg_3() \ -if (! (vector_p (Arg3))) error_wrong_type_arg_3 () - -#define guarantee_vector_arg_4() \ -if (! (vector_p (Arg4))) error_wrong_type_arg_4 () - -#define guarantee_vector_arg_5() \ -if (! (vector_p (Arg5))) error_wrong_type_arg_5 () - -#define guarantee_vector_arg_6() \ -if (! (vector_p (Arg6))) error_wrong_type_arg_6 () - -#define guarantee_vector_arg_7() \ -if (! (vector_p (Arg7))) error_wrong_type_arg_7 () - -#define guarantee_vector_arg_8() \ -if (! (vector_p (Arg8))) error_wrong_type_arg_8 () - -#define guarantee_vector_arg_9() \ -if (! (vector_p (Arg9))) error_wrong_type_arg_9 () - -#define guarantee_vector_arg_10() \ -if (! (vector_p (Arg10))) error_wrong_type_arg_10 () /*********************/ /* VECTORS <-> LISTS */ @@ -319,21 +286,21 @@ Built_In_Primitive(Prim_Sys_Vec_Size, 1, "SYSTEM-VECTOR-SIZE", 0xAE) Pointer *scan1, *scan2; \ Primitive_5_Args (); \ \ - guarantee_vector_arg_1 (); \ - start1 = (guarantee_nonnegative_int_arg_2 (Arg2)); \ - end1 = (guarantee_nonnegative_int_arg_3 (Arg3)); \ - guarantee_vector_arg_4 (); \ - start2 = (guarantee_nonnegative_int_arg_5 (Arg5)); \ + CHECK_ARG (1, VECTOR_P); \ + start1 = (arg_nonnegative_integer (2)); \ + end1 = (arg_nonnegative_integer (3)); \ + CHECK_ARG (4, VECTOR_P); \ + start2 = (arg_nonnegative_integer (5)); \ \ if (end1 > (Vector_Length (Arg1))) \ - error_bad_range_arg_3 (); \ + error_bad_range_arg (3); \ if (start1 > end1) \ - error_bad_range_arg_2 (); \ + error_bad_range_arg (2); \ length = (end1 - start1); \ \ end2 = (start2 + length); \ if (end2 > (Vector_Length (Arg4))) \ - error_bad_range_arg_5 (); \ + error_bad_range_arg (5); \ \ if (Is_Pure (Get_Pointer (Arg2))) \ Primitive_Error (ERR_WRITE_INTO_PURE_SPACE); @@ -367,14 +334,14 @@ Built_In_Primitive (Prim_vector_fill, 4, "SUBVECTOR-FILL!", 0x9F) long start, end, length; Primitive_4_Args (); - guarantee_vector_arg_1 (); - start = (guarantee_nonnegative_int_arg_2 (Arg2)); - end = (guarantee_nonnegative_int_arg_3 (Arg3)); + CHECK_ARG (1, VECTOR_P); + start = (arg_nonnegative_integer (2)); + end = (arg_nonnegative_integer (3)); if (end > (Vector_Length (Arg1))) - error_bad_range_arg_3 (); + error_bad_range_arg (3); if (start > end) - error_bad_range_arg_2 (); + error_bad_range_arg (2); length = (end - start); Side_Effect_Impurify (Arg1, Arg4); diff --git a/v7/src/microcode/version.h b/v7/src/microcode/version.h index 5d7090938..d3291b892 100644 --- a/v7/src/microcode/version.h +++ b/v7/src/microcode/version.h @@ -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/version.h,v 9.50 1987/05/11 17:51:51 cph Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/Attic/version.h,v 9.51 1987/05/14 13:51:20 cph Exp $ This file contains version information for the microcode. */ @@ -46,7 +46,7 @@ This file contains version information for the microcode. */ #define VERSION 9 #endif #ifndef SUBVERSION -#define SUBVERSION 50 +#define SUBVERSION 51 #endif #ifndef UCODE_TABLES_FILENAME diff --git a/v8/src/microcode/object.h b/v8/src/microcode/object.h index 1e07bfe97..935354ad0 100644 --- a/v8/src/microcode/object.h +++ b/v8/src/microcode/object.h @@ -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/object.h,v 9.22 1987/04/16 02:27:09 jinx Exp $ */ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/object.h,v 9.23 1987/05/14 13:49:24 cph Rel $ */ /* This file contains definitions pertaining to the C view of Scheme pointers: widths of fields, extraction macros, pre-computed @@ -83,22 +83,25 @@ MIT in each case. */ #endif #ifndef UNSIGNED_SHIFT /* Safe version */ -#define pointer_type(P) (((P) >> ADDRESS_LENGTH) & MAX_TYPE_CODE) +#define OBJECT_TYPE(P) (((P) >> ADDRESS_LENGTH) & MAX_TYPE_CODE) #define safe_pointer_type(P) (((P) >> ADDRESS_LENGTH) & SAFE_TYPE_MASK) #else /* Faster for logical shifts */ -#define pointer_type(P) ((P) >> ADDRESS_LENGTH) +#define OBJECT_TYPE(P) ((P) >> ADDRESS_LENGTH) #define safe_pointer_type(P) ((pointer_type (P)) & SAFE_TYPE_MASK) #endif -#define pointer_datum(P) ((P) & ADDRESS_MASK) +#define OBJECT_DATUM(P) ((P) & ADDRESS_MASK) /* compatibility definitions */ -#define Type_Code(P) (pointer_type (P)) +#define Type_Code(P) (OBJECT_TYPE (P)) #define Safe_Type_Code(P) (safe_pointer_type (P)) -#define Datum(P) (pointer_datum (P)) +#define Datum(P) (OBJECT_DATUM (P)) + +#define pointer_type(P) (OBJECT_TYPE (P)) +#define pointer_datum(P) (OBJECT_DATUM (P)) #define Make_Object(TC, D) \ -((((unsigned) (TC)) << ADDRESS_LENGTH) | (pointer_datum (D))) +((((unsigned) (TC)) << ADDRESS_LENGTH) | (OBJECT_DATUM (D))) #ifndef Heap_In_Low_Memory /* Safe version */ @@ -114,7 +117,7 @@ extern Pointer *Memory_Base; Heap = Memory_Base, \ ((Memory_Base + (space)) - 1)) -#define Get_Pointer(P) ((Pointer *) (Memory_Base + (pointer_datum (P)))) +#define Get_Pointer(P) ((Pointer *) (Memory_Base + (OBJECT_DATUM (P)))) #define C_To_Scheme(P) ((Pointer) ((P) - Memory_Base)) #else /* Storing absolute addresses */ @@ -133,7 +136,7 @@ typedef long relocation_type; /* Used to relocate pointers on fasload */ #else /* Not Spectrum, fast case */ -#define Get_Pointer(P) ((Pointer *) (pointer_datum (P))) +#define Get_Pointer(P) ((Pointer *) (OBJECT_DATUM (P))) #define C_To_Scheme(P) ((Pointer) (P)) #endif /* spectrum */ @@ -150,9 +153,9 @@ typedef long relocation_type; /* Used to relocate pointers on fasload */ #define Store_Type_Code(P, TC) P = (Make_Object ((TC), (P))) #define Store_Address(P, A) \ - P = (((P) & TYPE_CODE_MASK) | (pointer_datum ((Pointer) (A)))) + P = (((P) & TYPE_CODE_MASK) | (OBJECT_DATUM ((Pointer) (A)))) -#define Address(P) (pointer_datum (P)) +#define Address(P) (OBJECT_DATUM (P)) /* These are used only where the object is known to be immutable. On a parallel processor they don't require atomic references */ @@ -171,14 +174,55 @@ typedef long relocation_type; /* Used to relocate pointers on fasload */ #define User_Vector_Ref(P, N) Vector_Ref(P, (N)+1) #define User_Vector_Set(P, N, S) Vector_Set(P, (N)+1, S) +#define FIXNUM_P(object) ((OBJECT_TYPE (object)) == TC_FIXNUM) +#define BIGNUM_P(object) ((OBJECT_TYPE (object)) == TC_BIG_FIXNUM) +#define FLONUM_P(object) ((OBJECT_TYPE (object)) == TC_BIG_FLONUM) +#define COMPLEX_P(object) ((OBJECT_TYPE (object)) == TC_COMPLEX) +#define CHARACTER_P(object) ((OBJECT_TYPE (object)) == TC_CHARACTER) +#define STRING_P(object) ((OBJECT_TYPE (object)) == TC_CHARACTER_STRING) +#define BIT_STRING_P(object) ((OBJECT_TYPE (object)) == TC_BIT_STRING) +#define CELL_P(object) ((OBJECT_TYPE (object)) == TC_CELL) +#define PAIR_P(object) ((OBJECT_TYPE (object)) == TC_LIST) +#define WEAK_PAIR_P(object) ((OBJECT_TYPE (object)) == TC_WEAK_CONS) +#define VECTOR_P(object) ((OBJECT_TYPE (object)) == TC_VECTOR) + +#define SYMBOL_P(object) \ + (((OBJECT_TYPE (object)) == TC_INTERNED_SYMBOL) || \ + ((OBJECT_TYPE (object)) == TC_UNINTERNED_SYMBOL)) + +#define INTEGER_P(object) \ + (((OBJECT_TYPE (object)) == TC_FIXNUM) || \ + ((OBJECT_TYPE (object)) == TC_BIG_FIXNUM)) + +#define REAL_P(object) \ + (((OBJECT_TYPE (object)) == TC_FIXNUM) || \ + ((OBJECT_TYPE (object)) == TC_BIG_FIXNUM) || \ + ((OBJECT_TYPE (object)) == TC_BIG_FLONUM)) + +#define NUMBER_P(object) \ + (((OBJECT_TYPE (object)) == TC_FIXNUM) || \ + ((OBJECT_TYPE (object)) == TC_BIG_FIXNUM) || \ + ((OBJECT_TYPE (object)) == TC_BIG_FLONUM) \ + ((OBJECT_TYPE (object)) == TC_COMPLEX)) + +#define MAKE_FIXNUM(N) (Make_Non_Pointer (TC_FIXNUM, (N))) +#define FIXNUM_NEGATIVE_P(fixnum) (((fixnum) & FIXNUM_SIGN_BIT) != 0) +#define MAKE_UNSIGNED_FIXNUM(N) (FIXNUM_ZERO + (N)) +#define UNSIGNED_FIXNUM_VALUE(fixnum) (OBJECT_DATUM (fixnum)) + +#define FIXNUM_VALUE(fixnum, target) \ +do \ +{ \ + (target) = (UNSIGNED_FIXNUM_VALUE (fixnum)); \ + if (FIXNUM_NEGATIVE_P (target)) \ + (target) |= (-1 << ADDRESS_LENGTH); \ +} while (0) + #define Make_Broken_Heart(N) (BROKEN_HEART_ZERO + (N)) #define Make_Unsigned_Fixnum(N) (FIXNUM_ZERO + (N)) #define Make_Signed_Fixnum(N) Make_Non_Pointer( TC_FIXNUM, (N)) -#define fixnum_p(P) ((pointer_type (P)) == TC_FIXNUM) #define Get_Float(P) (* ((double *) (Nth_Vector_Loc ((P), 1)))) -#define Get_Integer(P) (pointer_datum (P)) - -#define fixnum_negative_p(P) (((P) & FIXNUM_SIGN_BIT) != 0) +#define Get_Integer(P) (OBJECT_DATUM (P)) #define Sign_Extend(P, S) \ { \ diff --git a/v8/src/microcode/version.h b/v8/src/microcode/version.h index a1d06b08e..dccb9fb0c 100644 --- a/v8/src/microcode/version.h +++ b/v8/src/microcode/version.h @@ -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/version.h,v 9.50 1987/05/11 17:51:51 cph Exp $ +/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/microcode/version.h,v 9.51 1987/05/14 13:51:20 cph Exp $ This file contains version information for the microcode. */ @@ -46,7 +46,7 @@ This file contains version information for the microcode. */ #define VERSION 9 #endif #ifndef SUBVERSION -#define SUBVERSION 50 +#define SUBVERSION 51 #endif #ifndef UCODE_TABLES_FILENAME