long
arg_ascii_char (int n)
{
CHECK_ARG (n, CHARACTER_P);
{
SCHEME_OBJECT object = (ARG_REF (n));
if (! (CHAR_TO_ASCII_P (object)))
error_bad_range_arg (n);
return (CHAR_TO_ASCII (object));
}
}
if (! (CHAR_TO_ASCII_P (object)))
error_bad_range_arg (n);
return (CHAR_TO_ASCII (object));
}
}
long
arg_ascii_integer (int n)
{
return (arg_index_integer (n, MAX_ASCII));
}
DEFINE_PRIMITIVE ("CHAR?", Prim_char_p, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (CHARACTER_P (ARG_REF (1))));
}
DEFINE_PRIMITIVE ("MAKE-CHAR", Prim_make_char, 2, 2, 0)
{
PRIMITIVE_HEADER (2);
PRIMITIVE_RETURN
(MAKE_CHAR ((arg_index_integer (2, MAX_BITS)),
(arg_index_integer (1, MAX_CODE))));
}
DEFINE_PRIMITIVE ("CHAR-BITS", Prim_char_bits, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
CHECK_ARG (1, CHARACTER_P);
PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (CHAR_BITS (ARG_REF (1))));
PRIMITIVE_RETURN (SHARP_F); \
else if ((result) == (-2)) \
error_bad_range_arg (1); \
else \
error_external_return (); \
/*NOTREACHED*/ \
return (0); \
} while (0)
DEFINE_PRIMITIVE ("RE-CHAR-SET-ADJOIN!", Prim_re_char_set_adjoin, 2, 2, 0)
{
int ascii;
PRIMITIVE_HEADER (2);
CHECK_ARG (1, RE_CHAR_SET_P);
ascii = (arg_ascii_integer (2));
(* (STRING_LOC ((ARG_REF (1)), (ascii / ASCII_LENGTH)))) |=
(1 << (ascii % ASCII_LENGTH));
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("RE-COMPILE-FASTMAP", Prim_re_compile_fastmap, 4, 4, 0)
{
SCHEME_OBJECT pattern;
int can_be_null;
PRIMITIVE_HEADER (4);
CHECK_ARG (1, STRING_P);
pattern = (ARG_REF (1));
CHECK_ARG (2, CHAR_TRANSLATION_P);
CHECK_ARG (3, SYNTAX_TABLE_P);
CHECK_ARG (4, CHAR_SET_P);
can_be_null =
if (gc_check_p)
Primitive_GC_If_Needed (length + 1);
{
SCHEME_OBJECT result = (MAKE_POINTER_OBJECT (TC_VECTOR, Free));
(*Free++) = (MAKE_OBJECT (TC_MANIFEST_VECTOR, length));
while ((length--) > 0)
(*Free++) = contents;
return (result);
}
}
DEFINE_PRIMITIVE ("VECTOR-CONS", Prim_vector_cons, 2, 2, 0)
{
PRIMITIVE_HEADER (2);
PRIMITIVE_RETURN
(make_vector ((arg_nonnegative_integer (1)), (ARG_REF (2)), true));
}
DEFINE_PRIMITIVE ("VECTOR", Prim_vector, 0, LEXPR, 0)
{
PRIMITIVE_HEADER (LEXPR);
{
SCHEME_OBJECT result =
(allocate_marked_vector (TC_VECTOR, GET_LEXPR_ACTUALS, true));
SCHEME_OBJECT * argument_scan = (ARG_LOC (1));
SCHEME_OBJECT * argument_limit = (ARG_LOC (GET_LEXPR_ACTUALS + 1));
SCHEME_OBJECT * result_scan = (VECTOR_LOC (result, 0));
while (argument_scan != argument_limit)
(*result_scan++) = (STACK_LOCATIVE_POP (argument_scan));
PRIMITIVE_RETURN (result);
}
return (arg_ulong_index_integer (arg, (1L << TYPE_CODE_LENGTH)));
}
static unsigned long
arg_datum (int arg)
{
return (arg_ulong_index_integer (arg, (1L << DATUM_LENGTH)));
}
/* Low level object manipulation */
DEFINE_PRIMITIVE ("PRIMITIVE-OBJECT-TYPE", Prim_prim_obj_type, 1, 1,
"Return the type code of OBJECT as an unsigned integer.")
{
PRIMITIVE_HEADER (1);
PRIMITIVE_RETURN (ULONG_TO_FIXNUM (OBJECT_TYPE (ARG_REF (1))));
}
DEFINE_PRIMITIVE ("PRIMITIVE-OBJECT-TYPE?", Prim_prim_obj_type_p, 2, 2,
"Return #T if TYPE-CODE is OBJECT's type code, else #F.")
{
PRIMITIVE_HEADER (2);
PRIMITIVE_RETURN
(BOOLEAN_TO_OBJECT ((OBJECT_TYPE (ARG_REF (2))) == (arg_type (1))));
}
DEFINE_PRIMITIVE ("PRIMITIVE-OBJECT-DATUM", Prim_prim_obj_datum, 1, 1,
"Return the datum part of OBJECT as an unsigned integer.")
{
PRIMITIVE_HEADER (1);
PRIMITIVE_RETURN (ulong_to_integer (OBJECT_DATUM (ARG_REF (1))));
{
Primitive_GC_If_Needed (2);
(*Free++) = car;
(*Free++) = cdr;
return (MAKE_POINTER_OBJECT (TC_LIST, (Free - 2)));
}
DEFINE_PRIMITIVE ("CONS", Prim_cons, 2, 2,
"(obj1 obj2)\n\
Returns a newly allocated pair whose car is OBJ1 and whose cdr is OBJ2.\n\
The pair is guaranteed to be different (in the sense of EQV?) from other\n\
previously existing object.\
")
{
PRIMITIVE_HEADER (2);
PRIMITIVE_RETURN (cons ((ARG_REF (1)), (ARG_REF (2))));
}
DEFINE_PRIMITIVE ("CAR", Prim_car, 1, 1,
"(pair)\n\
Returns the contents of the car field of PAIR.\n\
Note that it is an error to take the CAR of an empty list.\
")
{
PRIMITIVE_HEADER (1);
CHECK_ARG (1, PAIR_P);
PRIMITIVE_RETURN (PAIR_CAR (ARG_REF (1)));
}
DEFINE_PRIMITIVE ("CDR", Prim_cdr, 1, 1,
"(pair)\n\
static SCHEME_OBJECT
arg_vector_8b (int n)
{
CHECK_ARG (n, VECTOR_8B_P);
return (ARG_REF (n));
}
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
USA.
*/
/* Pure/constant space utilities. */
#include "scheme.h"
#include "prims.h"
DEFINE_PRIMITIVE ("PRIMITIVE-IMPURIFY", Prim_impurify, 1, 1,
"(OBJECT)\n\
Remove OBJECT from pure space, allowing it to be modified.")
{
PRIMITIVE_HEADER (1);
PRIMITIVE_RETURN (ARG_REF (1));
}
DEFINE_PRIMITIVE ("CONSTANT?", Prim_constant_p, 1, 1,
"(OBJECT)\n\
Returns #T iff OBJECT is in constant space.")
{
PRIMITIVE_HEADER (1);
PRIMITIVE_RETURN
(BOOLEAN_TO_OBJECT (object_in_constant_space_p (ARG_REF (1))));
}
DEFINE_PRIMITIVE ("PURE?", Prim_pure_p, 1, 1,
"(OBJECT)\n\
Returns #T iff OBJECT is in constant space and is 'pure'.")
{
PRIMITIVE_RETURN \
(BOOLEAN_TO_OBJECT (comparison ((ARG_REF (1)), (ARG_REF (2))))); \
}
DEFINE_PRIMITIVE ("INTEGER-EQUAL?", Prim_integer_equal_p, 2, 2, 0)
INTEGER_COMPARISON (integer_equal_p)
DEFINE_PRIMITIVE ("INTEGER-LESS?", Prim_integer_less_p, 2, 2, 0)
INTEGER_COMPARISON (integer_less_p)
DEFINE_PRIMITIVE ("INTEGER-GREATER?", Prim_integer_greater_p, 2, 2, 0)
{
PRIMITIVE_HEADER (2);
CHECK_ARG (1, INTEGER_P);
CHECK_ARG (2, INTEGER_P);
PRIMITIVE_RETURN
(BOOLEAN_TO_OBJECT (integer_less_p ((ARG_REF (2)), (ARG_REF (1)))));
}
#define INTEGER_BINARY_OPERATION(operator) \
{ \
PRIMITIVE_HEADER (2); \
CHECK_ARG (1, INTEGER_P); \
CHECK_ARG (2, INTEGER_P); \
PRIMITIVE_RETURN (operator ((ARG_REF (1)), (ARG_REF (2)))); \
}
DEFINE_PRIMITIVE ("INTEGER-ADD", Prim_integer_add, 2, 2, 0)
INTEGER_BINARY_OPERATION (integer_add)
DEFINE_PRIMITIVE ("INTEGER-SUBTRACT", Prim_integer_subtract, 2, 2, 0)
INTEGER_BINARY_OPERATION (integer_subtract)
DEFINE_PRIMITIVE ("INTEGER-MULTIPLY", Prim_integer_multiply, 2, 2, 0)
