static ptr eval(ptr x) {
if (Spairp(x)) {
switch (Schar_value(Scar(x))) {
case '+': return S_add(First(x), Second(x));
case '-': return S_sub(First(x), Second(x));
case '*': return S_mul(First(x), Second(x));
case '/': return S_div(First(x), Second(x));
case 'q': return S_trunc(First(x), Second(x));
case 'r': return S_rem(First(x), Second(x));
case 'g': return S_gcd(First(x), Second(x));
case '=': {
ptr x1 = First(x), x2 = Second(x);
if (Sfixnump(x1) && Sfixnump(x2))
return Sboolean(x1 == x2);
else if (Sbignump(x1) && Sbignump(x2))
return Sboolean(S_big_eq(x1, x2));
else return Sfalse;
}
case '<': {
ptr x1 = First(x), x2 = Second(x);
if (Sfixnump(x1))
if (Sfixnump(x2))
return Sboolean(x1 < x2);
else
return Sboolean(!BIGSIGN(x2));
else
if (Sfixnump(x2))
return Sboolean(BIGSIGN(x1));
else
return Sboolean(S_big_lt(x1, x2));
}
case 'f': return Sflonum(S_floatify(First(x)));
case 'c':
S_gc(get_thread_context(), UNFIX(First(x)),UNFIX(Second(x)));
return Svoid;
case 'd': return S_decode_float(Sflonum_value(First(x)));
default:
S_prin1(x);
putchar('\n');
printf("unrecognized operator, returning zero\n");
return FIX(0);
}
} else
return x;
}
void query_type(ptr x) {
printf("Object is a: ");
if (Sinexactnump(x)) printf("inexact ");
if (Sexactnump(x)) printf("exact ");
if (Sfixnump(x)) printf("fixnum ");
if (Scharp(x)) printf("char ");
if (Snullp(x)) printf("nil ");
if (Seof_objectp(x)) printf("eof ");
if (Sbwp_objectp(x)) printf("bwp ");
if (Sbooleanp(x)) printf("bool ");
if (Spairp(x)) printf("pair ");
if (Ssymbolp(x)) printf("symbol ");
if (Sprocedurep(x)) printf("procedure ");
if (Sflonump(x)) printf("flonum ");
if (Svectorp(x)) printf("vector ");
if (Sstringp(x)) printf("string ");
if (Sbignump(x)) printf("bignum ");
if (Sboxp(x)) printf("box ");
if (Sratnump(x)) printf("rational ");
if (Sinputportp(x)) printf("inputport ");
if (Soutputportp(x)) printf("outputport ");
if (Srecordp(x)) printf("record ");
printf("\n");
}
static void idiot_checks() {
IBOOL oops = 0;
if (bytes_per_segment < S_pagesize) {
fprintf(stderr, "bytes_per_segment (%x) < S_pagesize (%lx)\n",
bytes_per_segment, (long)S_pagesize);
oops = 1;
}
if (sizeof(iptr) != sizeof(ptr)) {
fprintf(stderr, "sizeof(iptr) [%ld] != sizeof(ptr) [%ld]\n",
(long)sizeof(iptr), (long)sizeof(ptr));
oops = 1;
}
if (sizeof(uptr) != sizeof(ptr)) {
fprintf(stderr, "sizeof(uptr) [%ld] != sizeof(ptr) [%ld]\n",
(long)sizeof(uptr), (long)sizeof(ptr));
oops = 1;
}
if (sizeof(ptr) * 8 != ptr_bits) {
fprintf(stderr, "sizeof(ptr) * 8 [%ld] != ptr_bits [%d]\n",
(long)sizeof(ptr), ptr_bits);
oops = 1;
}
if (sizeof(int) * 8 != int_bits) {
fprintf(stderr, "sizeof(int) * 8 [%ld] != int_bits [%d]\n",
(long)sizeof(int), int_bits);
oops = 1;
}
if (sizeof(short) * 8 != short_bits) {
fprintf(stderr, "sizeof(short) * 8 [%ld] != short_bits [%d]\n",
(long)sizeof(short), short_bits);
oops = 1;
}
if (sizeof(long) * 8 != long_bits) {
fprintf(stderr, "sizeof(long) * 8 [%ld] != long_bits [%d]\n",
(long)sizeof(long), long_bits);
oops = 1;
}
#ifndef WIN32
if (sizeof(long long) * 8 != long_long_bits) {
fprintf(stderr, "sizeof(long long) * 8 [%ld] != long_long_bits [%d]\n",
(long)sizeof(long long), long_long_bits);
oops = 1;
}
#endif
if (sizeof(wchar_t) * 8 != wchar_bits) {
fprintf(stderr, "sizeof(wchar_t) * 8 [%ld] != wchar_bits [%d]\n",
(long)sizeof(wchar_t), wchar_bits);
oops = 1;
}
if (sizeof(size_t) * 8 != size_t_bits) {
fprintf(stderr, "sizeof(size_t) * 8 [%ld] != size_t_bits [%d]\n",
(long)sizeof(size_t), size_t_bits);
oops = 1;
}
#ifndef WIN32
if (sizeof(ssize_t) * 8 != size_t_bits) {
fprintf(stderr, "sizeof(ssize_t) * 8 [%ld] != size_t_bits [%d]\n",
(long)sizeof(ssize_t), size_t_bits);
oops = 1;
}
#endif
if (sizeof(ptrdiff_t) * 8 != ptrdiff_t_bits) {
fprintf(stderr, "sizeof(ptrdiff_t) * 8 [%ld] != ptrdiff_t_bits [%d]\n",
(long)sizeof(ptrdiff_t), ptrdiff_t_bits);
oops = 1;
}
if (sizeof(time_t) * 8 != time_t_bits) {
fprintf(stderr, "sizeof(time_t) * 8 [%ld] != time_t_bits [%d]\n",
(long)sizeof(time_t), time_t_bits);
oops = 1;
}
if (sizeof(bigit) * 8 != bigit_bits) {
fprintf(stderr, "sizeof(bigit) * 8 [%ld] != bigit_bits [%d]\n",
(long)sizeof(bigit), bigit_bits);
oops = 1;
}
if (sizeof(bigitbigit) != 2 * sizeof(bigit)) {
fprintf(stderr, "sizeof(bigitbigit) [%ld] != sizeof(bigit) [%ld] * 2\n",
(long)sizeof(bigitbigit), (long)sizeof(bigit));
oops = 1;
}
if (sizeof(char) != 1) {
fprintf(stderr, "sizeof(char) [%ld] != 1\n", (long)sizeof(char));
oops = 1;
}
if (sizeof(I8) != 1) {
fprintf(stderr, "sizeof(I8) [%ld] != 1\n", (long)sizeof(I8));
oops = 1;
}
if (sizeof(U8) != 1) {
fprintf(stderr, "sizeof(U8) [%ld] != 1\n", (long)sizeof(U8));
oops = 1;
}
if (sizeof(I16) != 2) {
fprintf(stderr, "sizeof(I16) [%ld] != 2\n", (long)sizeof(I16));
oops = 1;
}
if (sizeof(U16) != 2) {
fprintf(stderr, "sizeof(U16) [%ld] != 2\n", (long)sizeof(U16));
oops = 1;
}
if (sizeof(I32) != 4) {
fprintf(stderr, "sizeof(I32) [%ld] != 4\n", (long)sizeof(I32));
oops = 1;
}
if (sizeof(U32) != 4) {
fprintf(stderr, "sizeof(U32) [%ld] != 4\n", (long)sizeof(U32));
oops = 1;
}
if (sizeof(I64) != 8) {
fprintf(stderr, "sizeof(I64) [%ld] != 8\n", (long)sizeof(I64));
oops = 1;
}
if (sizeof(U64) != 8) {
fprintf(stderr, "sizeof(U64) [%ld] != 8\n", (long)sizeof(U64));
oops = 1;
}
if (sizeof(string_char) != string_char_bytes) {
fprintf(stderr, "sizeof(string_char) [%ld] != string_char_bytes [%d]\n", (long)sizeof(string_char), string_char_bytes);
oops = 1;
}
if (UNFIX(fixtest) != -1) {
fprintf(stderr, "UNFIX operation failed\n");
oops = 1;
}
if (strlen(VERSION)+1 > HEAP_VERSION_LENGTH) {
fprintf(stderr, "insufficient space for version in heap header\n");
oops = 1;
}
if (strlen(MACHINE_TYPE)+1 > HEAP_MACHID_LENGTH) {
fprintf(stderr, "insufficient space for machine id in heap header\n");
oops = 1;
}
#define big 0
#define little 1
if (native_endianness == big) {
uptr x[1];
*x = 1;
if (*(char *)x != 0) {
fprintf(stderr, "endianness claimed to be big, appears to be little\n");
oops = 1;
}
} else {
uptr x[1];
*x = 1;
if (*(char *)x == 0) {
fprintf(stderr, "endianness claimed to be little, appears to be big\n");
oops = 1;
}
}
if (sizeof(bucket_pointer_list) != sizeof(bucket_list)) {
/* gc repurposes bucket_lists for bucket_pointer lists, so they'd better have the same size */
fprintf(stderr, "bucket_pointer_list and bucket_list have different sizes\n");
oops = 1;
}
if ((cards_per_segment & (sizeof(iptr) - 1)) != 0) {
/* gc sometimes processes dirty bytes sizeof(iptr) bytes at a time */
fprintf(stderr, "cards_per_segment is not a multiple of sizeof(iptr)\n");
oops = 1;
}
if (((uptr)(&((seginfo *)0)->dirty_bytes[0]) & (sizeof(iptr) - 1)) != 0) {
/* gc sometimes processes dirty bytes sizeof(iptr) bytes at a time */
fprintf(stderr, "dirty_bytes[0] is not iptr-aligned wrt to seginfo struct\n");
oops = 1;
}
if (!Sfixnump(type_vector | ~mask_vector)) {
/* gc counts on vector type/length looking like a fixnum, so it can put vectors in space_impure */
fprintf(stderr, "vector type/length field does not look like a fixnum\n");
oops = 1;
}
if (oops) S_abnormal_exit();
}
