/*
* External entry to manage registering callbacks
* 'xtra1' and 'xtra2' are ignored by most callbacks; only the two callbacks
* use them:
* glutTimerFunc: xtra1 for millliseconds, xtra2 for value
* glutJoystickFunc: xtra1 for interval
*/
void Scm_GlutRegisterCallback(int type, ScmObj closure, int xtra1, int xtra2)
{
SCM_ASSERT(type >= 0 && type < SCM_GLUT_NUM_CBS);
if (type < SCM_GLUT_NUM_WINDOW_CBS) {
int win = glutGetWindow();
ScmObj entry = Scm_HashTableRef(SCM_HASH_TABLE(ScmGlutCallbackTable),
SCM_MAKE_INT(win), SCM_FALSE);
if (SCM_EQ(entry, SCM_FALSE)) {
entry = Scm_MakeVector(SCM_GLUT_NUM_WINDOW_CBS, SCM_FALSE);
Scm_HashTableSet(SCM_HASH_TABLE(ScmGlutCallbackTable),
SCM_MAKE_INT(win), entry, 0);
}
SCM_VECTOR_ELEMENT(entry, type) = closure;
registrars[type](!SCM_FALSEP(closure), xtra1);
} else if (type == SCM_GLUT_CB_IDLE) {
idle_closure = closure;
if (SCM_FALSEP(closure)) {
glutIdleFunc(NULL);
} else {
glutIdleFunc(idle_cb);
}
} else {
timer_closure = closure;
if (!SCM_FALSEP(closure)) {
glutTimerFunc(xtra1, timer_cb, xtra2);
}
}
}
/* 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;
}
ScmObj Scm_Openpty(ScmObj slaveterm)
{
int master, slave;
struct termios *term = NULL;
if (SCM_SYS_TERMIOS_P(slaveterm)) {
term = &SCM_SYS_TERMIOS(slaveterm)->term;
}
if (openpty(&master, &slave, NULL, term, NULL) < 0) {
Scm_SysError("openpty failed");
}
return Scm_Values2(SCM_MAKE_INT(master), SCM_MAKE_INT(slave));
}
/* 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;
}
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 */
}
/*------------------------------------------------------------
* Vport Gets
*/
static int vport_getz(char *buf, int buflen, ScmPort *p)
{
vport *data = (vport*)p->src.vt.data;
SCM_ASSERT(data != NULL);
if (!SCM_FALSEP(data->gets_proc)) {
u_int size;
const char *start;
ScmObj s = Scm_ApplyRec(data->gets_proc,
SCM_LIST1(SCM_MAKE_INT(buflen)));
if (!SCM_STRINGP(s)) return EOF;
start = Scm_GetStringContent(SCM_STRING(s), &size, NULL, NULL);
if ((int)size > buflen) {
/* NB: should raise an exception? */
memcpy(buf, start, buflen);
return buflen;
} else {
memcpy(buf, start, size);
return size;
}
} else {
int byte, i;
for (i=0; i<buflen; i++) {
byte = vport_getb(p);
if (byte == EOF) break;
buf[i] = byte;
}
if (i==0) return EOF;
else return i;
}
}
ScmObj Scm_GetBinaryU8(ScmUVector *uv, int off, ScmSymbol *endian)
{
unsigned char b;
CHECK_ENDIAN(endian);
extract(uv, (char *)&b, off, 1);
return SCM_MAKE_INT(b);
}
ScmObj Scm_ReadBinaryU8(ScmPort *iport, ScmSymbol *endian)
{
int b;
ENSURE_IPORT(iport);
CHECK_ENDIAN(endian);
if ((b = Scm_Getb(iport)) == EOF) return SCM_EOF;
else return SCM_MAKE_INT(b);
}
ScmObj Scm_ReadBinaryS16(ScmPort *iport, ScmSymbol *endian)
{
swap_s16_t v;
CHECK_ENDIAN(endian);
if (getbytes(v.buf, 2, iport) == EOF) return SCM_EOF;
SWAP_16(endian, v);
return SCM_MAKE_INT(v.val);
}
ScmObj Scm_GetBinaryS16(ScmUVector *uv, int off, ScmSymbol *endian)
{
swap_s16_t v;
CHECK_ENDIAN(endian);
extract(uv, v.buf, off, 2);
SWAP_16(endian, v);
return SCM_MAKE_INT(v.val);
}
ScmObj Scm_GetBinaryS8(ScmUVector *uv, int off, ScmSymbol *endian)
{
unsigned char b; int r;
CHECK_ENDIAN(endian);
extract(uv, (char *)&b, off, 1);
r = b;
if (r >= 128) r -= 256;
return SCM_MAKE_INT(r);
}
ScmObj Scm_SocketSend(ScmSocket *sock, ScmObj msg, int flags)
{
int r;
u_int size;
CLOSE_CHECK(sock->fd, "send to", sock);
const char *cmsg = get_message_body(msg, &size);
SCM_SYSCALL(r, send(sock->fd, cmsg, size, flags));
if (r < 0) Scm_SysError("send(2) failed");
return SCM_MAKE_INT(r);
}
ScmObj Scm_SocketSendTo(ScmSocket *sock, ScmObj msg, ScmSockAddr *to,
int flags)
{
int r;
u_int size;
CLOSE_CHECK(sock->fd, "send to", sock);
const char *cmsg = get_message_body(msg, &size);
SCM_SYSCALL(r, sendto(sock->fd, cmsg, size, flags,
&SCM_SOCKADDR(to)->addr, SCM_SOCKADDR(to)->addrlen));
if (r < 0) Scm_SysError("sendto(2) failed");
return SCM_MAKE_INT(r);
}
static ScmObj get_callback(int type)
{
int win = glutGetWindow();
ScmObj entry = Scm_HashTableRef(SCM_HASH_TABLE(ScmGlutCallbackTable),
SCM_MAKE_INT(win), SCM_FALSE);
SCM_ASSERT(type >= 0 && type < SCM_GLUT_NUM_WINDOW_CBS);
if (SCM_VECTORP(entry)) {
return SCM_VECTOR_ELEMENT(entry, type);
} else {
return SCM_FALSE;
}
}
/* returns a list of ranges contained in the charset */
ScmObj Scm_CharSetRanges(ScmCharSet *cs)
{
ScmObj h = SCM_NIL, t = SCM_NIL;
int ind, begin = 0, prev = FALSE;
for (ind = 0; ind < SCM_CHAR_SET_SMALL_CHARS; ind++) {
int bit = MASK_ISSET(cs, ind);
if (!prev && bit) begin = ind;
if (prev && !bit) {
ScmObj cell = Scm_Cons(SCM_MAKE_INT(begin), SCM_MAKE_INT(ind-1));
SCM_APPEND1(h, t, cell);
}
prev = bit;
}
if (prev) {
ScmObj cell = Scm_Cons(SCM_MAKE_INT(begin), SCM_MAKE_INT(ind-1));
SCM_APPEND1(h, t, cell);
}
ScmTreeIter iter;
ScmDictEntry *e;
Scm_TreeIterInit(&iter, &cs->large, NULL);
while ((e = Scm_TreeIterNext(&iter)) != NULL) {
ScmObj cell = Scm_Cons(SCM_MAKE_INT(e->key), SCM_MAKE_INT(e->value));
SCM_APPEND1(h, t, cell);
}
return h;
}
ScmObj Scm_Forkpty(ScmObj slaveterm)
{
int master;
pid_t pid;
struct termios *term = NULL;
if (SCM_SYS_TERMIOS_P(slaveterm)) {
term = &SCM_SYS_TERMIOS(slaveterm)->term;
}
if ((pid = forkpty(&master, NULL, term, NULL)) < 0) {
Scm_SysError("forkpty failed");
}
return Scm_Values2(Scm_MakeInteger(pid), SCM_MAKE_INT(master));
}
/* Modifies B and return it. */
ScmObj Scm_NormalizeBignum(ScmBignum *b)
{
int size = b->size;
int i;
for (i=size-1; i>0; i--) {
if (b->values[i] == 0) size--;
else break;
}
if (i==0) {
if (b->sign == 0) {
return SCM_MAKE_INT(0);
}
if (b->sign > 0 && b->values[0] <= (u_long)SCM_SMALL_INT_MAX) {
return SCM_MAKE_INT(b->values[0]);
}
if (b->sign < 0 && b->values[0] <= (u_long)-SCM_SMALL_INT_MIN) {
return SCM_MAKE_INT(-((signed long)b->values[0]));
}
}
b->size = size;
return SCM_OBJ(b);
}
ScmObj Scm_SocketSendMsg(ScmSocket *sock, ScmObj msg, int flags)
{
#if !GAUCHE_WINDOWS
int r;
u_int size;
CLOSE_CHECK(sock->fd, "send to", sock);
const char *cmsg = get_message_body(msg, &size);
SCM_SYSCALL(r, sendmsg(sock->fd, (struct msghdr*)cmsg, flags));
if (r < 0) Scm_SysError("sendmsg(2) failed");
return SCM_MAKE_INT(r);
#else /*GAUCHE_WINDOWS*/
Scm_Error("sendmsg is not implemented on this platform.");
return SCM_UNDEFINED; /* dummy */
#endif /*GAUCHE_WINDOWS*/
}
ScmObj Scm_TLSWrite(ScmTLS* t, ScmObj msg)
{
#if defined(GAUCHE_USE_AXTLS)
context_check(t, "write");
close_check(t, "write");
int r;
u_int size;
const uint8_t* cmsg = get_message_body(msg, &size);
if ((r = ssl_write(t->conn, cmsg, size)) < 0) {
Scm_SysError("ssl_write() failed");
}
return SCM_MAKE_INT(r);
#else /*!GAUCHE_USE_AXTLS*/
return SCM_FALSE;
#endif /*!GAUCHE_USE_AXTLS*/
}
/* 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_UngottenBytesUnsafe(ScmPort *p)
#endif
{
VMDECL;
SHORTCUT(p, return Scm_UngottenBytesUnsafe(p));
char buf[SCM_CHAR_MAX_BYTES];
LOCK(p);
for (int i=0; i<p->scrcnt; i++) buf[i] = p->scratch[i];
int n = p->scrcnt;
UNLOCK(p);
ScmObj h = SCM_NIL, t = SCM_NIL;
for (int i=0; i<n; i++) {
SCM_APPEND1(h, t, SCM_MAKE_INT((unsigned char)buf[i]));
}
return h;
}
static ScmObj bport_allocate(ScmClass *klass, ScmObj initargs)
{
bport *data = SCM_NEW(bport);
int bufsize = Scm_GetInteger(Scm_GetKeyword(key_bufsize, initargs,
SCM_MAKE_INT(0)));
data->fill_proc = SCM_FALSE;
data->flush_proc = SCM_FALSE;
data->close_proc = SCM_FALSE;
data->ready_proc = SCM_FALSE;
data->filenum_proc = SCM_FALSE;
data->seek_proc = SCM_FALSE;
ScmPortBuffer buf;
if (bufsize > 0) {
buf.buffer = SCM_NEW_ATOMIC2(char*, bufsize);
buf.size = bufsize;
} else {
/*------------------------------------------------------------
* Vport putz
*/
static void vport_putz(const char *buf, int size, ScmPort *p)
{
vport *data = (vport*)p->src.vt.data;
SCM_ASSERT(data != NULL);
if (!SCM_FALSEP(data->puts_proc)) {
Scm_ApplyRec(data->puts_proc,
SCM_LIST1(Scm_MakeString(buf, size, -1,
SCM_STRING_COPYING)));
} else if (!SCM_FALSEP(data->putb_proc)) {
for (int i=0; i<size; i++) {
unsigned char b = buf[i];
Scm_ApplyRec(data->putb_proc, SCM_LIST1(SCM_MAKE_INT(b)));
}
} else {
Scm_PortError(p, SCM_PORT_ERROR_UNIT,
"cannot perform binary output to the port %S", p);
}
}
/*------------------------------------------------------------
* Vport putb
*/
static void vport_putb(ScmByte b, ScmPort *p)
{
vport *data = (vport*)p->src.vt.data;
SCM_ASSERT(data != NULL);
if (SCM_FALSEP(data->putb_proc)) {
if (!SCM_FALSEP(data->putc_proc)
&& SCM_CHAR_NFOLLOWS(b) == 0) {
/* This byte is a single-byte character, so we can use putc. */
Scm_ApplyRec(data->putc_proc, SCM_LIST1(SCM_MAKE_CHAR(b)));
} else {
/* Given byte is a part of multibyte sequence. We don't
handle it for the time being. */
Scm_PortError(p, SCM_PORT_ERROR_UNIT,
"cannot perform binary output to the port %S", p);
}
} else {
Scm_ApplyRec(data->putb_proc, SCM_LIST1(SCM_MAKE_INT(b)));
}
}
/*------------------------------------------------------------
* Vport putc
*/
static void vport_putc(ScmChar c, ScmPort *p)
{
vport *data = (vport*)p->src.vt.data;
SCM_ASSERT(data != NULL);
if (SCM_FALSEP(data->putc_proc)) {
if (SCM_FALSEP(data->putb_proc)) {
Scm_PortError(p, SCM_PORT_ERROR_OTHER,
"cannot perform output to the port %S", p);
} else {
unsigned char buf[SCM_CHAR_MAX_BYTES];
int i, n=SCM_CHAR_NBYTES(c);
SCM_CHAR_PUT(buf, c);
for (i=0; i<n; i++) {
Scm_ApplyRec(data->putb_proc, SCM_LIST1(SCM_MAKE_INT(buf[i])));
}
}
} else {
Scm_ApplyRec(data->putc_proc, SCM_LIST1(SCM_MAKE_CHAR(c)));
}
}
ScmObj Scm_ForkptyAndExec(ScmString *file, ScmObj args, ScmObj iomap,
ScmObj slaveterm, ScmSysSigset *mask)
{
int argc = Scm_Length(args);
char **argv;
const char *program;
int *fds;
int master;
pid_t pid;
struct termios *term = NULL;
if (argc < 1) {
Scm_Error("argument list must have at least one element: %S", args);
}
argv = Scm_ListToCStringArray(args, TRUE, NULL);
program = Scm_GetStringConst(file);
if (SCM_SYS_TERMIOS_P(slaveterm)) {
term = &SCM_SYS_TERMIOS(slaveterm)->term;
}
fds = Scm_SysPrepareFdMap(iomap);
if ((pid = forkpty(&master, NULL, term, NULL)) < 0) {
Scm_SysError("forkpty failed");
}
if (pid == 0) {
Scm_SysSwapFds(fds);
if (mask) {
Scm_ResetSignalHandlers(&mask->set);
Scm_SysSigmask(SIG_SETMASK, mask);
}
execvp(program, (char *const*)argv);
/* here, we failed */
Scm_Panic("exec failed: %s: %s", program, strerror(errno));
}
return Scm_Values2(Scm_MakeInteger(pid), SCM_MAKE_INT(master));
}
static ScmObj syserror_number_get(ScmSystemError *obj)
{
return SCM_MAKE_INT(obj->error_number);
}
/* 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
}
static ScmObj sigerror_signal_get(ScmUnhandledSignalError *obj)
{
return SCM_MAKE_INT(obj->signal);
}
static ScmObj readerror_line_get(ScmReadError *obj)
{
return SCM_MAKE_INT(obj->line);
}