static void message_prefix_set(ScmMessageCondition *obj, ScmObj val)
{
ScmObj msglist = obj->message;
if (SCM_PAIRP(msglist) && SCM_PAIRP(SCM_CDR(msglist))) {
SCM_SET_CAR(SCM_CDR(msglist), val);
} else {
obj->message = SCM_LIST2(msglist, val);
}
}
static ScmObj message_prefix_get(ScmMessageCondition *obj)
{
ScmObj msglist = obj->message;
if (SCM_PAIRP(msglist) && SCM_PAIRP(SCM_CDR(msglist))) {
return SCM_CADR(msglist);
} else {
return msglist;
}
}
static ScmObj message_args_get(ScmMessageCondition *obj)
{
ScmObj msglist = obj->message;
if (SCM_PAIRP(msglist) && SCM_PAIRP(SCM_CDR(msglist))) {
return SCM_CDDR(msglist);
} else {
return SCM_NIL;
}
}
static void message_args_set(ScmMessageCondition *obj, ScmObj val)
{
ScmObj msglist = obj->message;
if (SCM_PAIRP(msglist) && SCM_PAIRP(SCM_CDR(msglist))) {
SCM_SET_CDR(SCM_CDR(msglist), val);
} else {
obj->message = Scm_Cons(msglist, Scm_Cons(msglist, val));
}
}
ScmObj Scm_CopyList(ScmObj list)
{
if (!SCM_PAIRP(list)) return list;
ScmObj start = SCM_NIL, last = SCM_NIL;
SCM_FOR_EACH(list, list) {
SCM_APPEND1(start, last, SCM_CAR(list));
}
int Scm_Length(ScmObj obj)
{
ScmObj slow = obj;
int len = 0;
for (;;) {
if (SCM_NULLP(obj)) break;
if (!SCM_PAIRP(obj)) return SCM_LIST_DOTTED;
obj = SCM_CDR(obj);
len++;
if (SCM_NULLP(obj)) break;
if (!SCM_PAIRP(obj)) return SCM_LIST_DOTTED;
obj = SCM_CDR(obj);
slow = SCM_CDR(slow);
if (obj == slow) return SCM_LIST_CIRCULAR;
len++;
}
return len;
}
ScmObj Scm_GetKeyword(ScmObj key, ScmObj list, ScmObj fallback)
{
ScmObj cp;
SCM_FOR_EACH(cp, list) {
if (!SCM_PAIRP(SCM_CDR(cp))) {
Scm_Error("incomplete key list: %S", list);
}
if (key == SCM_CAR(cp)) return SCM_CADR(cp);
cp = SCM_CDR(cp);
}
if (SCM_UNBOUNDP(fallback)) {
Scm_Error("value for key %S is not provided: %S", key, list);
}
return fallback;
}
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));
}
}
}
ScmObj Scm_DeleteKeyword(ScmObj key, ScmObj list)
{
ScmObj cp;
SCM_FOR_EACH(cp, list) {
if (!SCM_PAIRP(SCM_CDR(cp))) {
Scm_Error("incomplete key list: %S", list);
}
if (key == SCM_CAR(cp)) {
/* found */
ScmObj h = SCM_NIL, t = SCM_NIL;
ScmObj tail = Scm_DeleteKeyword(key, SCM_CDR(SCM_CDR(cp)));
ScmObj cp2;
SCM_FOR_EACH(cp2, list) {
if (cp2 == cp) {
SCM_APPEND(h, t, tail);
return h;
} else {
SCM_APPEND1(h, t, SCM_CAR(cp2));
}
}
}
cp = SCM_CDR(cp);
}
/* 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));
}
static void message_set(ScmMessageCondition *obj, ScmObj val)
{
ScmObj msglist = obj->message;
if (SCM_PAIRP(msglist)) SCM_SET_CAR(msglist, val);
else SCM_MESSAGE_CONDITION(obj)->message = SCM_LIST2(val, val);
}
/* 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
}
int Scm_Compare(ScmObj x, ScmObj y)
{
/* Shortcut for typical case */
if (SCM_NUMBERP(x) && SCM_NUMBERP(y)) {
if (SCM_COMPNUMP(x) || SCM_COMPNUMP(y)) {
/* Scm_NumCmp can't compare complex numbers---it doesn't make
mathematical sense. But Scm_Compare is used just to order
items, it doesn't need to carry meaning. So here it goes.
We follow srfi-114 spec. */
/* TODO: If we ever introduce exact compnums, we should use
exact number first to compare, for Scm_GetDouble may lose
precision. */
/* TODO: Handle NaN. */
double xr = Scm_RealPart(x);
double yr = Scm_RealPart(y);
if (xr < yr) return -1;
if (xr > yr) return 1;
double xi = Scm_ImagPart(x);
double yi = Scm_ImagPart(y);
if (xi < yi) return -1;
if (xi > yi) return 1;
return 0;
} else {
return Scm_NumCmp(x, y);
}
}
if (SCM_STRINGP(x) && SCM_STRINGP(y))
return Scm_StringCmp(SCM_STRING(x), SCM_STRING(y));
if (SCM_CHARP(x) && SCM_CHARP(y))
return SCM_CHAR_VALUE(x) == SCM_CHAR_VALUE(y)? 0 :
SCM_CHAR_VALUE(x) < SCM_CHAR_VALUE(y)? -1 : 1;
/* Set cx, cy here, for we may jump to distinct_types later. */
ScmClass *cx = Scm_ClassOf(x);
ScmClass *cy = Scm_ClassOf(y);
/* srfi-114 default comparator behaviors*/
/* () is the smallest of all */
if (SCM_NULLP(x)) return (SCM_NULLP(y)? 0 : -1);
if (SCM_NULLP(y)) return (SCM_NULLP(x)? 0 : 1);
if (SCM_PAIRP(x)) {
if (SCM_PAIRP(y)) {
ScmObj px = x;
ScmObj py = y;
while (SCM_PAIRP(px) && SCM_PAIRP(py)) {
int r = Scm_Compare(SCM_CAR(px), SCM_CAR(py));
if (r != 0) return r;
px = SCM_CDR(px);
py = SCM_CDR(py);
}
return Scm_Compare(px, py);
}
goto distinct_types;
}
if (SCM_FALSEP(x)) {
if (SCM_FALSEP(y)) return 0;
if (SCM_TRUEP(y)) return -1;
goto distinct_types;
}
if (SCM_TRUEP(x)) {
if (SCM_FALSEP(y)) return 1;
if (SCM_TRUEP(y)) return 0;
goto distinct_types;
}
if (Scm_SubtypeP(cx, cy)) {
if (cy->compare) return cy->compare(x, y, FALSE);
} else if (Scm_SubtypeP(cy, cx)) {
if (cx->compare) return cx->compare(x, y, FALSE);
}
if (cx == cy) {
/* x and y are of the same type, and they can't be ordered. */
Scm_Error("can't compare %S and %S", x, y);
}
distinct_types:
/* x and y are of distinct types. Follow the srfi-114 rule:
() < pairs < booleans < chars < strings < symbols < numbers
< vectors < bytevectors < others
Note that we already eliminated NULL.
*/
#define ELIMINATE(pred) \
do { \
if pred(x) return -1; \
if pred(y) return 1; \
} while (0)
ELIMINATE(SCM_PAIRP);
ELIMINATE(SCM_BOOLP);
ELIMINATE(SCM_CHARP);
ELIMINATE(SCM_STRINGP);
ELIMINATE(SCM_SYMBOLP);
ELIMINATE(SCM_NUMBERP);
ELIMINATE(SCM_VECTORP);
/* To conform srfi-114, we must order u8vector first. For the
consistency, we use this order:
u8 < s8 < u16 < s16 < u32 < s32 < u64 < s64 < f16 < f32 < f64
Unfortunately this doesn't match the order of ScmUVectorType,
so we need some tweak.
*/
if (SCM_UVECTORP(x)) {
if (SCM_UVECTORP(y)) {
int tx = Scm_UVectorType(Scm_ClassOf(x));
int ty = Scm_UVectorType(Scm_ClassOf(y));
if (tx/2 < ty/2) return -1;
if (tx/2 > ty/2) return 1;
if (tx < SCM_UVECTOR_F16) {
/* x and y are either sNvector and uNvector with the same N.
The odd one is uNvector.
*/
return (tx%2)? -1:1;
} else {
return (tx<ty)? -1:1;
}
}
return -1; /* y is other, so x comes first. */
} else if (SCM_UVECTORP(y)) {
return 1; /* x is other, so y comes first. */
}
/* Now we have two objects of different types, both are not the
types defined the order in srfi-114.
To achieve better stability, we first compare the name of the
classes and the names of their defining modules; if they are still
the same, we fall back to compare addresses.
Note: Addresses and defining modules may be changed when
the class is redefined.
*/
ScmObj nx = cx->name;
ScmObj ny = cy->name;
int nr = Scm_Compare(nx, ny);
if (nr != 0) return nr;
ScmObj mx = cx->modules;
ScmObj my = cy->modules;
while (SCM_PAIRP(mx) && SCM_PAIRP(my)) {
SCM_ASSERT(SCM_MODULEP(SCM_CAR(mx)) && SCM_MODULEP(SCM_CAR(my)));
int r = Scm_Compare(SCM_MODULE(SCM_CAR(mx))->name,
SCM_MODULE(SCM_CAR(my))->name);
if (r != 0) return r;
mx = SCM_CDR(mx);
my = SCM_CDR(my);
}
if (SCM_PAIRP(mx)) return -1;
if (SCM_PAIRP(my)) return 1;
if (cx < cy) return -1;
else return 1;
}
int Scm_EqualP(ScmObj x, ScmObj y)
{
ScmClass *cx, *cy;
if (SCM_EQ(x, y)) return TRUE;
if (SCM_PAIRP(x)) {
if (!SCM_PAIRP(y)) return FALSE;
do {
if (!Scm_EqualP(SCM_CAR(x), SCM_CAR(y))) return FALSE;
x = SCM_CDR(x);
y = SCM_CDR(y);
} while (SCM_PAIRP(x)&&SCM_PAIRP(y));
return Scm_EqualP(x, y);
}
if (SCM_STRINGP(x)) {
if (SCM_STRINGP(y)) {
return Scm_StringEqual(SCM_STRING(x), SCM_STRING(y));
}
return FALSE;
}
if (SCM_NUMBERP(x)) {
if (SCM_NUMBERP(y)) {
if ((SCM_EXACTP(x) && SCM_EXACTP(y))
|| (SCM_INEXACTP(x) && SCM_INEXACTP(y))) {
return Scm_NumEq(x, y);
}
}
return FALSE;
}
if (SCM_VECTORP(x)) {
if (SCM_VECTORP(y)) {
int sizx = SCM_VECTOR_SIZE(x);
int sizy = SCM_VECTOR_SIZE(y);
if (sizx == sizy) {
while (sizx--) {
if (!Scm_EqualP(SCM_VECTOR_ELEMENT(x, sizx),
SCM_VECTOR_ELEMENT(y, sizx)))
break;
}
if (sizx < 0) return TRUE;
}
}
return FALSE;
}
/* EXPERIMENTAL: when identifier is compared by equal?,
we use its symbolic name to compare. This allows
comparing macro output with equal?, and also less confusing
when R5RS macro and legacy macro are mixed.
For "proper" comparison of identifiers keeping their semantics,
we need such procedures as free-identifier=? and bound-identifier=?
anyway, so this change of equal? won't have a negative impact, I hope.
NB: this operation come here instead of the beginning of this
procedure, since comparing identifiers are relatively rare so
we don't want to check idnetifier-ness every time.
*/
if (SCM_IDENTIFIERP(x) || SCM_IDENTIFIERP(y)) {
if (SCM_IDENTIFIERP(x)) x = SCM_OBJ(SCM_IDENTIFIER(x)->name);
if (SCM_IDENTIFIERP(y)) y = SCM_OBJ(SCM_IDENTIFIER(y)->name);
return SCM_EQ(x, y);
}
/* End of EXPERIMENTAL code */
if (!SCM_HPTRP(x)) return (x == y);
cx = Scm_ClassOf(x);
cy = Scm_ClassOf(y);
if (cx == cy && cx->compare) {
return (cx->compare(x, y, TRUE) == 0);
}
return FALSE;
}
/* 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
}
/* See comment on gauche/exception.h about hack in 'message' slot.
TODO: Remove this hack on 1.0 release. */
static ScmObj message_get(ScmMessageCondition *obj)
{
ScmObj msglist = obj->message;
if (SCM_PAIRP(msglist)) return SCM_CAR(msglist);
else return msglist;
}
