示例#1
0
/*
 * 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);
        }
    }
}
示例#2
0
文件: write.c 项目: h2oota/Gauche
/* 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;
}
示例#3
0
文件: termios.c 项目: aharisu/Gauche
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));
}
示例#4
0
文件: write.c 项目: icicle99/Gauche
/* 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;
}
示例#5
0
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 */
}
示例#6
0
文件: vport.c 项目: aharisu/Gauche
/*------------------------------------------------------------
 * 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;
    }
}
示例#7
0
文件: binary.c 项目: aharisu/Gauche
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);
}
示例#8
0
文件: binary.c 项目: aharisu/Gauche
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);
}
示例#9
0
文件: binary.c 项目: aharisu/Gauche
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);
}
示例#10
0
文件: binary.c 项目: aharisu/Gauche
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);
}
示例#11
0
文件: binary.c 项目: aharisu/Gauche
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);
}
示例#12
0
文件: net.c 项目: qyqx/Gauche
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);
}
示例#13
0
文件: net.c 项目: qyqx/Gauche
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);
}
示例#14
0
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;
    }
}
示例#15
0
文件: char.c 项目: abbrous/Gauche
/* 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;
}
示例#16
0
文件: termios.c 项目: aharisu/Gauche
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));
}
示例#17
0
文件: bignum.c 项目: aharisu/Gauche
/* 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);
}
示例#18
0
文件: net.c 项目: qyqx/Gauche
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*/
}
示例#19
0
文件: tls.c 项目: Z-Shang/Gauche
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*/
}
示例#20
0
文件: prof.c 项目: jmuk/Gauche
/* 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));
        }
    }
}
示例#21
0
文件: portapi.c 项目: abbrous/Gauche
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;
}
示例#22
0
文件: vport.c 项目: syunta/Gauche
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 {
示例#23
0
文件: vport.c 项目: syunta/Gauche
/*------------------------------------------------------------
 * 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);
   }
}
示例#24
0
文件: vport.c 项目: aharisu/Gauche
/*------------------------------------------------------------
 * 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)));
    }
}
示例#25
0
文件: vport.c 项目: aharisu/Gauche
/*------------------------------------------------------------
 * 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)));
    }
}
示例#26
0
文件: termios.c 项目: aharisu/Gauche
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));
}
示例#27
0
文件: error.c 项目: Z-Shang/Gauche
static ScmObj syserror_number_get(ScmSystemError *obj)
{
    return SCM_MAKE_INT(obj->error_number);
}
示例#28
0
文件: write.c 项目: h2oota/Gauche
/* 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
}
示例#29
0
文件: error.c 项目: Z-Shang/Gauche
static ScmObj sigerror_signal_get(ScmUnhandledSignalError *obj)
{
    return SCM_MAKE_INT(obj->signal);
}
示例#30
0
文件: error.c 项目: Z-Shang/Gauche
static ScmObj readerror_line_get(ScmReadError *obj)
{
    return SCM_MAKE_INT(obj->line);
}