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. */
\f
{
Primitive_1_Arg ();
- return (allocate_bit_string (guarantee_nonnegative_int_arg_1 (Arg1)));
+ return (allocate_bit_string (arg_nonnegative_integer (1)));
}
/* (BIT-STRING? object)
Primitive_1_Arg ();
Touch_In_Primitive (Arg1, Arg1);
- return ((bit_string_p (Arg1)) ? TRUTH : NIL);
+ return ((BIT_STRING_P (Arg1)) ? TRUTH : NIL);
}
\f
void
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);
}
{
Primitive_2_Args ();
- guarantee_bit_string_arg_1 ();
+ CHECK_ARG (1, BIT_STRING_P);
fill_bit_string (Arg1, (Arg2 != NIL));
return (NIL);
}
{
Primitive_1_Arg ();
- guarantee_bit_string_arg_1 ();
+ CHECK_ARG (1, BIT_STRING_P);
return (Make_Unsigned_Fixnum (bit_string_length (Arg1)));
}
\f
-#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)
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);
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))
}
}
\f
-#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() =
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);
return (NIL);
}
\f
-#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.
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);
}
}
\f
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);
}
}
\f
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);
}
\f
/* (BIT-STRING->UNSIGNED-INTEGER bit-string)
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);
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);
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);
}
\f
/* 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() \
/* -*-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
/* Bit string macros. */
\f
-#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))
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. */
#include "character.h"
#include <ctype.h>
\f
-#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)
-\f
-#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);
+}
\f
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));
}
{
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)
return
(Make_Non_Pointer (TC_CHARACTER,
- (guarantee_index_arg_1 (Arg1, MAX_EXTNDD_CHAR))));
+ (arg_index_integer (1, MAX_EXTNDD_CHAR))));
}
\f
long
{
Primitive_1_Arg ();
- guarantee_char_arg_1 ();
+ CHECK_ARG (1, CHARACTER_P);
return (make_char ((char_bits (Arg1)), (char_downcase (char_code (Arg1)))));
}
{
Primitive_1_Arg ();
- guarantee_char_arg_1 ();
+ CHECK_ARG (1, CHARACTER_P);
return (make_char ((char_bits (Arg1)), (char_upcase (char_code (Arg1)))));
}
{
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)
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)));
}
\f
forward Boolean ascii_control_p();
/* -*-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
#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) \
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);
}
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;
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.
*/
if ((safe_pointer_type (Arg1)) != TC_HUNK3)
- error_wrong_type_arg_1 ();
+ error_wrong_type_arg (1);
Val = *History;
#ifdef COMPILE_HISTORY
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/microcode/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
#endif
\f
#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)))
\f
#ifndef Heap_In_Low_Memory /* Safe version */
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 */
#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 */
#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 */
#define User_Vector_Ref(P, N) Vector_Ref(P, (N)+1)
#define User_Vector_Set(P, N, S) Vector_Set(P, (N)+1, S)
\f
+#define 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)
+\f
#define Make_Broken_Heart(N) (BROKEN_HEART_ZERO + (N))
#define Make_Unsigned_Fixnum(N) (FIXNUM_ZERO + (N))
#define Make_Signed_Fixnum(N) Make_Non_Pointer( TC_FIXNUM, (N))
-#define fixnum_p(P) ((pointer_type (P)) == TC_FIXNUM)
#define Get_Float(P) (* ((double *) (Nth_Vector_Loc ((P), 1))))
-#define Get_Integer(P) (pointer_datum (P))
-
-#define fixnum_negative_p(P) (((P) & FIXNUM_SIGN_BIT) != 0)
+#define Get_Integer(P) (OBJECT_DATUM (P))
#define Sign_Extend(P, S) \
{ \
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
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 ();
\f
+/* 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 ()
-\f
-#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)
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. */
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 =
{
Primitive_1_Arg ();
- return ((string_p (Arg1)) ? TRUTH : NIL);
+ return ((STRING_P (Arg1)) ? TRUTH : NIL);
}
\f
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)));
}
{
Primitive_1_Arg ();
- guarantee_string_arg_1 ();
+ CHECK_ARG (1, STRING_P);
return (Make_Unsigned_Fixnum ((maximum_string_length (Arg1)) - 1));
}
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);
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))); \
}
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)); \
}
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)
\f
#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)
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)
{
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)
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));
fast char *scan, temp; \
Primitive_3_Args (); \
\
- guarantee_string_arg_1 (); \
- start = (guarantee_nonnegative_int_arg_2 (Arg2)); \
- end = (guarantee_nonnegative_int_arg_3 (Arg3)); \
+ CHECK_ARG (1, STRING_P); \
+ start = (arg_nonnegative_integer (2)); \
+ end = (arg_nonnegative_integer (3)); \
\
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); \
\
length = (end - start); \
scan = (string_pointer (Arg1, start));
/* -*-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
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);
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));
{
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)))))));
}
\f
/* Parser Initialization */
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)))
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); \
#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) \
char *scan; \
\
scan = (scan_init); \
- DECREMENT_SCAN (scan); \
+ MOVE_LEFT (scan); \
RIGHT_QUOTED_P_INTERNAL (scan, quoted); \
} while (0)
\f
LEFT_QUOTED_P (start, quoted);
WIN_IF (quoted ||
((SYNTAX_ENTRY_CODE (PEEK_LEFT (start))) != syntaxcode_quote));
- DECREMENT_SCAN (start);
+ MOVE_LEFT (start);
}
}
\f
{
LOSE_IF_RIGHT_END (start);
WIN_IF ((SYNTAX_ENTRY_CODE (PEEK_RIGHT (start))) == syntaxcode_word);
- INCREMENT_SCAN (start);
+ MOVE_RIGHT (start);
}
}
{
WIN_IF_RIGHT_END (start);
WIN_IF ((SYNTAX_ENTRY_CODE (PEEK_RIGHT (start))) != syntaxcode_word);
- INCREMENT_SCAN (start);
+ MOVE_RIGHT (start);
}
}
{
WIN_IF_LEFT_END (start);
WIN_IF ((SYNTAX_ENTRY_CODE (PEEK_LEFT (start))) != syntaxcode_word);
- DECREMENT_SCAN (start);
+ MOVE_LEFT (start);
}
}
\f
(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)
{
if ((SYNTAX_ENTRY_COMEND_FIRST (entry)) &&
(SYNTAX_ENTRY_COMEND_SECOND (PEEK_RIGHT (start))))
{
- INCREMENT_SCAN (start);
+ MOVE_RIGHT (start);
break;
}
}
case syntaxcode_escape:
case syntaxcode_charquote:
LOSE_IF_RIGHT_END (start);
- INCREMENT_SCAN (start);
+ MOVE_RIGHT (start);
case syntaxcode_word:
case syntaxcode_symbol:
{
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:
if ((SYNTAX_ENTRY_CODE (PEEK_RIGHT (start))) ==
syntaxcode_endcomment)
break;
- INCREMENT_SCAN (start);
+ MOVE_RIGHT (start);
}
break;
\f
if (! sexp_flag)
break;
if ((! (RIGHT_END_P (start))) && (c == *start))
- INCREMENT_SCAN (start);
+ MOVE_RIGHT (start);
if (math_exit)
{
WIN_IF (--depth == 0);
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;
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;
LEFT_QUOTED_P (start, quoted);
if (! quoted)
{
- DECREMENT_SCAN (start);
+ MOVE_LEFT (start);
LOSE_IF_LEFT_END (start);
while (true)
{
if ((SYNTAX_ENTRY_COMSTART_SECOND (entry)) &&
(SYNTAX_ENTRY_COMSTART_SECOND (PEEK_LEFT (start))))
{
- DECREMENT_SCAN (start);
+ MOVE_LEFT (start);
break;
}
}
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);
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;
if ((SYNTAX_ENTRY_CODE (PEEK_LEFT (start))) ==
syntaxcode_comment)
break;
- DECREMENT_SCAN (start);
+ MOVE_LEFT (start);
}
break;
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;
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)
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);
\f
/* Make sure there is enough room for the result before we start. */
(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)
DONE_IF_RIGHT_END (start);
if (SYNTAX_ENTRY_COMEND_SECOND (PEEK_RIGHT (start)))
{
- INCREMENT_SCAN (start);
+ MOVE_RIGHT (start);
break;
}
}
quoted = true;
DONE_IF (true);
}
- INCREMENT_SCAN (start);
+ MOVE_RIGHT (start);
goto start_atom;
case syntaxcode_word:
{
case syntaxcode_escape:
case syntaxcode_charquote:
- INCREMENT_SCAN (start);
+ MOVE_RIGHT (start);
if (RIGHT_END_P (start))
{
quoted = true;
case syntaxcode_word:
case syntaxcode_symbol:
- INCREMENT_SCAN (start);
+ MOVE_RIGHT (start);
break;
default:
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);
}
in_string = -1;
level->previous = level->last;
- INCREMENT_SCAN (start);
+ MOVE_RIGHT (start);
break;
}
}
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. */
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
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);
-}
\f
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);
}
\f
-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);
}
\f
-#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)
-\f
-#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)
-\f
void
Do_Micro_Error (Err, From_Pop_Return)
long Err;
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.
#include "scheme.h"
#include "primitive.h"
-\f
-#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 ()
\f
/*********************/
/* VECTORS <-> LISTS */
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);
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);
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. */
\f
#define VERSION 9
#endif
#ifndef SUBVERSION
-#define SUBVERSION 50
+#define SUBVERSION 51
#endif
#ifndef UCODE_TABLES_FILENAME
promotional, or sales literature without prior written consent from
MIT in each case. */
-/* $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/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
#endif
\f
#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)))
\f
#ifndef Heap_In_Low_Memory /* Safe version */
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 */
#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 */
#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 */
#define User_Vector_Ref(P, N) Vector_Ref(P, (N)+1)
#define User_Vector_Set(P, N, S) Vector_Set(P, (N)+1, S)
\f
+#define 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)
+\f
#define Make_Broken_Heart(N) (BROKEN_HEART_ZERO + (N))
#define Make_Unsigned_Fixnum(N) (FIXNUM_ZERO + (N))
#define Make_Signed_Fixnum(N) Make_Non_Pointer( TC_FIXNUM, (N))
-#define fixnum_p(P) ((pointer_type (P)) == TC_FIXNUM)
#define Get_Float(P) (* ((double *) (Nth_Vector_Loc ((P), 1))))
-#define Get_Integer(P) (pointer_datum (P))
-
-#define fixnum_negative_p(P) (((P) & FIXNUM_SIGN_BIT) != 0)
+#define Get_Integer(P) (OBJECT_DATUM (P))
#define Sign_Extend(P, S) \
{ \
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. */
\f
#define VERSION 9
#endif
#ifndef SUBVERSION
-#define SUBVERSION 50
+#define SUBVERSION 51
#endif
#ifndef UCODE_TABLES_FILENAME
projects / mit-scheme.git / commitdiff