picrin/extlib/benz/read.c

921 lines
18 KiB
C
Raw Normal View History

2014-08-25 00:38:09 -04:00
/**
* See Copyright Notice in picrin.h
*/
#include "picrin.h"
static pic_value read(pic_state *pic, struct pic_port *port, int c);
static pic_value read_nullable(pic_state *pic, struct pic_port *port, int c);
2015-01-25 22:22:38 -05:00
PIC_NORETURN static void
2014-08-25 00:38:09 -04:00
read_error(pic_state *pic, const char *msg)
{
2015-06-04 00:23:20 -04:00
struct pic_error *e;
e = pic_make_error(pic, pic->sREAD, msg, pic_nil_value());
pic_raise(pic, pic_obj_value(e));
2014-08-25 00:38:09 -04:00
}
static int
skip(struct pic_port *port, int c)
{
while (isspace(c)) {
c = xfgetc(port->file);
}
return c;
}
static int
next(struct pic_port *port)
{
return xfgetc(port->file);
}
static int
peek(struct pic_port *port)
{
int c;
xungetc((c = xfgetc(port->file)), port->file);
return c;
}
static bool
expect(struct pic_port *port, const char *str)
{
int c;
while ((c = (int)*str++) != 0) {
if (c != peek(port))
return false;
next(port);
}
return true;
}
static bool
isdelim(int c)
{
return c == EOF || strchr("();,|\" \t\n\r", c) != NULL; /* ignores "#", "'" */
}
#if PIC_ENABLE_FLOAT
2014-08-25 00:38:09 -04:00
static bool
strcaseeq(const char *s1, const char *s2)
{
char a, b;
while ((a = *s1++) * (b = *s2++)) {
if (tolower(a) != tolower(b))
return false;
}
return a == b;
}
#endif
2014-08-25 00:38:09 -04:00
2015-01-26 00:33:48 -05:00
static int
case_fold(pic_state *pic, int c)
{
if (pic->reader->typecase == PIC_CASE_FOLD) {
c = tolower(c);
}
return c;
}
2014-08-25 00:38:09 -04:00
static pic_value
2015-05-28 04:06:41 -04:00
read_comment(pic_state PIC_UNUSED(*pic), struct pic_port *port, int c)
2014-08-25 00:38:09 -04:00
{
do {
c = next(port);
} while (! (c == EOF || c == '\n'));
2015-06-09 03:02:23 -04:00
return pic_invalid_value();
2014-08-25 00:38:09 -04:00
}
static pic_value
2015-05-28 04:06:41 -04:00
read_block_comment(pic_state PIC_UNUSED(*pic), struct pic_port *port, int PIC_UNUSED(c))
2014-08-25 00:38:09 -04:00
{
int x, y;
int i = 1;
y = next(port);
while (y != EOF && i > 0) {
x = y;
y = next(port);
if (x == '|' && y == '#') {
i--;
}
if (x == '#' && y == '|') {
i++;
}
}
2015-06-09 03:02:23 -04:00
return pic_invalid_value();
2014-08-25 00:38:09 -04:00
}
static pic_value
2015-05-28 04:06:41 -04:00
read_datum_comment(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c))
2014-08-25 00:38:09 -04:00
{
read(pic, port, next(port));
2015-06-09 03:02:23 -04:00
return pic_invalid_value();
2014-08-25 00:38:09 -04:00
}
static pic_value
read_directive(pic_state *pic, struct pic_port *port, int c)
2014-08-25 00:38:09 -04:00
{
switch (peek(port)) {
case 'n':
if (expect(port, "no-fold-case")) {
pic->reader->typecase = PIC_CASE_DEFAULT;
2015-06-09 03:02:23 -04:00
return pic_invalid_value();
2014-08-25 00:38:09 -04:00
}
break;
case 'f':
if (expect(port, "fold-case")) {
pic->reader->typecase = PIC_CASE_FOLD;
2015-06-09 03:02:23 -04:00
return pic_invalid_value();
2014-08-25 00:38:09 -04:00
}
break;
}
return read_comment(pic, port, c);
2014-08-25 00:38:09 -04:00
}
static pic_value
2015-05-28 04:06:41 -04:00
read_eval(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c))
2014-08-25 00:38:09 -04:00
{
pic_value form;
form = read(pic, port, next(port));
return pic_eval(pic, form, pic->lib->env);
2014-08-25 00:38:09 -04:00
}
static pic_value
2015-05-28 04:06:41 -04:00
read_quote(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c))
2014-08-25 00:38:09 -04:00
{
2015-01-18 21:08:27 -05:00
return pic_list2(pic, pic_obj_value(pic->sQUOTE), read(pic, port, next(port)));
2014-08-25 00:38:09 -04:00
}
static pic_value
2015-05-28 04:06:41 -04:00
read_quasiquote(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c))
2014-08-25 00:38:09 -04:00
{
2015-01-18 21:08:27 -05:00
return pic_list2(pic, pic_obj_value(pic->sQUASIQUOTE), read(pic, port, next(port)));
2014-08-25 00:38:09 -04:00
}
static pic_value
2015-05-28 04:06:41 -04:00
read_unquote(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c))
2014-08-25 00:38:09 -04:00
{
pic_sym *tag = pic->sUNQUOTE;
2014-08-25 00:38:09 -04:00
if (peek(port) == '@') {
tag = pic->sUNQUOTE_SPLICING;
next(port);
}
return pic_list2(pic, pic_obj_value(tag), read(pic, port, next(port)));
2014-08-25 00:38:09 -04:00
}
2015-06-10 02:18:03 -04:00
static pic_value
read_syntax_quote(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c))
{
return pic_list2(pic, pic_obj_value(pic->sSYNTAX_QUOTE), read(pic, port, next(port)));
}
static pic_value
read_syntax_quasiquote(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c))
{
return pic_list2(pic, pic_obj_value(pic->sSYNTAX_QUASIQUOTE), read(pic, port, next(port)));
}
static pic_value
read_syntax_unquote(pic_state *pic, struct pic_port *port, int PIC_UNUSED(c))
{
pic_sym *tag = pic->sSYNTAX_UNQUOTE;
if (peek(port) == '@') {
tag = pic->sSYNTAX_UNQUOTE_SPLICING;
next(port);
}
return pic_list2(pic, pic_obj_value(tag), read(pic, port, next(port)));
}
2014-08-25 00:38:09 -04:00
static pic_value
read_symbol(pic_state *pic, struct pic_port *port, int c)
2014-08-25 00:38:09 -04:00
{
size_t len;
2014-08-25 00:38:09 -04:00
char *buf;
2015-01-20 02:02:28 -05:00
pic_sym *sym;
2014-08-25 00:38:09 -04:00
len = 1;
2015-05-28 03:42:16 -04:00
buf = pic_malloc(pic, len + 1);
2015-01-26 00:33:48 -05:00
buf[0] = case_fold(pic, c);
buf[1] = 0;
2014-08-25 00:38:09 -04:00
while (! isdelim(peek(port))) {
c = next(port);
len += 1;
buf = pic_realloc(pic, buf, len + 1);
2015-01-26 00:33:48 -05:00
buf[len - 1] = case_fold(pic, c);
buf[len] = 0;
2014-08-25 00:38:09 -04:00
}
2015-01-18 12:21:10 -05:00
sym = pic_intern_cstr(pic, buf);
2014-08-25 00:38:09 -04:00
pic_free(pic, buf);
2015-01-18 21:08:27 -05:00
return pic_obj_value(sym);
2014-08-25 00:38:09 -04:00
}
2015-05-27 10:40:01 -04:00
static unsigned
read_uinteger(pic_state *pic, struct pic_port *port, int c)
2014-08-25 00:38:09 -04:00
{
2015-05-27 10:40:01 -04:00
unsigned u = 0;
2014-08-25 00:38:09 -04:00
if (! isdigit(c)) {
read_error(pic, "expected one or more digits");
}
2015-05-27 10:40:01 -04:00
u = c - '0';
2014-08-25 00:38:09 -04:00
while (isdigit(c = peek(port))) {
2015-05-27 10:40:01 -04:00
u = u * 10 + next(port) - '0';
2014-08-25 00:38:09 -04:00
}
2015-05-27 10:40:01 -04:00
return u;
2014-08-25 00:38:09 -04:00
}
2015-05-27 10:40:01 -04:00
static int
read_suffix(pic_state *pic, struct pic_port *port)
2014-08-25 00:38:09 -04:00
{
2015-05-27 10:40:01 -04:00
int c, s = 1;
2014-08-25 00:38:09 -04:00
c = peek(port);
if (c != 'e' && c != 'E') {
2015-05-27 10:40:01 -04:00
return 0;
2014-08-25 00:38:09 -04:00
}
2015-05-27 10:40:01 -04:00
next(port);
2014-08-25 00:38:09 -04:00
switch ((c = next(port))) {
case '-':
2015-05-27 10:40:01 -04:00
s = -1;
2014-08-25 00:38:09 -04:00
case '+':
c = next(port);
default:
2015-05-27 10:40:01 -04:00
return s * read_uinteger(pic, port, c);
2014-08-25 00:38:09 -04:00
}
}
static pic_value
read_unsigned(pic_state *pic, struct pic_port *port, int c)
{
unsigned u;
2015-05-27 10:40:01 -04:00
int exp, s, i, e;
#if PIC_ENABLE_FLOAT
double f, g;
#endif
2014-08-25 00:38:09 -04:00
2015-05-27 10:40:01 -04:00
u = read_uinteger(pic, port, c);
2014-08-25 00:38:09 -04:00
switch (peek(port)) {
#if PIC_ENABLE_FLOAT
2014-08-25 00:38:09 -04:00
case '.':
2015-05-27 10:40:01 -04:00
next(port);
g = 0, e = 0;
2015-05-27 10:40:01 -04:00
while (isdigit(c = peek(port))) {
g = g * 10 + (next(port) - '0');
e++;
2015-05-27 10:40:01 -04:00
}
f = u + g * pow(10, -e);
2015-05-27 10:40:01 -04:00
exp = read_suffix(pic, port);
if (exp >= 0) {
s = 0;
} else {
exp = -exp;
s = 1;
}
e = 10;
for (i = 0; exp; ++i) {
if ((exp & 1) != 0) {
f = s ? f / e : (f * e);
}
e *= e;
exp >>= 1;
}
return pic_float_value(f);
#endif
2014-08-25 00:38:09 -04:00
default:
2015-05-27 10:40:01 -04:00
exp = read_suffix(pic, port);
if (exp >= 0) {
s = 0;
} else {
exp = -exp;
s = 1;
}
e = 10;
for (i = 0; exp; ++i) {
if ((exp & 1) != 0) {
u = s ? u / e : (u * e);
}
e *= e;
exp >>= 1;
}
return pic_int_value(u);
2014-08-25 00:38:09 -04:00
}
}
static pic_value
read_number(pic_state *pic, struct pic_port *port, int c)
2014-08-25 00:38:09 -04:00
{
return read_unsigned(pic, port, c);
2014-08-25 00:38:09 -04:00
}
static pic_value
negate(pic_value n)
{
#if PIC_ENABLE_FLOAT
2014-08-25 00:38:09 -04:00
if (pic_int_p(n)) {
return pic_int_value(-pic_int(n));
} else {
return pic_float_value(-pic_float(n));
}
#else
return pic_int_value(-pic_int(n));
#endif
2014-08-25 00:38:09 -04:00
}
static pic_value
read_minus(pic_state *pic, struct pic_port *port, int c)
2014-08-25 00:38:09 -04:00
{
pic_value sym;
if (isdigit(peek(port))) {
return negate(read_unsigned(pic, port, next(port)));
}
else {
sym = read_symbol(pic, port, c);
#if PIC_ENABLE_FLOAT
2015-01-20 01:31:17 -05:00
if (strcaseeq(pic_symbol_name(pic, pic_sym_ptr(sym)), "-inf.0")) {
2014-08-25 00:38:09 -04:00
return pic_float_value(-INFINITY);
}
2015-01-20 01:31:17 -05:00
if (strcaseeq(pic_symbol_name(pic, pic_sym_ptr(sym)), "-nan.0")) {
2014-08-25 00:38:09 -04:00
return pic_float_value(-NAN);
}
#endif
2014-08-25 00:38:09 -04:00
return sym;
}
}
static pic_value
read_plus(pic_state *pic, struct pic_port *port, int c)
2014-08-25 00:38:09 -04:00
{
pic_value sym;
if (isdigit(peek(port))) {
return read_unsigned(pic, port, next(port));
}
else {
sym = read_symbol(pic, port, c);
#if PIC_ENABLE_FLOAT
2015-01-20 01:31:17 -05:00
if (strcaseeq(pic_symbol_name(pic, pic_sym_ptr(sym)), "+inf.0")) {
2014-08-25 00:38:09 -04:00
return pic_float_value(INFINITY);
}
2015-01-20 01:31:17 -05:00
if (strcaseeq(pic_symbol_name(pic, pic_sym_ptr(sym)), "+nan.0")) {
2014-08-25 00:38:09 -04:00
return pic_float_value(NAN);
}
#endif
2014-08-25 00:38:09 -04:00
return sym;
}
}
static pic_value
read_true(pic_state *pic, struct pic_port *port, int c)
2014-08-25 00:38:09 -04:00
{
if ((c = peek(port)) == 'r') {
if (! expect(port, "rue")) {
read_error(pic, "unexpected character while reading #true");
}
} else if (! isdelim(c)) {
read_error(pic, "non-delimiter character given after #t");
}
2014-08-25 00:38:09 -04:00
return pic_true_value();
}
static pic_value
read_false(pic_state *pic, struct pic_port *port, int c)
2014-08-25 00:38:09 -04:00
{
if ((c = peek(port)) == 'a') {
if (! expect(port, "alse")) {
read_error(pic, "unexpected character while reading #false");
}
} else if (! isdelim(c)) {
read_error(pic, "non-delimiter character given after #f");
}
2014-08-25 00:38:09 -04:00
return pic_false_value();
}
static pic_value
read_char(pic_state *pic, struct pic_port *port, int c)
2014-08-25 00:38:09 -04:00
{
c = next(port);
if (! isdelim(peek(port))) {
switch (c) {
default: read_error(pic, "unexpected character after char literal");
case 'a': c = '\a'; if (! expect(port, "lerm")) goto fail; break;
case 'b': c = '\b'; if (! expect(port, "ackspace")) goto fail; break;
case 'd': c = 0x7F; if (! expect(port, "elete")) goto fail; break;
case 'e': c = 0x1B; if (! expect(port, "scape")) goto fail; break;
case 'n':
if ((c = peek(port)) == 'e') {
c = '\n';
if (! expect(port, "ewline"))
goto fail;
} else {
c = '\0';
if (! expect(port, "ull"))
goto fail;
}
break;
case 'r': c = '\r'; if (! expect(port, "eturn")) goto fail; break;
case 's': c = ' '; if (! expect(port, "pace")) goto fail; break;
case 't': c = '\t'; if (! expect(port, "ab")) goto fail; break;
}
}
2014-09-27 07:43:31 -04:00
return pic_char_value((char)c);
2014-08-25 00:38:09 -04:00
fail:
read_error(pic, "unexpected character while reading character literal");
}
static pic_value
read_string(pic_state *pic, struct pic_port *port, int c)
2014-08-25 00:38:09 -04:00
{
char *buf;
size_t size, cnt;
pic_str *str;
size = 256;
2015-05-28 03:42:16 -04:00
buf = pic_malloc(pic, size);
2014-08-25 00:38:09 -04:00
cnt = 0;
/* TODO: intraline whitespaces */
while ((c = next(port)) != '"') {
if (c == '\\') {
switch (c = next(port)) {
case 'a': c = '\a'; break;
case 'b': c = '\b'; break;
case 't': c = '\t'; break;
case 'n': c = '\n'; break;
case 'r': c = '\r'; break;
}
}
2014-09-27 07:43:31 -04:00
buf[cnt++] = (char)c;
2014-08-25 00:38:09 -04:00
if (cnt >= size) {
buf = pic_realloc(pic, buf, size *= 2);
}
}
buf[cnt] = '\0';
2014-09-12 06:52:49 -04:00
str = pic_make_str(pic, buf, cnt);
2014-08-25 00:38:09 -04:00
pic_free(pic, buf);
return pic_obj_value(str);
}
static pic_value
read_pipe(pic_state *pic, struct pic_port *port, int c)
2014-08-25 00:38:09 -04:00
{
char *buf;
size_t size, cnt;
2015-01-20 02:02:28 -05:00
pic_sym *sym;
2014-08-25 00:38:09 -04:00
/* Currently supports only ascii chars */
char HEX_BUF[3];
size_t i = 0;
size = 256;
2015-05-28 03:42:16 -04:00
buf = pic_malloc(pic, size);
2014-08-25 00:38:09 -04:00
cnt = 0;
while ((c = next(port)) != '|') {
if (c == '\\') {
switch ((c = next(port))) {
case 'a': c = '\a'; break;
case 'b': c = '\b'; break;
case 't': c = '\t'; break;
case 'n': c = '\n'; break;
case 'r': c = '\r'; break;
case 'x':
i = 0;
2014-09-27 07:43:31 -04:00
while ((HEX_BUF[i++] = (char)next(port)) != ';') {
2014-08-25 00:38:09 -04:00
if (i >= sizeof HEX_BUF)
read_error(pic, "expected ';'");
}
2014-09-27 07:43:31 -04:00
c = (char)strtol(HEX_BUF, NULL, 16);
2014-08-25 00:38:09 -04:00
break;
}
}
2014-09-27 07:43:31 -04:00
buf[cnt++] = (char)c;
2014-08-25 00:38:09 -04:00
if (cnt >= size) {
buf = pic_realloc(pic, buf, size *= 2);
}
}
buf[cnt] = '\0';
sym = pic_intern_cstr(pic, buf);
pic_free(pic, buf);
2015-01-18 21:08:27 -05:00
return pic_obj_value(sym);
2014-08-25 00:38:09 -04:00
}
static pic_value
read_blob(pic_state *pic, struct pic_port *port, int c)
2014-08-25 00:38:09 -04:00
{
int nbits, n;
2014-08-25 00:38:09 -04:00
size_t len, i;
2014-09-27 07:43:31 -04:00
unsigned char *dat;
2014-08-25 00:38:09 -04:00
pic_blob *blob;
nbits = 0;
while (isdigit(c = next(port))) {
nbits = 10 * nbits + c - '0';
}
if (nbits != 8) {
read_error(pic, "unsupported bytevector bit width");
}
if (c != '(') {
read_error(pic, "expected '(' character");
}
len = 0;
dat = NULL;
c = next(port);
while ((c = skip(port, c)) != ')') {
2015-05-27 10:40:01 -04:00
n = read_uinteger(pic, port, c);
2014-08-25 00:38:09 -04:00
if (n < 0 || (1 << nbits) <= n) {
read_error(pic, "invalid element in bytevector literal");
}
len += 1;
dat = pic_realloc(pic, dat, len);
2014-09-27 07:43:31 -04:00
dat[len - 1] = (unsigned char)n;
2014-08-25 00:38:09 -04:00
c = next(port);
}
2014-09-12 06:36:24 -04:00
blob = pic_make_blob(pic, len);
2014-08-25 00:38:09 -04:00
for (i = 0; i < len; ++i) {
blob->data[i] = dat[i];
}
pic_free(pic, dat);
return pic_obj_value(blob);
}
2015-06-09 03:19:57 -04:00
static pic_value
read_undef_or_blob(pic_state *pic, struct pic_port *port, int c)
{
if ((c = peek(port)) == 'n') {
if (! expect(port, "ndefined")) {
read_error(pic, "unexpected character while reading #undefined");
}
return pic_undef_value();
}
if (! isdigit(c)) {
read_error(pic, "expect #undefined or #u8(...), but illegal character given");
}
return read_blob(pic, port, 'u');
}
2014-08-25 00:38:09 -04:00
static pic_value
read_pair(pic_state *pic, struct pic_port *port, int c)
2014-08-25 00:38:09 -04:00
{
2015-01-25 22:29:29 -05:00
static const int tCLOSE = ')';
2014-08-25 00:38:09 -04:00
pic_value car, cdr;
retry:
c = skip(port, ' ');
if (c == tCLOSE) {
return pic_nil_value();
}
if (c == '.' && isdelim(peek(port))) {
cdr = read(pic, port, next(port));
closing:
if ((c = skip(port, ' ')) != tCLOSE) {
2015-06-09 03:02:23 -04:00
if (pic_invalid_p(read_nullable(pic, port, c))) {
2014-08-25 00:38:09 -04:00
goto closing;
}
read_error(pic, "unmatched parenthesis");
}
return cdr;
}
else {
car = read_nullable(pic, port, c);
2015-06-09 03:02:23 -04:00
if (pic_invalid_p(car)) {
2014-08-25 00:38:09 -04:00
goto retry;
}
2015-01-25 22:29:29 -05:00
cdr = read_pair(pic, port, '(');
2014-08-25 00:38:09 -04:00
return pic_cons(pic, car, cdr);
}
}
static pic_value
read_vector(pic_state *pic, struct pic_port *port, int c)
2014-08-25 00:38:09 -04:00
{
pic_value list;
list = read(pic, port, c);
2014-08-25 00:38:09 -04:00
2014-09-12 06:55:32 -04:00
return pic_obj_value(pic_make_vec_from_list(pic, list));
2014-08-25 00:38:09 -04:00
}
static pic_value
read_label_set(pic_state *pic, struct pic_port *port, int i)
{
pic_value val;
int c;
switch ((c = skip(port, ' '))) {
2015-01-25 22:29:29 -05:00
case '(':
2014-08-25 00:38:09 -04:00
{
pic_value tmp;
2015-06-09 03:34:45 -04:00
val = pic_cons(pic, pic_undef_value(), pic_undef_value());
2014-08-25 00:38:09 -04:00
xh_put_int(&pic->reader->labels, i, &val);
tmp = read(pic, port, c);
pic_pair_ptr(val)->car = pic_car(pic, tmp);
pic_pair_ptr(val)->cdr = pic_cdr(pic, tmp);
return val;
}
case '#':
{
bool vect;
if (peek(port) == '(') {
vect = true;
} else {
vect = false;
}
if (vect) {
pic_vec *tmp;
2014-09-12 06:55:32 -04:00
val = pic_obj_value(pic_make_vec(pic, 0));
2014-08-25 00:38:09 -04:00
xh_put_int(&pic->reader->labels, i, &val);
tmp = pic_vec_ptr(read(pic, port, c));
2015-01-07 16:11:48 -05:00
PIC_SWAP(pic_value *, tmp->data, pic_vec_ptr(val)->data);
PIC_SWAP(size_t, tmp->len, pic_vec_ptr(val)->len);
2014-08-25 00:38:09 -04:00
return val;
}
2015-01-07 16:11:48 -05:00
PIC_FALLTHROUGH;
2014-08-25 00:38:09 -04:00
}
default:
{
val = read(pic, port, c);
xh_put_int(&pic->reader->labels, i, &val);
return val;
}
}
}
static pic_value
2015-05-28 04:06:41 -04:00
read_label_ref(pic_state *pic, struct pic_port PIC_UNUSED(*port), int i)
2014-08-25 00:38:09 -04:00
{
xh_entry *e;
e = xh_get_int(&pic->reader->labels, i);
if (! e) {
read_error(pic, "label of given index not defined");
}
return xh_val(e, pic_value);
}
static pic_value
read_label(pic_state *pic, struct pic_port *port, int c)
2014-08-25 00:38:09 -04:00
{
int i;
2014-08-25 00:38:09 -04:00
i = 0;
do {
i = i * 10 + c - '0';
2014-08-25 00:38:09 -04:00
} while (isdigit(c = next(port)));
if (c == '=') {
return read_label_set(pic, port, i);
}
if (c == '#') {
return read_label_ref(pic, port, i);
}
read_error(pic, "broken label expression");
}
static pic_value
2015-05-28 04:06:41 -04:00
read_unmatch(pic_state *pic, struct pic_port PIC_UNUSED(*port), int PIC_UNUSED(c))
2014-08-25 00:38:09 -04:00
{
read_error(pic, "unmatched parenthesis");
}
static pic_value
read_dispatch(pic_state *pic, struct pic_port *port, int c)
2014-08-25 00:38:09 -04:00
{
c = next(port);
2014-08-25 00:38:09 -04:00
if (c == EOF) {
read_error(pic, "unexpected EOF");
}
if (pic->reader->dispatch[c] == NULL) {
2014-08-25 00:38:09 -04:00
read_error(pic, "invalid character at the seeker head");
}
return pic->reader->dispatch[c](pic, port, c);
}
2014-08-25 00:38:09 -04:00
static pic_value
read_nullable(pic_state *pic, struct pic_port *port, int c)
{
c = skip(port, c);
2014-08-25 00:38:09 -04:00
if (c == EOF) {
read_error(pic, "unexpected EOF");
2014-08-25 00:38:09 -04:00
}
if (pic->reader->table[c] == NULL) {
read_error(pic, "invalid character at the seeker head");
2014-08-25 00:38:09 -04:00
}
return pic->reader->table[c](pic, port, c);
2014-08-25 00:38:09 -04:00
}
static pic_value
read(pic_state *pic, struct pic_port *port, int c)
{
pic_value val;
retry:
val = read_nullable(pic, port, c);
2015-06-09 03:02:23 -04:00
if (pic_invalid_p(val)) {
2014-08-25 00:38:09 -04:00
c = next(port);
goto retry;
}
return val;
}
static void
reader_table_init(struct pic_reader *reader)
2014-08-25 00:38:09 -04:00
{
int c;
reader->table[0] = NULL;
2014-08-25 00:38:09 -04:00
/* default reader */
for (c = 1; c < 256; ++c) {
reader->table[c] = read_symbol;
}
reader->table[')'] = read_unmatch;
reader->table[';'] = read_comment;
reader->table['\''] = read_quote;
reader->table['`'] = read_quasiquote;
reader->table[','] = read_unquote;
reader->table['"'] = read_string;
reader->table['|'] = read_pipe;
reader->table['+'] = read_plus;
reader->table['-'] = read_minus;
reader->table['('] = read_pair;
reader->table['#'] = read_dispatch;
2014-08-25 00:38:09 -04:00
/* read number */
for (c = '0'; c <= '9'; ++c) {
reader->table[c] = read_number;
2014-08-25 00:38:09 -04:00
}
reader->dispatch['!'] = read_directive;
reader->dispatch['|'] = read_block_comment;
reader->dispatch[';'] = read_datum_comment;
reader->dispatch['t'] = read_true;
reader->dispatch['f'] = read_false;
2015-06-10 02:18:03 -04:00
reader->dispatch['\''] = read_syntax_quote;
reader->dispatch['`'] = read_syntax_quasiquote;
reader->dispatch[','] = read_syntax_unquote;
reader->dispatch['\\'] = read_char;
reader->dispatch['('] = read_vector;
2015-06-09 03:19:57 -04:00
reader->dispatch['u'] = read_undef_or_blob;
reader->dispatch['.'] = read_eval;
/* read labels */
for (c = '0'; c <= '9'; ++c) {
reader->dispatch[c] = read_label;
2014-08-25 00:38:09 -04:00
}
}
struct pic_reader *
pic_reader_open(pic_state *pic)
{
struct pic_reader *reader;
int c;
2015-05-28 03:42:16 -04:00
reader = pic_malloc(pic, sizeof(struct pic_reader));
reader->typecase = PIC_CASE_DEFAULT;
xh_init_int(&reader->labels, sizeof(pic_value));
for (c = 0; c < 256; ++c) {
reader->table[c] = NULL;
}
for (c = 0; c < 256; ++c) {
reader->dispatch[c] = NULL;
}
reader_table_init(reader);
return reader;
}
void
pic_reader_close(pic_state *pic, struct pic_reader *reader)
{
xh_destroy(&reader->labels);
pic_free(pic, reader);
}
2014-08-25 00:38:09 -04:00
pic_value
pic_read(pic_state *pic, struct pic_port *port)
{
pic_value val;
int c = next(port);
retry:
c = skip(port, c);
if (c == EOF) {
return pic_eof_object();
}
val = read_nullable(pic, port, c);
2015-06-09 03:02:23 -04:00
if (pic_invalid_p(val)) {
2014-08-25 00:38:09 -04:00
c = next(port);
goto retry;
}
return val;
}
pic_value
pic_read_cstr(pic_state *pic, const char *str)
{
2015-05-28 10:28:55 -04:00
struct pic_port *port = pic_open_input_string(pic, str);
pic_value form;
2014-08-25 00:38:09 -04:00
2015-05-28 10:28:55 -04:00
form = pic_read(pic, port);
2014-08-25 00:38:09 -04:00
2015-05-28 10:28:55 -04:00
pic_close_port(pic, port);
return form;
2014-08-25 00:38:09 -04:00
}
static pic_value
pic_read_read(pic_state *pic)
{
struct pic_port *port = pic_stdin(pic);
pic_get_args(pic, "|p", &port);
return pic_read(pic, port);
}
void
pic_init_read(pic_state *pic)
{
2014-08-31 22:37:52 -04:00
pic_defun(pic, "read", pic_read_read);
2014-08-25 00:38:09 -04:00
}