/*------------------------------------------------------------
* Vport Getc
*/
static int vport_getc(ScmPort *p)
{
vport *data = (vport*)p->src.vt.data;
SCM_ASSERT(data != NULL);
if (SCM_FALSEP(data->getc_proc)) {
/* If the port doesn't have get-char method, try get-byte */
ScmObj b;
int n, i;
ScmChar ch;
char buf[SCM_CHAR_MAX_BYTES];
if (SCM_FALSEP(data->getb_proc)) return EOF;
b = Scm_ApplyRec(data->getb_proc, SCM_NIL);
if (!SCM_INTP(b)) return EOF;
buf[0] = (char)SCM_INT_VALUE(b);
n = SCM_CHAR_NFOLLOWS(p->scratch[0]);
for (i=0; i<n; i++) {
b = Scm_ApplyRec(data->getb_proc, SCM_NIL);
if (!SCM_INTP(b)) {
/* TODO: should raise an exception? */
return EOF;
}
buf[i+1] = (char)SCM_INT_VALUE(b);
}
SCM_CHAR_GET(buf, ch);
return ch;
} else {
ScmObj ch = Scm_ApplyRec(data->getc_proc, SCM_NIL);
if (!SCM_CHARP(ch)) return EOF;
return SCM_CHAR_VALUE(ch);
}
}
SCM_EXPORT ScmObj
scm_p_srfi60_logtest(ScmObj j, ScmObj k)
{
DECLARE_FUNCTION("logtest", procedure_fixed_2);
ENSURE_INT(j);
ENSURE_INT(k);
return MAKE_BOOL(SCM_INT_VALUE(j) & SCM_INT_VALUE(k));
}
SCM_EXPORT ScmObj
scm_p_prealloc_heaps(ScmObj n)
{
DECLARE_FUNCTION("%%prealloc-heaps", procedure_fixed_1);
ENSURE_INT(n);
if (SCM_INT_VALUE(n) < 0)
ERR_OBJ("non-negative number required but got", n);
scm_prealloc_heaps((size_t)SCM_INT_VALUE(n));
return n;
}
SCM_EXPORT ScmObj
scm_p_srfi60_bitwise_if(ScmObj mask, ScmObj n0, ScmObj n1)
{
scm_int_t result, c_mask;
DECLARE_FUNCTION("bitwise-if", procedure_fixed_3);
ENSURE_INT(mask);
ENSURE_INT(n0);
ENSURE_INT(n1);
c_mask = SCM_INT_VALUE(mask);
result = (c_mask & SCM_INT_VALUE(n0)) | (~c_mask & SCM_INT_VALUE(n1));
return MAKE_INT(result);
}
ScmObj Scm_MakeBignumFromDouble(double val)
{
if (LONG_MIN <= val
#if SIZEOF_LONG == 4
&& val <= LONG_MAX
#else
&& val <= nextafter((double)LONG_MAX, 0.0)
#endif
)
return Scm_MakeBignumFromSI((long)val);
int exponent, sign;
ScmObj mantissa = Scm_DecodeFlonum(val, &exponent, &sign);
if (!SCM_NUMBERP(mantissa)) {
Scm_Error("can't convert %lf to an integer", val);
}
ScmObj b = Scm_Ash(mantissa, exponent);
if (sign < 0) b = Scm_Negate(b);
/* always returns bignum */
if (SCM_INTP(b)) {
return Scm_MakeBignumFromSI(SCM_INT_VALUE(b));
} else {
return b;
}
}
/*------------------------------------------------------------
* Vport Getb
*/
static int vport_getb(ScmPort *p)
{
vport *data = (vport*)p->src.vt.data;
SCM_ASSERT(data != NULL);
if (SCM_FALSEP(data->getb_proc)) {
/* If the port doesn't have get-byte method, use get-char
if possible. */
ScmObj ch;
ScmChar c;
char buf[SCM_CHAR_MAX_BYTES];
int nb, i;
if (SCM_FALSEP(data->getc_proc)) return EOF;
ch = Scm_ApplyRec(data->getc_proc, SCM_NIL);
if (!SCM_CHARP(ch)) return EOF;
c = SCM_CHAR_VALUE(ch);
nb = SCM_CHAR_NBYTES(c);
SCM_CHAR_PUT(buf, c);
for (i=1; i<nb; i++) {
/* pushback for later use. this isn't very efficient;
if efficiency becomes a problem, we need another API
to pushback multiple bytes. */
Scm_UngetbUnsafe(buf[i], p);
}
return buf[0];
} else {
ScmObj b = Scm_ApplyRec(data->getb_proc, SCM_NIL);
if (!SCM_INTP(b)) return EOF;
return (SCM_INT_VALUE(b) & 0xff);
}
}
u_long Scm_EqvHash(ScmObj obj)
{
u_long hashval;
if (SCM_NUMBERP(obj)) {
if (SCM_INTP(obj)) {
SMALL_INT_HASH(hashval, SCM_INT_VALUE(obj));
} else if (SCM_BIGNUMP(obj)) {
u_int i;
u_long u = 0;
for (i=0; i<SCM_BIGNUM_SIZE(obj); i++) {
u += SCM_BIGNUM(obj)->values[i];
}
SMALL_INT_HASH(hashval, u);
} else if (SCM_FLONUMP(obj)) {
/* TODO: I'm not sure this is a good hash. */
hashval = (u_long)(SCM_FLONUM_VALUE(obj)*2654435761UL);
} else if (SCM_RATNUMP(obj)) {
/* Ratnum must be normalized, so we can simply combine
hashvals of numerator and denominator. */
u_long h1 = Scm_EqvHash(SCM_RATNUM_NUMER(obj));
u_long h2 = Scm_EqvHash(SCM_RATNUM_DENOM(obj));
hashval = COMBINE(h1, h2);
} else {
/* TODO: I'm not sure this is a good hash. */
hashval = (u_long)((SCM_COMPNUM_REAL(obj)+SCM_COMPNUM_IMAG(obj))*2654435761UL);
}
} else {
ADDRESS_HASH(hashval, obj);
}
return hashval&HASHMASK;
}
static int
prepare_radix(const char *funcname, ScmObj args)
{
ScmObj radix;
int r;
DECLARE_INTERNAL_FUNCTION("(internal)");
ASSERT_PROPER_ARG_LIST(args);
/* dirty hack to replace internal function name */
SCM_MANGLE(name) = funcname;
if (NULLP(args)) {
r = 10;
} else {
radix = POP(args);
ASSERT_NO_MORE_ARG(args);
ENSURE_INT(radix);
r = SCM_INT_VALUE(radix);
if (!VALID_RADIXP(r))
ERR_OBJ("invalid radix", radix);
}
return r;
}
static void sigerror_signal_set(ScmUnhandledSignalError *obj, ScmObj val)
{
if (!SCM_INTP(val)) {
Scm_Error("small integer required, but got %S", val);
}
obj->signal = SCM_INT_VALUE(val);
}
static void readerror_line_set(ScmReadError *obj, ScmObj val)
{
if (!SCM_INTP(val)){
Scm_Error("small integer required, but got %S", val);
}
obj->line = SCM_INT_VALUE(val);
}
static void syserror_number_set(ScmSystemError *obj, ScmObj val)
{
if (!SCM_INTP(val)) {
Scm_Error("small integer required, but got %S", val);
}
obj->error_number = SCM_INT_VALUE(val);
}
/* If OBJ is a primitive object (roughly, immediate or number), write it to
PORT. Assumes the caller locks the PORT.
Returns the # of characters written, or #f if OBJ is not a primitive object.
*/
ScmObj Scm__WritePrimitive(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
{
#define CASE_ITAG_RET(obj, str) \
case SCM_ITAG(obj): \
Scm_PutzUnsafe(str, -1, port); \
return SCM_MAKE_INT(sizeof(str)-1);
if (SCM_IMMEDIATEP(obj)) {
switch (SCM_ITAG(obj)) {
CASE_ITAG_RET(SCM_FALSE, "#f");
CASE_ITAG_RET(SCM_TRUE, "#t");
CASE_ITAG_RET(SCM_NIL, "()");
CASE_ITAG_RET(SCM_EOF, "#<eof>");
CASE_ITAG_RET(SCM_UNDEFINED, "#<undef>");
CASE_ITAG_RET(SCM_UNBOUND, "#<unbound>");
default:
Scm_Panic("write: unknown itag object: %08x", SCM_WORD(obj));
}
}
else if (SCM_INTP(obj)) {
char buf[SPBUFSIZ];
int k = snprintf(buf, SPBUFSIZ, "%ld", SCM_INT_VALUE(obj));
Scm_PutzUnsafe(buf, -1, port);
return SCM_MAKE_INT(k);
}
else if (SCM_CHARP(obj)) {
size_t k = write_char(SCM_CHAR_VALUE(obj), port, ctx);
return SCM_MAKE_INT(k);
}
else if (SCM_NUMBERP(obj)) {
return SCM_MAKE_INT(Scm_PrintNumber(port, obj, NULL));
}
return SCM_FALSE;
}
SCM_EXPORT ScmObj
scm_p_eqvp(ScmObj obj1, ScmObj obj2)
{
#if SCM_HAS_EQVP
#define scm_p_eqvp error_eqvp_recursed__ /* Safety measure. */
return EQVP(obj1, obj2);
#undef scm_p_eqvp
#else /* don't have inlined EQVP() */
#if (!(SCM_HAS_IMMEDIATE_NUMBER_ONLY && SCM_HAS_IMMEDIATE_CHAR_ONLY))
enum ScmObjType type;
#endif
DECLARE_FUNCTION("eqv?", procedure_fixed_2);
if (EQ(obj1, obj2))
return SCM_TRUE;
#if (!(SCM_HAS_IMMEDIATE_NUMBER_ONLY && SCM_HAS_IMMEDIATE_CHAR_ONLY))
type = SCM_TYPE(obj1);
/* different type */
if (type != SCM_TYPE(obj2))
return SCM_FALSE;
/* same type */
switch (type) {
#if (SCM_USE_INT && !SCM_HAS_IMMEDIATE_INT_ONLY)
case ScmInt:
return MAKE_BOOL(SCM_INT_VALUE(obj1) == SCM_INT_VALUE(obj2));
#endif
#if (SCM_USE_CHAR && !SCM_HAS_IMMEDIATE_CHAR_ONLY)
case ScmChar:
return MAKE_BOOL(SCM_CHAR_VALUE(obj1) == SCM_CHAR_VALUE(obj2));
#endif
default:
break;
}
#endif /* (!(SCM_HAS_IMMEDIATE_NUMBER_ONLY && SCM_HAS_IMMEDIATE_CHAR_ONLY)) */
return SCM_FALSE;
#endif /* don't have inlined EQVP() */
}
static ScmObj
scm_p_set_macro_debug_flagsx(ScmObj new_mode)
{
SCM_ASSERT(INTP(new_mode));
l_debug_mode = SCM_INT_VALUE(new_mode);
return SCM_UNDEF;
}
static int cmp_scm(ScmObj x, ScmObj y, ScmObj fn)
{
ScmObj r = Scm_ApplyRec(fn, SCM_LIST2(x, y));
if (SCM_TRUEP(r) || (SCM_INTP(r) && SCM_INT_VALUE(r) < 0))
return -1;
else
return 1;
}
/*------------------------------------------------------------
* Bport filenum
*/
static int bport_filenum(ScmPort *p)
{
bport *data = (bport*)p->src.buf.data;
SCM_ASSERT(data != NULL);
if (SCM_FALSEP(data->filenum_proc)) {
return -1;
} else {
ScmObj s = Scm_ApplyRec(data->filenum_proc, SCM_NIL);
if (SCM_INTP(s)) return SCM_INT_VALUE(s);
else return -1;
}
}
/* If OBJ is a primitive object (roughly, immediate or number), write it to
PORT. Assumes the caller locks the PORT.
Returns the # of characters written, or #f if OBJ is not a primitive object.
*/
ScmObj Scm__WritePrimitive(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
{
const ScmWriteControls *wp = Scm_GetWriteControls(ctx, port->writeState);
#define CASE_ITAG_RET(obj, str) \
case SCM_ITAG(obj): \
Scm_PutzUnsafe(str, -1, port); \
return SCM_MAKE_INT(sizeof(str)-1);
if (SCM_IMMEDIATEP(obj)) {
switch (SCM_ITAG(obj)) {
CASE_ITAG_RET(SCM_FALSE, "#f");
CASE_ITAG_RET(SCM_TRUE, "#t");
CASE_ITAG_RET(SCM_NIL, "()");
CASE_ITAG_RET(SCM_EOF, "#<eof>");
CASE_ITAG_RET(SCM_UNDEFINED, "#<undef>");
CASE_ITAG_RET(SCM_UNBOUND, "#<unbound>");
default:
Scm_Panic("write: unknown itag object: %08x", SCM_WORD(obj));
}
}
else if (SCM_INTP(obj) && wp->printBase == 10 && !wp->printRadix) {
/* Shortcut to avoid allocation */
char buf[SPBUFSIZ];
int k = snprintf(buf, SPBUFSIZ, "%ld", SCM_INT_VALUE(obj));
Scm_PutzUnsafe(buf, -1, port);
return SCM_MAKE_INT(k);
}
else if (SCM_CHARP(obj)) {
size_t k = write_char(SCM_CHAR_VALUE(obj), port, ctx);
return SCM_MAKE_INT(k);
}
else if (SCM_NUMBERP(obj)) {
ScmNumberFormat fmt;
Scm_NumberFormatInit(&fmt);
fmt.radix = wp->printBase;
if (wp->printRadix) fmt.flags |= SCM_NUMBER_FORMAT_ALT_RADIX;
return SCM_MAKE_INT(Scm_PrintNumber(port, obj, &fmt));
}
/* PVREF only appears in pattern temlate in the current macro expander.
It will be go away once we rewrite the expander. */
else if (SCM_PVREF_P(obj)) {
char buf[SPBUFSIZ];
int k = snprintf(buf, SPBUFSIZ, "#<pvar %ld.%ld>",
SCM_PVREF_LEVEL(obj), SCM_PVREF_COUNT(obj));
Scm_PutzUnsafe(buf, -1, port);
return SCM_MAKE_INT(k);
}
return SCM_FALSE;
}
/*------------------------------------------------------------
* Bport fill
*/
static int bport_fill(ScmPort *p, int cnt)
{
bport *data = (bport*)p->src.buf.data;
SCM_ASSERT(data != NULL);
if (SCM_FALSEP(data->fill_proc)) {
return 0; /* indicates EOF */
}
ScmObj vec = Scm_MakeU8VectorFromArrayShared(
cnt, (unsigned char*)p->src.buf.buffer);
ScmObj r = Scm_ApplyRec(data->fill_proc, SCM_LIST1(vec));
if (SCM_INTP(r)) return SCM_INT_VALUE(r);
else if (SCM_EOFP(r)) return 0;
else return -1;
}
/* multifunction on sigset
if delp == FALSE, signals are added to set.
else, signals are removed from set.
signals is a list of either integer or #t (all signals), or other sigset.
*/
ScmObj Scm_SysSigsetOp(ScmSysSigset *set, ScmObj signals, int delp)
{
if (!SCM_PAIRP(signals)) {
Scm_Error("list of signals required, but got %S", signals);
}
ScmObj cp;
SCM_FOR_EACH(cp, signals) {
ScmObj s = SCM_CAR(cp);
if (SCM_TRUEP(s)) {
if (!delp) sigfillset(&set->set);
else sigemptyset(&set->set);
break;
}
if (SCM_SYS_SIGSET_P(s)) {
sigset_op(&set->set, &SCM_SYS_SIGSET(s)->set, delp);
continue;
}
if (!SCM_INTP(s) || !validsigp(SCM_INT_VALUE(s))) {
Scm_Error("bad signal number %S", s);
}
if (!delp) sigaddset(&set->set, SCM_INT_VALUE(s));
else sigdelset(&set->set, SCM_INT_VALUE(s));
}
/*------------------------------------------------------------
* Bport flush
*/
static int bport_flush(ScmPort *p, int cnt, int forcep)
{
bport *data = (bport*)p->src.buf.data;
ScmObj vec, r;
SCM_ASSERT(data != NULL);
if (SCM_FALSEP(data->flush_proc)) {
return cnt; /* blackhole */
}
vec = Scm_MakeU8VectorFromArrayShared(cnt,
(unsigned char*)p->src.buf.buffer);
r = Scm_ApplyRec(data->flush_proc, SCM_LIST2(vec, SCM_MAKE_BOOL(forcep)));
if (SCM_INTP(r)) return SCM_INT_VALUE(r);
else if (SCM_EOFP(r)) return 0;
else return -1;
}
void Scm_ProfilerCountBufferFlush(ScmVM *vm)
{
if (vm->prof == NULL) return; /* for safety */
if (vm->prof->currentCount == 0) return;
/* suspend itimer during hash table operation */
#if !defined(GAUCHE_WINDOWS)
sigset_t set;
sigemptyset(&set);
sigaddset(&set, SIGPROF);
SIGPROCMASK(SIG_BLOCK, &set, NULL);
#endif /* !GAUCHE_WINDOWS */
int ncounts = vm->prof->currentCount;
for (int i=0; i<ncounts; i++) {
ScmObj e;
int cnt;
ScmObj func = vm->prof->counts[i].func;
if (SCM_METHODP(func) && SCM_METHOD(func)->func == NULL) {
/* func is Scheme-defined method. Record the code of
method body, so that we can match it with sampling
profiler later. */
func = SCM_OBJ(SCM_METHOD(func)->data);
}
e = Scm_HashTableSet(vm->prof->statHash,
vm->prof->counts[i].func,
SCM_FALSE,
SCM_DICT_NO_OVERWRITE);
if (SCM_FALSEP(e)) {
e = Scm_HashTableSet(vm->prof->statHash,
vm->prof->counts[i].func,
Scm_Cons(SCM_MAKE_INT(0), SCM_MAKE_INT(0)),
0);
}
SCM_ASSERT(SCM_PAIRP(e));
cnt = SCM_INT_VALUE(SCM_CAR(e)) + 1;
SCM_SET_CAR(e, SCM_MAKE_INT(cnt));
}
vm->prof->currentCount = 0;
/* resume itimer */
#if !defined(GAUCHE_WINDOWS)
SIGPROCMASK(SIG_UNBLOCK, &set, NULL);
#endif /* !GAUCHE_WINDOWS */
}
/* register samples into the stat table. Called from Scm_ProfilerResult */
void collect_samples(ScmVMProfiler *prof)
{
for (int i=0; i<prof->currentSample; i++) {
ScmObj e = Scm_HashTableRef(prof->statHash,
prof->samples[i].func, SCM_UNBOUND);
if (SCM_UNBOUNDP(e)) {
/* NB: just for now */
Scm_Warn("profiler: uncounted object appeared in a sample: %p (%S)\n",
prof->samples[i].func, prof->samples[i].func);
} else {
SCM_ASSERT(SCM_PAIRP(e));
int cnt = SCM_INT_VALUE(SCM_CDR(e)) + 1;
SCM_SET_CDR(e, SCM_MAKE_INT(cnt));
}
}
}
void
graphicsGdImageSetStyle(gdImage *im, ScmObj style, int styleLength)
{
ScmObj head;
int *p, *q, i = 0;
CHECK_LIST_AND_LENGTH(style, styleLength);
p = q = calloc(styleLength, sizeof(int));
if (p == NULL) {
graphicsGdRaiseCondition("calloc failed: %s", "graphicsGdImageSetStyle");
return;
}
SCM_FOR_EACH (head, style) {
if (i++ == styleLength) break;
*q++ = SCM_INT_VALUE(SCM_CAR(head));
}
gdImageSetStyle(im, p, styleLength);
free(p);
}
SCM_EXPORT ScmObj
scm_p_number2string(ScmObj num, ScmObj args)
{
char *str;
intmax_t n;
int r;
ScmValueFormat vfmt;
DECLARE_FUNCTION("number->string", procedure_variadic_1);
ENSURE_INT(num);
n = (intmax_t)SCM_INT_VALUE(num);
r = prepare_radix(SCM_MANGLE(name), args);
SCM_VALUE_FORMAT_INIT(vfmt);
str = scm_int2string(vfmt, (uintmax_t)n, r);
return MAKE_STRING(str, SCM_STRLEN_UNKNOWN);
}
SCM_EXPORT ScmObj
scm_p_exit(ScmObj args)
{
ScmObj explicit_status;
int status;
DECLARE_FUNCTION("exit", procedure_variadic_0);
if (NULLP(args)) {
status = EXIT_SUCCESS;
} else {
explicit_status = POP(args);
ASSERT_NO_MORE_ARG(args);
ENSURE_INT(explicit_status);
status = SCM_INT_VALUE(explicit_status);
}
scm_finalize();
exit(status);
}
ScmObj Scm_MakeBignumFromDouble(double val)
{
int exponent, sign;
ScmObj mantissa, b;
if (val >= LONG_MIN && val <= LONG_MAX) {
return Scm_MakeBignumFromSI((long)val);
}
mantissa = Scm_DecodeFlonum(val, &exponent, &sign);
if (!SCM_NUMBERP(mantissa)) {
Scm_Error("can't convert %lf to an integer", val);
}
b = Scm_Ash(mantissa, exponent);
if (sign < 0) b = Scm_Negate(b);
/* always returns bignum */
if (SCM_INTP(b)) {
return Scm_MakeBignumFromSI(SCM_INT_VALUE(b));
} else {
return b;
}
}
static void
write_obj(ScmObj port, ScmObj obj, enum ScmOutputType otype)
{
ScmObj sym;
#if SCM_USE_SRFI38
if (INTERESTINGP(obj)) {
scm_intobj_t index = get_shared_index(obj);
if (index > 0) {
/* defined datum */
scm_format(port, SCM_FMT_RAW_C, "#~ZU#", (size_t)index);
return;
}
if (index < 0) {
/* defining datum, with the new index negated */
scm_format(port, SCM_FMT_RAW_C, "#~ZU=", (size_t)-index);
/* Print it; the next time it'll be defined. */
}
}
#endif
switch (SCM_TYPE(obj)) {
#if SCM_USE_INT
case ScmInt:
scm_format(port, SCM_FMT_RAW_C, "~MD", SCM_INT_VALUE(obj));
break;
#endif
case ScmCons:
if (ERROBJP(obj))
write_errobj(port, obj, otype);
else
write_list(port, obj, otype);
break;
case ScmSymbol:
scm_port_puts(port, SCM_SYMBOL_NAME(obj));
break;
#if SCM_USE_CHAR
case ScmChar:
write_char(port, obj, otype);
break;
#endif
#if SCM_USE_STRING
case ScmString:
write_string(port, obj, otype);
break;
#endif
case ScmFunc:
scm_port_puts(port, (SCM_SYNTAXP(obj)) ? "#<syntax " : "#<subr ");
sym = scm_symbol_bound_to(obj);
if (TRUEP(sym))
scm_display(port, sym);
else
scm_format(port, SCM_FMT_RAW_C, "~P", (void *)obj);
scm_port_put_char(port, '>');
break;
#if SCM_USE_HYGIENIC_MACRO
case ScmMacro:
scm_port_puts(port, "#<macro ");
write_obj(port, SCM_HMACRO_RULES(obj), otype);
scm_port_puts(port, ">");
break;
case ScmFarsymbol:
write_farsymbol(port, obj, otype);
break;
case ScmSubpat:
if (SCM_SUBPAT_PVARP(obj)) {
#if SCM_DEBUG_MACRO
scm_port_puts(port, "#<pvar ");
write_obj(port, SCM_SUBPAT_OBJ(obj), otype);
scm_format(port, SCM_FMT_RAW_C, " ~MD>",
SCM_SUBPAT_PVAR_INDEX(obj));
#else /* not SCM_DEBUG_MACRO */
write_obj(port, SCM_SUBPAT_OBJ(obj), otype);
#endif /* not SCM_DEBUG_MACRO */
} else {
SCM_ASSERT(SCM_SUBPAT_REPPATP(obj));
write_obj(port, SCM_SUBPAT_REPPAT_PAT(obj), otype);
#if SCM_DEBUG_MACRO
scm_format(port, SCM_FMT_RAW_C, " ..[~MD]..",
SCM_SUBPAT_REPPAT_PVCOUNT(obj));
#else
scm_port_puts(port, " ...");
#endif
}
break;
#endif /* SCM_USE_HYGIENIC_MACRO */
case ScmClosure:
#if SCM_USE_LEGACY_MACRO
if (SYNTACTIC_CLOSUREP(obj))
scm_port_puts(port, "#<syntactic closure ");
else
#endif
scm_port_puts(port, "#<closure ");
write_obj(port, SCM_CLOSURE_EXP(obj), otype);
scm_port_put_char(port, '>');
break;
#if SCM_USE_VECTOR
case ScmVector:
write_vector(port, obj, otype);
break;
#endif
case ScmPort:
write_port(port, obj, otype);
break;
#if SCM_USE_CONTINUATION
case ScmContinuation:
scm_format(port, SCM_FMT_RAW_C, "#<continuation ~P>", (void *)obj);
break;
#endif
case ScmValuePacket:
scm_port_puts(port, "#<values ");
write_obj(port, SCM_VALUEPACKET_VALUES(obj), otype);
#if SCM_USE_VALUECONS
#if SCM_USE_STORAGE_FATTY
/* SCM_VALUEPACKET_VALUES() changes the type destructively */
SCM_ENTYPE(obj, ScmValuePacket);
#else /* SCM_USE_STORAGE_FATTY */
#error "valuecons is not supported on this storage implementation"
#endif /* SCM_USE_STORAGE_FATTY */
#endif /* SCM_USE_VALUECONS */
scm_port_put_char(port, '>');
break;
case ScmConstant:
write_constant(port, obj, otype);
break;
#if SCM_USE_SSCM_EXTENSIONS
case ScmCPointer:
scm_format(port, SCM_FMT_RAW_C,
"#<c_pointer ~P>", SCM_C_POINTER_VALUE(obj));
break;
case ScmCFuncPointer:
scm_format(port, SCM_FMT_RAW_C,
"#<c_func_pointer ~P>",
(void *)(uintptr_t)SCM_C_FUNCPOINTER_VALUE(obj));
break;
#endif
case ScmRational:
case ScmReal:
case ScmComplex:
default:
SCM_NOTREACHED;
}
}
/* Trick: The hashtable contains positive integer after the walk pass.
If we emit a reference tag N, we replace the entry's value to -N,
so that we can distinguish whether we've already emitted the object
or not. */
static void write_rec(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
{
char numbuf[50]; /* enough to contain long number */
ScmObj stack = SCM_NIL;
ScmWriteState *st = port->writeState;
ScmHashTable *ht = (st? st->sharedTable : NULL);
int stack_depth = 0;
#define PUSH(elt) \
do { \
stack = Scm_Cons(elt, stack); \
if (!ht && ++stack_depth > STACK_LIMIT) { \
Scm_Error("write recursed too deeply; " \
"maybe a circular structure?"); \
} \
} while (0)
#define POP() \
do { \
stack = SCM_CDR(stack); \
if (ht) stack_depth--; \
} while (0)
for (;;) {
write1:
if (ctx->flags & WRITE_LIMITED) {
if (port->src.ostr.length >= ctx->limit) return;
}
/* number may be heap allocated, but we don't use srfi-38 notation. */
if (!SCM_PTRP(obj) || SCM_NUMBERP(obj)) {
if (SCM_FALSEP(Scm__WritePrimitive(obj, port, ctx))) {
Scm_Panic("write: got a bogus object: %08x", SCM_WORD(obj));
}
goto next;
}
if ((SCM_STRINGP(obj) && SCM_STRING_SIZE(obj) == 0)
|| (SCM_VECTORP(obj) && SCM_VECTOR_SIZE(obj) == 0)) {
/* we don't put a reference tag for these */
write_general(obj, port, ctx);
goto next;
}
if (ht) {
ScmObj e = Scm_HashTableRef(ht, obj, SCM_MAKE_INT(1));
long k = SCM_INT_VALUE(e);
if (k <= 0) {
/* This object is already printed. */
snprintf(numbuf, 50, "#%ld#", -k);
Scm_PutzUnsafe(numbuf, -1, port);
goto next;
} else if (k > 1) {
/* This object will be seen again. Put a reference tag. */
ScmWriteState *s = port->writeState;
snprintf(numbuf, 50, "#%d=", s->sharedCounter);
Scm_HashTableSet(ht, obj, SCM_MAKE_INT(-s->sharedCounter), 0);
s->sharedCounter++;
Scm_PutzUnsafe(numbuf, -1, port);
}
}
/* Writes aggregates */
if (SCM_PAIRP(obj)) {
/* special case for quote etc.
NB: we need to check if we've seen SCM_CDR(obj), otherwise we'll
get infinite recursion for the case like (cdr '#1='#1#). */
if (SCM_PAIRP(SCM_CDR(obj)) && SCM_NULLP(SCM_CDDR(obj))
&& (!ht
|| SCM_FALSEP(Scm_HashTableRef(ht, SCM_CDR(obj), SCM_FALSE)))){
const char *prefix = NULL;
if (SCM_CAR(obj) == SCM_SYM_QUOTE) {
prefix = "'";
} else if (SCM_CAR(obj) == SCM_SYM_QUASIQUOTE) {
prefix = "`";
} else if (SCM_CAR(obj) == SCM_SYM_UNQUOTE) {
prefix = ",";
} else if (SCM_CAR(obj) == SCM_SYM_UNQUOTE_SPLICING) {
prefix = ",@";
}
if (prefix) {
Scm_PutzUnsafe(prefix, -1, port);
obj = SCM_CADR(obj);
goto write1;
}
}
/* normal case */
Scm_PutcUnsafe('(', port);
PUSH(Scm_Cons(SCM_TRUE, SCM_CDR(obj)));
obj = SCM_CAR(obj);
goto write1;
} else if (SCM_VECTORP(obj)) {
Scm_PutzUnsafe("#(", -1, port);
PUSH(Scm_Cons(SCM_MAKE_INT(1), obj));
obj = SCM_VECTOR_ELEMENT(obj, 0);
goto write1;
} else {
/* string or user-defined object */
write_general(obj, port, ctx);
goto next;
}
next:
while (SCM_PAIRP(stack)) {
ScmObj top = SCM_CAR(stack);
SCM_ASSERT(SCM_PAIRP(top));
if (SCM_INTP(SCM_CAR(top))) {
/* we're processing a vector */
ScmObj v = SCM_CDR(top);
int i = SCM_INT_VALUE(SCM_CAR(top));
int len = SCM_VECTOR_SIZE(v);
if (i == len) { /* we've done this vector */
Scm_PutcUnsafe(')', port);
POP();
} else {
Scm_PutcUnsafe(' ', port);
obj = SCM_VECTOR_ELEMENT(v, i);
SCM_SET_CAR(top, SCM_MAKE_INT(i+1));
goto write1;
}
} else {
/* we're processing a list */
ScmObj v = SCM_CDR(top);
if (SCM_NULLP(v)) { /* we've done with this list */
Scm_PutcUnsafe(')', port);
POP();
} else if (!SCM_PAIRP(v)) {
Scm_PutzUnsafe(" . ", -1, port);
obj = v;
SCM_SET_CDR(top, SCM_NIL);
goto write1;
} else if (ht && !SCM_EQ(Scm_HashTableRef(ht, v, SCM_MAKE_INT(1)), SCM_MAKE_INT(1))) {
/* cdr part is shared */
Scm_PutzUnsafe(" . ", -1, port);
obj = v;
SCM_SET_CDR(top, SCM_NIL);
goto write1;
} else {
Scm_PutcUnsafe(' ', port);
obj = SCM_CAR(v);
SCM_SET_CDR(top, SCM_CDR(v));
goto write1;
}
}
}
break;
}
#undef PUSH
#undef POP
}
/* Trick: The hashtable contains positive integer after the walk pass.
If we emit a reference tag N, we replace the entry's value to -N,
so that we can distinguish whether we've already emitted the object
or not. */
static void write_rec(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
{
char numbuf[50]; /* enough to contain long number */
ScmObj stack = SCM_NIL;
ScmWriteState *st = port->writeState;
ScmHashTable *ht = (st? st->sharedTable : NULL);
const ScmWriteControls *wp = Scm_GetWriteControls(ctx, st);
int stack_depth = 0; /* only used when !ht */
#define PUSH(elt) \
do { \
stack = Scm_Cons(elt, stack); \
if (!ht && ++stack_depth > STACK_LIMIT) { \
Scm_Error("write recursed too deeply; " \
"maybe a circular structure?"); \
} \
} while (0)
#define POP() \
do { \
stack = SCM_CDR(stack); \
if (!ht) stack_depth--; \
} while (0)
#define CHECK_LEVEL() \
do { \
if (st) { \
if (wp->printLevel >= 0 && st->currentLevel >= wp->printLevel) { \
Scm_PutcUnsafe('#', port); \
goto next; \
} else { \
if (st) st->currentLevel++; \
} \
} \
} while (0)
for (;;) {
write1:
if (ctx->flags & WRITE_LIMITED) {
if (port->src.ostr.length >= ctx->limit) return;
}
/* number may be heap allocated, but we don't use srfi-38 notation. */
if (!SCM_PTRP(obj) || SCM_NUMBERP(obj)) {
if (SCM_FALSEP(Scm__WritePrimitive(obj, port, ctx))) {
Scm_Panic("write: got a bogus object: %08x", SCM_WORD(obj));
}
goto next;
}
if ((SCM_STRINGP(obj) && SCM_STRING_SIZE(obj) == 0)
|| (SCM_VECTORP(obj) && SCM_VECTOR_SIZE(obj) == 0)) {
/* we don't put a reference tag for these */
write_general(obj, port, ctx);
goto next;
}
/* obj is heap allocated and we may use label notation. */
if (ht) {
ScmObj e = Scm_HashTableRef(ht, obj, SCM_MAKE_INT(1));
long k = SCM_INT_VALUE(e);
if (k <= 0) {
/* This object is already printed. */
snprintf(numbuf, 50, "#%ld#", -k);
Scm_PutzUnsafe(numbuf, -1, port);
goto next;
} else if (k > 1) {
/* This object will be seen again. Put a reference tag. */
ScmWriteState *s = port->writeState;
snprintf(numbuf, 50, "#%d=", s->sharedCounter);
Scm_HashTableSet(ht, obj, SCM_MAKE_INT(-s->sharedCounter), 0);
s->sharedCounter++;
Scm_PutzUnsafe(numbuf, -1, port);
}
}
/* Writes aggregates */
if (SCM_PAIRP(obj)) {
CHECK_LEVEL();
/* special case for quote etc.
NB: we need to check if we've seen SCM_CDR(obj), otherwise we'll
get infinite recursion for the case like (cdr '#1='#1#). */
if (SCM_PAIRP(SCM_CDR(obj)) && SCM_NULLP(SCM_CDDR(obj))
&& (!ht
|| SCM_FALSEP(Scm_HashTableRef(ht, SCM_CDR(obj), SCM_FALSE)))){
const char *prefix = NULL;
if (SCM_CAR(obj) == SCM_SYM_QUOTE) {
prefix = "'";
} else if (SCM_CAR(obj) == SCM_SYM_QUASIQUOTE) {
prefix = "`";
} else if (SCM_CAR(obj) == SCM_SYM_UNQUOTE) {
prefix = ",";
} else if (SCM_CAR(obj) == SCM_SYM_UNQUOTE_SPLICING) {
prefix = ",@";
}
if (prefix) {
Scm_PutzUnsafe(prefix, -1, port);
obj = SCM_CADR(obj);
goto write1;
}
}
if (wp->printLength == 0) {
/* in this case we don't print the elements at all, so we need
to treat this specially. */
Scm_PutzUnsafe("(...)", -1, port);
if (st) st->currentLevel--;
goto next;
}
/* normal case */
Scm_PutcUnsafe('(', port);
PUSH(Scm_Cons(SCM_TRUE, Scm_Cons(SCM_MAKE_INT(1), SCM_CDR(obj))));
obj = SCM_CAR(obj);
goto write1;
} else if (SCM_VECTORP(obj)) {
CHECK_LEVEL();
if (wp->printLength == 0) {
/* in this case we don't print the elements at all, so we need
to treat this specially. */
Scm_PutzUnsafe("#(...)", -1, port);
if (st) st->currentLevel--;
goto next;
}
Scm_PutzUnsafe("#(", -1, port);
PUSH(Scm_Cons(SCM_MAKE_INT(1), obj));
obj = SCM_VECTOR_ELEMENT(obj, 0);
goto write1;
} else if (Scm_ClassOf(obj)->flags & SCM_CLASS_AGGREGATE) {
CHECK_LEVEL();
write_general(obj, port, ctx);
if (st) st->currentLevel--;
goto next;
} else {
write_general(obj, port, ctx);
goto next;
}
next:
while (SCM_PAIRP(stack)) {
ScmObj top = SCM_CAR(stack);
SCM_ASSERT(SCM_PAIRP(top));
if (SCM_INTP(SCM_CAR(top))) {
/* we're processing a vector */
ScmObj v = SCM_CDR(top);
int i = SCM_INT_VALUE(SCM_CAR(top));
int len = SCM_VECTOR_SIZE(v);
if (i == len) { /* we've done this vector */
Scm_PutcUnsafe(')', port);
POP();
} else if (wp->printLength >= 0 && wp->printLength <= i) {
Scm_PutzUnsafe(" ...)", -1, port);
POP();
} else {
Scm_PutcUnsafe(' ', port);
obj = SCM_VECTOR_ELEMENT(v, i);
SCM_SET_CAR(top, SCM_MAKE_INT(i+1));
goto write1;
}
} else {
/* we're processing a list */
SCM_ASSERT(SCM_PAIRP(SCM_CDR(top)));
long count = SCM_INT_VALUE(SCM_CADR(top));
ScmObj v = SCM_CDDR(top);
if (SCM_NULLP(v)) { /* we've done with this list */
Scm_PutcUnsafe(')', port);
POP();
} else if (!SCM_PAIRP(v)) {
/* Improper list. We treat aggregate types specially,
since such object at this position shouldn't increment
"level" - its content is regarded as the same level of
the current list.
*/
Scm_PutzUnsafe(" . ", -1, port);
if (Scm_ClassOf(v)->flags & SCM_CLASS_AGGREGATE) {
if (st) st->currentLevel--;
write_rec(v, port, ctx);
if (st) st->currentLevel++;
Scm_PutcUnsafe(')', port);
POP();
} else {
obj = v;
SCM_SET_CAR(SCM_CDR(top), SCM_MAKE_INT(count+1));
SCM_SET_CDR(SCM_CDR(top), SCM_NIL);
goto write1;
}
} else if (wp->printLength >= 0 && wp->printLength <= count) {
/* print-length limit reached */
Scm_PutzUnsafe(" ...)", -1, port);
POP();
} else if (ht && !SCM_EQ(Scm_HashTableRef(ht, v, SCM_MAKE_INT(1)), SCM_MAKE_INT(1))) {
/* cdr part is shared */
Scm_PutzUnsafe(" . ", -1, port);
obj = v;
SCM_SET_CAR(SCM_CDR(top), SCM_MAKE_INT(count+1));
SCM_SET_CDR(SCM_CDR(top), SCM_NIL);
goto write1;
} else {
Scm_PutcUnsafe(' ', port);
obj = SCM_CAR(v);
SCM_SET_CAR(SCM_CDR(top), SCM_MAKE_INT(count+1));
SCM_SET_CDR(SCM_CDR(top), SCM_CDR(v));
goto write1;
}
}
if (st) st->currentLevel--;
}
break;
}
#undef PUSH
#undef POP
#undef CHECK_DEPTH
}
SCM_EXPORT ScmObj
scm_p_equalp(ScmObj obj1, ScmObj obj2)
{
enum ScmObjType type;
ScmObj elm1, elm2;
#if SCM_USE_VECTOR
ScmObj *v1, *v2;
scm_int_t i, len;
#endif
DECLARE_FUNCTION("equal?", procedure_fixed_2);
if (EQ(obj1, obj2))
return SCM_TRUE;
type = SCM_TYPE(obj1);
/* different type */
if (type != SCM_TYPE(obj2))
return SCM_FALSE;
/* same type */
switch (type) {
#if (SCM_USE_INT && !SCM_HAS_IMMEDIATE_INT_ONLY)
case ScmInt:
return MAKE_BOOL(SCM_INT_VALUE(obj1) == SCM_INT_VALUE(obj2));
#endif
#if (SCM_USE_CHAR && !SCM_HAS_IMMEDIATE_CHAR_ONLY)
case ScmChar:
return MAKE_BOOL(SCM_CHAR_VALUE(obj1) == SCM_CHAR_VALUE(obj2));
#endif
#if SCM_USE_STRING
case ScmString:
return MAKE_BOOL(STRING_EQUALP(obj1, obj2));
#endif
case ScmCons:
for (; CONSP(obj1) && CONSP(obj2); obj1 = CDR(obj1), obj2 = CDR(obj2))
{
elm1 = CAR(obj1);
elm2 = CAR(obj2);
if (!EQ(elm1, elm2)
&& (SCM_TYPE(elm1) != SCM_TYPE(elm2)
|| !EQUALP(elm1, elm2)))
return SCM_FALSE;
}
/* compare last cdr */
return (EQ(obj1, obj2)) ? SCM_TRUE : scm_p_equalp(obj1, obj2);
#if SCM_USE_VECTOR
case ScmVector:
len = SCM_VECTOR_LEN(obj1);
if (len != SCM_VECTOR_LEN(obj2))
return SCM_FALSE;
v1 = SCM_VECTOR_VEC(obj1);
v2 = SCM_VECTOR_VEC(obj2);
for (i = 0; i < len; i++) {
elm1 = v1[i];
elm2 = v2[i];
if (!EQ(elm1, elm2)
&& (SCM_TYPE(elm1) != SCM_TYPE(elm2)
|| !EQUALP(elm1, elm2)))
return SCM_FALSE;
}
return SCM_TRUE;
#endif
#if SCM_USE_SSCM_EXTENSIONS
case ScmCPointer:
return MAKE_BOOL(SCM_C_POINTER_VALUE(obj1)
== SCM_C_POINTER_VALUE(obj2));
case ScmCFuncPointer:
return MAKE_BOOL(SCM_C_FUNCPOINTER_VALUE(obj1)
== SCM_C_FUNCPOINTER_VALUE(obj2));
#endif
default:
break;
}
return SCM_FALSE;
}
