read.c

enum {
    TOK_NONE, TOK_OPEN, TOK_CLOSE, TOK_DOT, TOK_QUOTE, TOK_SYM, TOK_NUM,
    TOK_BQ, TOK_COMMA, TOK_COMMAAT, TOK_COMMADOT,
    TOK_SHARPDOT, TOK_LABEL, TOK_BACKREF, TOK_SHARPQUOTE, TOK_SHARPOPEN,
    TOK_OPENB, TOK_CLOSEB, TOK_SHARPSYM, TOK_GENSYM, TOK_DOUBLEQUOTE
};

#define readF(fl_ctx) value2c(ios_t*,fl_ctx->readstate->source)

// defines which characters are ordinary symbol characters.
// exceptions are '.', which is an ordinary symbol character
// unless it's the only character in the symbol, and '#', which is
// an ordinary symbol character unless it's the first character.
static inline int symchar(char c)
{
    static const char *special = "()[]'\";`,\\| \f\n\r\t\v";
    return !strchr(special, c);
}

// like strtoull, but accepts "0b" prefix for base 2 and "0o" prefix for base 8
static unsigned long long strtoull_0b0o(const char *nptr, char **endptr, int base)
{
    if (*nptr == '0') {
        if ((base == 2 && nptr[1] == 'b' && nptr[2] >= '0' && nptr[2] <= '1') ||
            (base == 8 && nptr[1] == 'o' && nptr[2] >= '0' && nptr[2] <= '7')) {
            nptr += 2;
        }
    }
    return strtoull(nptr, endptr, base);
}

int isnumtok_base(fl_context_t *fl_ctx, char *tok, value_t *pval, int base)
{
    char *end;
    int64_t i64;
    uint64_t ui64;
    double d;
    if (*tok == '\0')
        return 0;
    if (!((tok[0]=='0' && tok[1]=='x') || (base >= 15)) &&
        strpbrk(tok, ".eEpP")) {
        d = jl_strtod_c(tok, &end);
        if (*end == '\0') {
            if (pval) *pval = mk_double(fl_ctx, d);
            return 1;
        }
        // floats can end in f or f0
        if (end > tok && end[0] == 'f' &&
            (end[1] == '\0' ||
             (end[1] == '0' && end[2] == '\0'))) {
            if (pval) *pval = mk_float(fl_ctx, (float)d);
            return 1;
        }
    }
    // hexadecimal float literals
    else if (((tok[0]=='0' && tok[1]=='x') || (base == 16)) &&
        strpbrk(tok, "pP")) {
        d = jl_strtod_c(tok, &end);
        if (*end == '\0') {
            if (pval) *pval = mk_double(fl_ctx, d);
            return 1;
        }
        // floats can end in f or f0
        if (end > tok && end[0] == 'f' &&
            (end[1] == '\0' ||
             (end[1] == '0' && end[2] == '\0'))) {
            if (pval) *pval = mk_float(fl_ctx, (float)d);
            return 1;
        }
    }

    if (tok[0] == '+') {
        if (!strcmp(tok,"+NaN") || !strcasecmp(tok,"+nan.0")) {
            if (pval) *pval = mk_double(fl_ctx, D_PNAN);
            return 1;
        }
        if (!strcmp(tok,"+Inf") || !strcasecmp(tok,"+inf.0")) {
            if (pval) *pval = mk_double(fl_ctx, D_PINF);
            return 1;
        }
    }
    else if (tok[0] == '-') {
        if (!strcmp(tok,"-NaN") || !strcasecmp(tok,"-nan.0")) {
            if (pval) *pval = mk_double(fl_ctx, D_NNAN);
            return 1;
        }
        if (!strcmp(tok,"-Inf") || !strcasecmp(tok,"-inf.0")) {
            if (pval) *pval = mk_double(fl_ctx, D_NINF);
            return 1;
        }
        errno = 0;
        i64 = strtoll(tok, &end, base);
        if (errno)
            return 0;
        int done = (*end == '\0');  // must access *end before alloc
        if (pval) *pval = return_from_int64(fl_ctx, i64);
        return done;
    }
    errno = 0;
    ui64 = strtoull_0b0o(tok, &end, base);
    if (errno)
        return 0;
    int done = (*end == '\0');  // must access *end before alloc
    if (pval) *pval = return_from_uint64(fl_ctx, ui64);
    return done;
}

static int isnumtok(fl_context_t *fl_ctx, char *tok, value_t *pval)
{
    return isnumtok_base(fl_ctx, tok, pval, 0);
}

static int read_numtok(fl_context_t *fl_ctx, char *tok, value_t *pval, int base)
{
    int result;
    errno = 0;
    result = isnumtok_base(fl_ctx, tok, pval, base);
    if (errno == ERANGE)
        lerrorf(fl_ctx, fl_ctx->ParseError, "read: overflow in numeric constant %s", tok);
    return result;
}

static char nextchar(fl_context_t *fl_ctx)
{
    int ch;
    char c;
    ios_t *f = readF(fl_ctx);

    do {
        if (f->bpos < f->size) {
            ch = f->buf[f->bpos++];
        }
        else {
            ch = ios_getc(f);
            if (ch == IOS_EOF)
                return 0;
        }
        c = (char)ch;
        if (c == ';') {
            // single-line comment
            do {
                ch = ios_getc(f);
                if (ch == IOS_EOF)
                    return 0;
            } while ((char)ch != '\n');
            c = (char)ch;
        }
    } while (c==' ' || isspace((unsigned char)c));
    return c;
}

static void take(fl_context_t *fl_ctx)
{
    fl_ctx->readtoktype = TOK_NONE;
}

static void accumchar(fl_context_t *fl_ctx, char c, int *pi)
{
    fl_ctx->readbuf[(*pi)++] = c;
    if (*pi >= (int)(sizeof(fl_ctx->readbuf)-1))
        lerror(fl_ctx, fl_ctx->ParseError, "read: token too long");
}

// return: 1 if escaped (forced to be symbol)
static int read_token(fl_context_t *fl_ctx, char c, int digits)
{
    int i=0, ch, escaped=0, issym=0, nc=0;

    while (1) {
        if (nc != 0) {
            if (nc != 1)
                (void)ios_getc(readF(fl_ctx)); // consume ch
            ch = ios_peekc(readF(fl_ctx));
            if (ch == IOS_EOF)
                goto terminate;
            c = (char)ch;
        }
        if (c == '|') {
            issym = 1;
            escaped = !escaped;
        }
        else if (c == '\\') {
            issym = 1;
            (void)ios_getc(readF(fl_ctx)); // consume '\'
            ch = ios_peekc(readF(fl_ctx));
            if (ch == IOS_EOF)
                goto terminate;
            accumchar(fl_ctx, (char)ch, &i);
        }
        else if (!escaped && !(symchar(c) && (!digits || isdigit(c)))) {
            break;
        }
        else {
            accumchar(fl_ctx, c, &i);
        }
        nc++;
    }
    if (nc == 0)
        ios_skip(readF(fl_ctx), -1); // rewind stream for the caller, to prepare for throwing an error
 terminate:
    fl_ctx->readbuf[i++] = '\0';
    return issym;
}

static value_t do_read_sexpr(fl_context_t *fl_ctx, value_t label);

static uint32_t peek(fl_context_t *fl_ctx)
{
    char c, *end;
    fixnum_t x;
    int ch, base;

    if (fl_ctx->readtoktype != TOK_NONE)
        return fl_ctx->readtoktype;
    c = nextchar(fl_ctx);
    if (ios_eof(readF(fl_ctx))) return TOK_NONE;
    if (c == '(') {
        fl_ctx->readtoktype = TOK_OPEN;
    }
    else if (c == ')') {
        fl_ctx->readtoktype = TOK_CLOSE;
    }
    else if (c == '[') {
        fl_ctx->readtoktype = TOK_OPENB;
    }
    else if (c == ']') {
        fl_ctx->readtoktype = TOK_CLOSEB;
    }
    else if (c == '\'') {
        fl_ctx->readtoktype = TOK_QUOTE;
    }
    else if (c == '`') {
        fl_ctx->readtoktype = TOK_BQ;
    }
    else if (c == '"') {
        fl_ctx->readtoktype = TOK_DOUBLEQUOTE;
    }
    else if (c == '#') {
        ch = ios_getc(readF(fl_ctx)); c = (char)ch;
        if (ch == IOS_EOF)
            lerror(fl_ctx, fl_ctx->ParseError, "read: invalid read macro");
        if (c == '.') {
            fl_ctx->readtoktype = TOK_SHARPDOT;
        }
        else if (c == '\'') {
            fl_ctx->readtoktype = TOK_SHARPQUOTE;
        }
        else if (c == '\\') {
            uint32_t cval;
            if (ios_getutf8(readF(fl_ctx), &cval) == IOS_EOF)
                lerror(fl_ctx, fl_ctx->ParseError, "read: end of input in character constant");
            if (cval == (uint32_t)'u' || cval == (uint32_t)'U' ||
                cval == (uint32_t)'x') {
                read_token(fl_ctx, 'u', 0);
                if (fl_ctx->readbuf[1] != '\0') {  // not a solitary 'u','U','x'
                    if (!read_numtok(fl_ctx, &fl_ctx->readbuf[1], &fl_ctx->readtokval, 16))
                        lerror(fl_ctx, fl_ctx->ParseError,
                               "read: invalid hex character constant");
                    cval = numval(fl_ctx->readtokval);
                }
            }
            else if (cval >= 'a' && cval <= 'z') {
                read_token(fl_ctx, (char)cval, 0);
                fl_ctx->readtokval = symbol(fl_ctx, fl_ctx->readbuf);
                if (fl_ctx->readbuf[1] == '\0')       /* one character */;
                else if (fl_ctx->readtokval == fl_ctx->nulsym)        cval = 0x00;
                else if (fl_ctx->readtokval == fl_ctx->alarmsym)      cval = 0x07;
                else if (fl_ctx->readtokval == fl_ctx->backspacesym)  cval = 0x08;
                else if (fl_ctx->readtokval == fl_ctx->tabsym)        cval = 0x09;
                else if (fl_ctx->readtokval == fl_ctx->linefeedsym)   cval = 0x0A;
                else if (fl_ctx->readtokval == fl_ctx->newlinesym)    cval = 0x0A;
                else if (fl_ctx->readtokval == fl_ctx->vtabsym)       cval = 0x0B;
                else if (fl_ctx->readtokval == fl_ctx->pagesym)       cval = 0x0C;
                else if (fl_ctx->readtokval == fl_ctx->returnsym)     cval = 0x0D;
                else if (fl_ctx->readtokval == fl_ctx->escsym)        cval = 0x1B;
                else if (fl_ctx->readtokval == fl_ctx->spacesym)      cval = 0x20;
                else if (fl_ctx->readtokval == fl_ctx->deletesym)     cval = 0x7F;
                else
                    lerrorf(fl_ctx, fl_ctx->ParseError, "read: unknown character #\\%s", fl_ctx->readbuf);
            }
            fl_ctx->readtoktype = TOK_NUM;
            fl_ctx->readtokval = mk_wchar(fl_ctx, cval);
        }
        else if (c == '(') {
            fl_ctx->readtoktype = TOK_SHARPOPEN;
        }
        else if (c == '<') {
            lerror(fl_ctx, fl_ctx->ParseError, "read: unreadable object");
        }
        else if (isdigit(c)) {
            read_token(fl_ctx, c, 1);
            c = (char)ios_getc(readF(fl_ctx));
            if (c == '#')
                fl_ctx->readtoktype = TOK_BACKREF;
            else if (c == '=')
                fl_ctx->readtoktype = TOK_LABEL;
            else
                lerror(fl_ctx, fl_ctx->ParseError, "read: invalid label");
            errno = 0;
            x = strtol(fl_ctx->readbuf, &end, 10);
            if (*end != '\0' || errno)
                lerror(fl_ctx, fl_ctx->ParseError, "read: invalid label");
            fl_ctx->readtokval = fixnum(x);
        }
        else if (c == '!') {
            // #! single line comment for shbang script support
            do {
                ch = ios_getc(readF(fl_ctx));
            } while (ch != IOS_EOF && (char)ch != '\n');
            return peek(fl_ctx);
        }
        else if (c == '|') {
            // multiline comment
            int commentlevel=1;
            while (1) {
                ch = ios_getc(readF(fl_ctx));
            hashpipe_gotc:
                if (ch == IOS_EOF)
                    lerror(fl_ctx, fl_ctx->ParseError, "read: eof within comment");
                if ((char)ch == '|') {
                    ch = ios_getc(readF(fl_ctx));
                    if ((char)ch == '#') {
                        commentlevel--;
                        if (commentlevel == 0)
                            break;
                        else
                            continue;
                    }
                    goto hashpipe_gotc;
                }
                else if ((char)ch == '#') {
                    ch = ios_getc(readF(fl_ctx));
                    if ((char)ch == '|')
                        commentlevel++;
                    else
                        goto hashpipe_gotc;
                }
            }
            // this was whitespace, so keep peeking
            return peek(fl_ctx);
        }
        else if (c == ';') {
            // datum comment
            (void)do_read_sexpr(fl_ctx, UNBOUND); // skip
            return peek(fl_ctx);
        }
        else if (c == ':') {
            // gensym
            ch = ios_getc(readF(fl_ctx));
            if ((char)ch == 'g')
                ch = ios_getc(readF(fl_ctx));
            read_token(fl_ctx, (char)ch, 0);
            errno = 0;
            x = strtol(fl_ctx->readbuf, &end, 10);
            if (*end != '\0' || fl_ctx->readbuf[0] == '\0' || errno)
                lerror(fl_ctx, fl_ctx->ParseError, "read: invalid gensym label");
            fl_ctx->readtoktype = TOK_GENSYM;
            fl_ctx->readtokval = fixnum(x);
        }
        else if (symchar(c)) {
            read_token(fl_ctx, ch, 0);

            if (((c == 'b' && (base= 2)) ||
                 (c == 'o' && (base= 8)) ||
                 (c == 'd' && (base=10)) ||
                 (c == 'x' && (base=16))) &&
                (isdigit_base(fl_ctx->readbuf[1],base) ||
                 fl_ctx->readbuf[1]=='-')) {
                if (!read_numtok(fl_ctx, &fl_ctx->readbuf[1], &fl_ctx->readtokval, base))
                    lerrorf(fl_ctx, fl_ctx->ParseError, "read: invalid base %d constant", base);
                return (fl_ctx->readtoktype=TOK_NUM);
            }

            fl_ctx->readtoktype = TOK_SHARPSYM;
            fl_ctx->readtokval = symbol(fl_ctx, fl_ctx->readbuf);
        }
        else {
            lerror(fl_ctx, fl_ctx->ParseError, "read: unknown read macro");
        }
    }
    else if (c == ',') {
        fl_ctx->readtoktype = TOK_COMMA;
        ch = ios_peekc(readF(fl_ctx));
        if (ch == IOS_EOF)
            return fl_ctx->readtoktype;
        if ((char)ch == '@')
            fl_ctx->readtoktype = TOK_COMMAAT;
        else if ((char)ch == '.')
            fl_ctx->readtoktype = TOK_COMMADOT;
        else
            return fl_ctx->readtoktype;
        (void)ios_getc(readF(fl_ctx)); // consume ch
    }
    else {
        if (!read_token(fl_ctx, c, 0)) {
            if (fl_ctx->readbuf[0]=='.' && fl_ctx->readbuf[1]=='\0') {
                return (fl_ctx->readtoktype=TOK_DOT);
            }
            else {
                if (read_numtok(fl_ctx, fl_ctx->readbuf, &fl_ctx->readtokval, 0))
                    return (fl_ctx->readtoktype=TOK_NUM);
            }
        }
        fl_ctx->readtoktype = TOK_SYM;
        fl_ctx->readtokval = symbol(fl_ctx, fl_ctx->readbuf);
    }
    return fl_ctx->readtoktype;
}

// NOTE: this is NOT an efficient operation. it is only used by the
// reader, and requires at least 1 and up to 3 garbage collections!
static value_t vector_grow(fl_context_t *fl_ctx, value_t v, int rewrite_refs)
{
    size_t i, s = vector_size(v);
    size_t d = vector_grow_amt(s);
    PUSH(fl_ctx, v);
    value_t newv = alloc_vector(fl_ctx, s+d, 1);
    v = fl_ctx->Stack[fl_ctx->SP-1];
    for(i=0; i < s; i++)
        vector_elt(newv, i) = vector_elt(v, i);
    // use gc to rewrite references from the old vector to the new
    fl_ctx->Stack[fl_ctx->SP-1] = newv;
    if (s > 0 && rewrite_refs) {
        ((size_t*)ptr(v))[0] |= 0x1;
        vector_elt(v, 0) = newv;
        gc(fl_ctx, 0);
    }
    return POP(fl_ctx);
}

static value_t read_vector(fl_context_t *fl_ctx, value_t label, uint32_t closer)
{
    value_t v=fl_ctx->the_empty_vector, elt;
    uint32_t i=0;
    PUSH(fl_ctx, v);
    if (label != UNBOUND)
        ptrhash_put(&fl_ctx->readstate->backrefs, (void*)label, (void*)v);
    while (peek(fl_ctx) != closer) {
        if (ios_eof(readF(fl_ctx)))
            lerror(fl_ctx, fl_ctx->ParseError, "read: unexpected end of input");
        v = fl_ctx->Stack[fl_ctx->SP-1]; // reload after possible alloc in peek()
        if (i >= vector_size(v)) {
            v = fl_ctx->Stack[fl_ctx->SP-1] = vector_grow(fl_ctx, v, label != UNBOUND);
            if (label != UNBOUND)
                ptrhash_put(&fl_ctx->readstate->backrefs, (void*)label, (void*)v);
        }
        elt = do_read_sexpr(fl_ctx, UNBOUND);
        v = fl_ctx->Stack[fl_ctx->SP-1];
        vector_elt(v,i) = elt;
        i++;
    }
    take(fl_ctx);
    if (i > 0)
        vector_setsize(v, i);
    return POP(fl_ctx);
}

static value_t read_string(fl_context_t *fl_ctx)
{
    char *buf, *temp;
    char eseq[10];
    size_t i=0, j, sz = 64, ndig;
    int c;
    value_t s;
    uint32_t wc=0;

    buf = (char*)malloc(sz);
    if (buf == NULL) {
        lerror(fl_ctx, fl_ctx->ParseError, "read: out of memory reading string");
    }
    while (1) {
        if (i >= sz-4) {  // -4: leaves room for longest utf8 sequence
            sz *= 2;
            temp = (char*)realloc(buf, sz);
            if (temp == NULL) {
                free(buf);
                lerror(fl_ctx, fl_ctx->ParseError, "read: out of memory reading string");
            }
            buf = temp;
        }
        c = ios_getc(readF(fl_ctx));
        if (c == IOS_EOF) {
            free(buf);
            lerror(fl_ctx, fl_ctx->ParseError, "read: unexpected end of input in string");
        }
        if (c == '"')
            break;
        else if (c == '\\') {
            c = ios_getc(readF(fl_ctx));
            if (c == IOS_EOF) {
                free(buf);
                lerror(fl_ctx, fl_ctx->ParseError, "read: end of input in escape sequence");
            }
            j = 0;
            if (octal_digit(c)) {
                while (1) {
                    eseq[j++] = c;
                    c = ios_peekc(readF(fl_ctx));
                    if (c == IOS_EOF || !octal_digit(c) || j >= 3)
                        break;
                    (void)ios_getc(readF(fl_ctx)); // consume c
                }
                eseq[j] = '\0';
                wc = strtol(eseq, NULL, 8);
                // \DDD and \xXX read bytes, not characters
                buf[i++] = ((char)wc);
            }
            else if ((c=='x' && (ndig=2)) ||
                     (c=='u' && (ndig=4)) ||
                     (c=='U' && (ndig=8))) {
                while (1) {
                    c = ios_peekc(readF(fl_ctx));
                    if (c == IOS_EOF || !hex_digit(c) || j >= ndig)
                        break;
                    eseq[j++] = c;
                    (void)ios_getc(readF(fl_ctx)); // consume c
                }
                eseq[j] = '\0';
                if (j) wc = strtol(eseq, NULL, 16);
                if (!j || wc > 0x10ffff) {
                    free(buf);
                    lerror(fl_ctx, fl_ctx->ParseError, "read: invalid escape sequence");
                }
                if (ndig == 2)
                    buf[i++] = ((char)wc);
                else
                    i += u8_wc_toutf8(&buf[i], wc);
            }
            else {
                char esc = read_escape_control_char((char)c);
                if (esc == (char)c && !strchr("\\'\"$`", esc)) {
                    free(buf);
                    lerror(fl_ctx, fl_ctx->ParseError, "read: invalid escape sequence");
                }
                buf[i++] = esc;
            }
        }
        else {
            buf[i++] = c;
        }
    }
    s = cvalue_string(fl_ctx, i);
    memcpy(cvalue_data(s), buf, i);
    free(buf);
    return s;
}

// build a list of conses. this is complicated by the fact that all conses
// can move whenever a new cons is allocated. we have to refer to every cons
// through a handle to a relocatable pointer (i.e. a pointer on the stack).
static void read_list(fl_context_t *fl_ctx, value_t *pval, value_t label)
{
    value_t c, *pc;
    uint32_t t;

    PUSH(fl_ctx, fl_ctx->NIL);
    pc = &fl_ctx->Stack[fl_ctx->SP-1];  // to keep track of current cons cell
    t = peek(fl_ctx);
    while (t != TOK_CLOSE) {
        if (ios_eof(readF(fl_ctx)))
            lerror(fl_ctx, fl_ctx->ParseError, "read: unexpected end of input");
        c = mk_cons(fl_ctx); car_(c) = cdr_(c) = fl_ctx->NIL;
        if (iscons(*pc)) {
            cdr_(*pc) = c;
        }
        else {
            *pval = c;
            if (label != UNBOUND)
                ptrhash_put(&fl_ctx->readstate->backrefs, (void*)label, (void*)c);
        }
        *pc = c;
        c = do_read_sexpr(fl_ctx, UNBOUND); // must be on separate lines due to
        car_(*pc) = c;              // undefined evaluation order

        t = peek(fl_ctx);
        if (t == TOK_DOT) {
            take(fl_ctx);
            c = do_read_sexpr(fl_ctx, UNBOUND);
            cdr_(*pc) = c;
            t = peek(fl_ctx);
            if (ios_eof(readF(fl_ctx)))
                lerror(fl_ctx, fl_ctx->ParseError, "read: unexpected end of input");
            if (t != TOK_CLOSE)
                lerror(fl_ctx, fl_ctx->ParseError, "read: expected ')'");
        }
    }
    take(fl_ctx);
    (void)POP(fl_ctx);
}

// label is the backreference we'd like to fix up with this read
static value_t do_read_sexpr(fl_context_t *fl_ctx, value_t label)
{
    value_t v, sym, oldtokval, *head;
    value_t *pv;
    uint32_t t;
    char c;

    t = peek(fl_ctx);
    take(fl_ctx);
    switch (t) {
    case TOK_CLOSE:
        lerror(fl_ctx, fl_ctx->ParseError, "read: unexpected ')'");
    case TOK_CLOSEB:
        lerror(fl_ctx, fl_ctx->ParseError, "read: unexpected ']'");
    case TOK_DOT:
        lerror(fl_ctx, fl_ctx->ParseError, "read: unexpected '.'");
    case TOK_SYM:
    case TOK_NUM:
        return fl_ctx->readtokval;
    case TOK_COMMA:
        head = &fl_ctx->COMMA; goto listwith;
    case TOK_COMMAAT:
        head = &fl_ctx->COMMAAT; goto listwith;
    case TOK_COMMADOT:
        head = &fl_ctx->COMMADOT; goto listwith;
    case TOK_BQ:
        head = &fl_ctx->BACKQUOTE; goto listwith;
    case TOK_QUOTE:
        head = &fl_ctx->QUOTE;
    listwith:
#ifdef MEMDEBUG2
        v = fl_list2(fl_ctx, *head, fl_ctx->NIL);
#else
        v = cons_reserve(fl_ctx, 2);
        car_(v) = *head;
        cdr_(v) = tagptr(((cons_t*)ptr(v))+1, TAG_CONS);
        car_(cdr_(v)) = cdr_(cdr_(v)) = fl_ctx->NIL;
#endif
        PUSH(fl_ctx, v);
        if (label != UNBOUND)
            ptrhash_put(&fl_ctx->readstate->backrefs, (void*)label, (void*)v);
        v = do_read_sexpr(fl_ctx, UNBOUND);
        car_(cdr_(fl_ctx->Stack[fl_ctx->SP-1])) = v;
        return POP(fl_ctx);
    case TOK_SHARPQUOTE:
        // femtoLisp doesn't need symbol-function, so #' does nothing
        return do_read_sexpr(fl_ctx, label);
    case TOK_OPEN:
        PUSH(fl_ctx, fl_ctx->NIL);
        read_list(fl_ctx, &fl_ctx->Stack[fl_ctx->SP-1], label);
        return POP(fl_ctx);
    case TOK_SHARPSYM:
        sym = fl_ctx->readtokval;
        if (sym == fl_ctx->tsym || sym == fl_ctx->Tsym)
            return fl_ctx->T;
        else if (sym == fl_ctx->fsym || sym == fl_ctx->Fsym)
            return fl_ctx->F;
        // constructor notation
        c = nextchar(fl_ctx);
        if (c != '(') {
            take(fl_ctx);
            lerrorf(fl_ctx, fl_ctx->ParseError, "read: expected argument list for %s",
                    symbol_name(fl_ctx, fl_ctx->readtokval));
        }
        PUSH(fl_ctx, fl_ctx->NIL);
        read_list(fl_ctx, &fl_ctx->Stack[fl_ctx->SP-1], UNBOUND);
        if (sym == fl_ctx->vu8sym) {
            sym = fl_ctx->arraysym;
            fl_ctx->Stack[fl_ctx->SP-1] = fl_cons(fl_ctx, fl_ctx->uint8sym, fl_ctx->Stack[fl_ctx->SP-1]);
        }
        else if (sym == fl_ctx->fnsym) {
            sym = fl_ctx->FUNCTION;
        }
        v = symbol_value(sym);
        if (v == UNBOUND)
            fl_raise(fl_ctx, fl_list2(fl_ctx, fl_ctx->UnboundError, sym));
        return fl_apply(fl_ctx, v, POP(fl_ctx));
    case TOK_OPENB:
        return read_vector(fl_ctx, label, TOK_CLOSEB);
    case TOK_SHARPOPEN:
        return read_vector(fl_ctx, label, TOK_CLOSE);
    case TOK_SHARPDOT:
        // eval-when-read
        // evaluated expressions can refer to existing backreferences, but they
        // cannot see pending labels. in other words:
        // (... #2=#.#0# ... )    OK
        // (... #2=#.(#2#) ... )  DO NOT WANT
        sym = do_read_sexpr(fl_ctx, UNBOUND);
        if (issymbol(sym)) {
            v = symbol_value(sym);
            if (v == UNBOUND)
                fl_raise(fl_ctx, fl_list2(fl_ctx, fl_ctx->UnboundError, sym));
            return v;
        }
        return fl_toplevel_eval(fl_ctx, sym);
    case TOK_LABEL:
        // create backreference label
        if (ptrhash_has(&fl_ctx->readstate->backrefs, (void*)fl_ctx->readtokval))
            lerrorf(fl_ctx, fl_ctx->ParseError, "read: label %ld redefined", numval(fl_ctx->readtokval));
        oldtokval = fl_ctx->readtokval;
        v = do_read_sexpr(fl_ctx, fl_ctx->readtokval);
        ptrhash_put(&fl_ctx->readstate->backrefs, (void*)oldtokval, (void*)v);
        return v;
    case TOK_BACKREF:
        // look up backreference
        v = (value_t)ptrhash_get(&fl_ctx->readstate->backrefs, (void*)fl_ctx->readtokval);
        if (v == (value_t)HT_NOTFOUND)
            lerrorf(fl_ctx, fl_ctx->ParseError, "read: undefined label %ld", numval(fl_ctx->readtokval));
        return v;
    case TOK_GENSYM:
        pv = (value_t*)ptrhash_bp(&fl_ctx->readstate->gensyms, (void*)fl_ctx->readtokval);
        if (*pv == (value_t)HT_NOTFOUND)
            *pv = fl_gensym(fl_ctx, NULL, 0);
        return *pv;
    case TOK_DOUBLEQUOTE:
        return read_string(fl_ctx);
    }
    return FL_UNSPECIFIED(fl_ctx);
}

value_t fl_read_sexpr(fl_context_t *fl_ctx, value_t f)
{
    value_t v;
    fl_readstate_t state;
    state.prev = fl_ctx->readstate;
    htable_new(&state.backrefs, 8);
    htable_new(&state.gensyms, 8);
    state.source = f;
    fl_ctx->readstate = &state;
    assert(fl_ctx->readtoktype == TOK_NONE);
    fl_gc_handle(fl_ctx, &fl_ctx->readtokval);

    v = do_read_sexpr(fl_ctx, UNBOUND);

    fl_free_gc_handles(fl_ctx, 1);
    fl_ctx->readstate = state.prev;
    free_readstate(&state);
    return v;
}

static void fl_read_init(fl_context_t *fl_ctx)
{
    fl_ctx->readtoktype = TOK_NONE;
    fl_ctx->readtokval = 0;
    memset(fl_ctx->readbuf, 0, sizeof(fl_ctx->readbuf));
}