/* Force a lazy pair.
NB: When an error occurs during forcing, we release the lock of the
pair, so that the pair can be forced again. However, the generator
has already caused some side-effect before the error, so the next
forcing may not yield a correct next value. Another plausible option
is to mark the pair 'unforcible' permanently, by lp->owner == (AO_t)2,
and let subsequent attempt of forcing the pair fail.
*/
ScmObj Scm_ForceLazyPair(volatile ScmLazyPair *lp)
{
static const struct timespec req = {0, 1000000};
struct timespec rem;
ScmVM *vm = Scm_VM();
do {
if (AO_compare_and_swap_full(&lp->owner, 0, SCM_WORD(vm))) {
/* Here we own the lazy pair. */
ScmObj item = lp->item;
/* Calling generator might change VM state, so we protect
incomplete stack frame if there's any. */
int extra_frame_pushed = Scm__VMProtectStack(vm);
SCM_UNWIND_PROTECT {
ScmObj val = Scm_ApplyRec0(lp->generator);
ScmObj newgen = (vm->numVals == 1)? lp->generator : vm->vals[0];
vm->numVals = 1; /* make sure the extra val won't leak out */
if (SCM_EOFP(val)) {
lp->item = SCM_NIL;
lp->generator = SCM_NIL;
} else {
ScmObj newlp = Scm_MakeLazyPair(val, newgen);
lp->item = newlp;
lp->generator = SCM_NIL;
}
AO_nop_full();
SCM_SET_CAR(lp, item);
/* We don't need barrier here. */
lp->owner = (AO_t)1;
} SCM_WHEN_ERROR {
lp->owner = (AO_t)0; /*NB: See above about error handling*/
SCM_NEXT_HANDLER;
} SCM_END_PROTECT;
if (extra_frame_pushed) {
Scm__VMUnprotectStack(vm);
}
return SCM_OBJ(lp); /* lp is now an (extended) pair */
}
/* Check if we're already working on forcing this pair. Unlike
force/delay, We don't allow recursive forcing of lazy pair.
Since generators are supposed to be called every time to yield
a new value, so it is ambiguous what value should be returned
if a generator calls itself recursively. */
if (lp->owner == SCM_WORD(vm)) {
/* NB: lp->owner will be reset by the original caller of
the generator. */
Scm_Error("Attempt to recursively force a lazy pair.");
}
/* Somebody's already working on forcing. Let's wait for it
to finish, or to abort. */
while (SCM_HTAG(lp) == 7 && lp->owner != 0) {
nanosleep(&req, &rem);
}
} while (lp->owner == 0); /* we retry if the previous owner abandoned. */
/* 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;
}
/* 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;
}
/* General hash function */
u_long Scm_Hash(ScmObj obj)
{
u_long hashval;
if (!SCM_PTRP(obj)) {
SMALL_INT_HASH(hashval, (u_long)SCM_WORD(obj));
return hashval;
} else if (SCM_NUMBERP(obj)) {
return Scm_EqvHash(obj);
} else if (SCM_STRINGP(obj)) {
goto string_hash;
} else if (SCM_PAIRP(obj)) {
u_long h = 0, h2;
ScmObj cp;
SCM_FOR_EACH(cp, obj) {
h2 = Scm_Hash(SCM_CAR(cp));
h = COMBINE(h, h2);
}
h2 = Scm_Hash(cp);
h = COMBINE(h, h2);
return h;
} else if (SCM_VECTORP(obj)) {
/* 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
}
