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)