picrin/lib/read.c

790 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"
2016-02-20 10:58:58 -05:00
#include "picrin/extra.h"
2016-02-20 11:13:16 -05:00
#include "picrin/private/object.h"
2014-08-25 00:38:09 -04:00
2016-02-19 00:50:12 -05:00
#undef EOF
#define EOF (-1)
2016-02-21 04:28:59 -05:00
KHASH_DECLARE(read, int, pic_value)
2015-06-24 18:34:10 -04:00
KHASH_DEFINE(read, int, pic_value, kh_int_hash_func, kh_int_hash_equal)
2016-02-21 04:28:59 -05:00
struct reader_control {
int typecase;
khash_t(read) labels;
};
#define CASE_DEFAULT 0
#define CASE_FOLD 1
2016-06-19 15:49:01 -04:00
typedef pic_value (*pic_reader_t)(pic_state *, pic_value port, int c, struct reader_control *);
2016-02-21 04:28:59 -05:00
static pic_reader_t reader_table[256];
static pic_reader_t reader_dispatch[256];
2016-06-19 15:49:01 -04:00
static pic_value read_value(pic_state *pic, pic_value port, int c, struct reader_control *p);
static pic_value read_nullable(pic_state *pic, pic_value port, int c, struct reader_control *p);
2014-08-25 00:38:09 -04:00
2015-01-25 22:22:38 -05:00
PIC_NORETURN static void
2016-02-18 11:34:13 -05:00
read_error(pic_state *pic, const char *msg, pic_value irritants)
2014-08-25 00:38:09 -04:00
{
2016-02-22 12:23:22 -05:00
pic_raise(pic, pic_make_error(pic, "read", msg, irritants));
2014-08-25 00:38:09 -04:00
}
static int
2016-06-19 15:49:01 -04:00
skip(pic_state *pic, pic_value port, int c)
2014-08-25 00:38:09 -04:00
{
while (isspace(c)) {
2016-06-19 15:49:01 -04:00
c = pic_fgetc(pic, port);
2014-08-25 00:38:09 -04:00
}
return c;
}
static int
2016-06-19 15:49:01 -04:00
next(pic_state *pic, pic_value port)
2014-08-25 00:38:09 -04:00
{
2016-06-19 15:49:01 -04:00
return pic_fgetc(pic, port);
2014-08-25 00:38:09 -04:00
}
static int
2016-06-19 15:49:01 -04:00
peek(pic_state *pic, pic_value port)
2014-08-25 00:38:09 -04:00
{
int c;
2016-06-19 15:49:01 -04:00
pic_ungetc(pic, (c = pic_fgetc(pic, port)), port);
2014-08-25 00:38:09 -04:00
return c;
}
static bool
2016-06-19 15:49:01 -04:00
expect(pic_state *pic, pic_value port, const char *str)
2014-08-25 00:38:09 -04:00
{
int c;
while ((c = (int)*str++) != 0) {
2016-06-19 15:49:01 -04:00
if (c != peek(pic, port))
2014-08-25 00:38:09 -04:00
return false;
2016-06-19 15:49:01 -04:00
next(pic, port);
2014-08-25 00:38:09 -04:00
}
return true;
}
static bool
isdelim(int c)
{
return c == EOF || strchr("();,|\" \t\n\r", c) != NULL; /* ignores "#", "'" */
}
2015-01-26 00:33:48 -05:00
static int
2016-02-21 04:28:59 -05:00
case_fold(int c, struct reader_control *p)
2015-01-26 00:33:48 -05:00
{
2016-02-21 04:28:59 -05:00
if (p->typecase == CASE_FOLD) {
2015-01-26 00:33:48 -05:00
c = tolower(c);
}
return c;
}
2014-08-25 00:38:09 -04:00
static pic_value
2016-06-19 15:49:01 -04:00
read_comment(pic_state *pic, pic_value port, int c, struct reader_control *PIC_UNUSED(p))
2014-08-25 00:38:09 -04:00
{
do {
2016-06-19 15:49:01 -04:00
c = next(pic, port);
2014-08-25 00:38:09 -04:00
} while (! (c == EOF || c == '\n'));
2016-02-20 05:00:41 -05:00
return pic_invalid_value(pic);
2014-08-25 00:38:09 -04:00
}
static pic_value
2016-06-19 15:49:01 -04:00
read_block_comment(pic_state *pic, pic_value port, int PIC_UNUSED(c), struct reader_control *PIC_UNUSED(p))
2014-08-25 00:38:09 -04:00
{
int x, y;
int i = 1;
2016-06-19 15:49:01 -04:00
y = next(pic, port);
2014-08-25 00:38:09 -04:00
while (y != EOF && i > 0) {
x = y;
2016-06-19 15:49:01 -04:00
y = next(pic, port);
2014-08-25 00:38:09 -04:00
if (x == '|' && y == '#') {
i--;
}
if (x == '#' && y == '|') {
i++;
}
}
2016-02-20 05:00:41 -05:00
return pic_invalid_value(pic);
2014-08-25 00:38:09 -04:00
}
static pic_value
2016-06-19 15:49:01 -04:00
read_datum_comment(pic_state *pic, pic_value port, int PIC_UNUSED(c), struct reader_control *p)
2014-08-25 00:38:09 -04:00
{
2016-06-19 15:49:01 -04:00
read_value(pic, port, next(pic, port), p);
2014-08-25 00:38:09 -04:00
2016-02-20 05:00:41 -05:00
return pic_invalid_value(pic);
2014-08-25 00:38:09 -04:00
}
static pic_value
2016-06-19 15:49:01 -04:00
read_directive(pic_state *pic, pic_value port, int c, struct reader_control *p)
2014-08-25 00:38:09 -04:00
{
2016-06-19 15:49:01 -04:00
switch (peek(pic, port)) {
2014-08-25 00:38:09 -04:00
case 'n':
2016-06-19 15:49:01 -04:00
if (expect(pic, port, "no-fold-case")) {
2016-02-21 04:28:59 -05:00
p->typecase = CASE_DEFAULT;
2016-02-20 05:00:41 -05:00
return pic_invalid_value(pic);
2014-08-25 00:38:09 -04:00
}
break;
case 'f':
2016-06-19 15:49:01 -04:00
if (expect(pic, port, "fold-case")) {
2016-02-21 04:28:59 -05:00
p->typecase = CASE_FOLD;
2016-02-20 05:00:41 -05:00
return pic_invalid_value(pic);
2014-08-25 00:38:09 -04:00
}
break;
}
2016-06-19 15:49:01 -04:00
return read_comment(pic, port, c, p);
2014-08-25 00:38:09 -04:00
}
static pic_value
2016-06-19 15:49:01 -04:00
read_quote(pic_state *pic, pic_value port, int PIC_UNUSED(c), struct reader_control *p)
2014-08-25 00:38:09 -04:00
{
2016-06-19 15:49:01 -04:00
return pic_list(pic, 2, pic_intern_lit(pic, "quote"), read_value(pic, port, next(pic, port), p));
2014-08-25 00:38:09 -04:00
}
static pic_value
2016-06-19 15:49:01 -04:00
read_quasiquote(pic_state *pic, pic_value port, int PIC_UNUSED(c), struct reader_control *p)
2014-08-25 00:38:09 -04:00
{
2016-06-19 15:49:01 -04:00
return pic_list(pic, 2, pic_intern_lit(pic, "quasiquote"), read_value(pic, port, next(pic, port), p));
2014-08-25 00:38:09 -04:00
}
static pic_value
2016-06-19 15:49:01 -04:00
read_unquote(pic_state *pic, pic_value port, int PIC_UNUSED(c), struct reader_control *p)
2014-08-25 00:38:09 -04:00
{
2016-02-20 14:34:26 -05:00
pic_value tag;
2014-08-25 00:38:09 -04:00
2016-06-19 15:49:01 -04:00
if (peek(pic, port) == '@') {
2016-02-20 14:34:26 -05:00
tag = pic_intern_lit(pic, "unquote-splicing");
2016-06-19 15:49:01 -04:00
next(pic, port);
2016-02-20 14:34:26 -05:00
} else {
tag = pic_intern_lit(pic, "unquote");
}
2016-06-19 15:49:01 -04:00
return pic_list(pic, 2, tag, read_value(pic, port, next(pic, port), p));
2014-08-25 00:38:09 -04:00
}
2015-06-10 02:18:03 -04:00
static pic_value
2016-06-19 15:49:01 -04:00
read_syntax_quote(pic_state *pic, pic_value port, int PIC_UNUSED(c), struct reader_control *p)
2015-06-10 02:18:03 -04:00
{
2016-06-19 15:49:01 -04:00
return pic_list(pic, 2, pic_intern_lit(pic, "syntax-quote"), read_value(pic, port, next(pic, port), p));
2015-06-10 02:18:03 -04:00
}
static pic_value
2016-06-19 15:49:01 -04:00
read_syntax_quasiquote(pic_state *pic, pic_value port, int PIC_UNUSED(c), struct reader_control *p)
2015-06-10 02:18:03 -04:00
{
2016-06-19 15:49:01 -04:00
return pic_list(pic, 2, pic_intern_lit(pic, "syntax-quasiquote"), read_value(pic, port, next(pic, port), p));
2015-06-10 02:18:03 -04:00
}
static pic_value
2016-06-19 15:49:01 -04:00
read_syntax_unquote(pic_state *pic, pic_value port, int PIC_UNUSED(c), struct reader_control *p)
2015-06-10 02:18:03 -04:00
{
2016-02-20 14:34:26 -05:00
pic_value tag;
2015-06-10 02:18:03 -04:00
2016-06-19 15:49:01 -04:00
if (peek(pic, port) == '@') {
2016-02-20 14:34:26 -05:00
tag = pic_intern_lit(pic, "syntax-unquote-splicing");
2016-06-19 15:49:01 -04:00
next(pic, port);
2016-02-20 14:34:26 -05:00
} else {
tag = pic_intern_lit(pic, "syntax-unquote");
2015-06-10 02:18:03 -04:00
}
2016-06-19 15:49:01 -04:00
return pic_list(pic, 2, tag, read_value(pic, port, next(pic, port), p));
2015-06-10 02:18:03 -04:00
}
2014-08-25 00:38:09 -04:00
static pic_value
2016-06-19 15:49:01 -04:00
read_atom(pic_state *pic, pic_value port, int c, struct reader_control *p) {
2015-08-26 06:04:27 -04:00
int len;
2014-08-25 00:38:09 -04:00
char *buf;
2016-03-03 05:42:18 -05:00
pic_value str;
2014-08-25 00:38:09 -04:00
len = 1;
2015-05-28 03:42:16 -04:00
buf = pic_malloc(pic, len + 1);
2016-02-21 04:28:59 -05:00
buf[0] = case_fold(c, p);
buf[1] = 0;
2014-08-25 00:38:09 -04:00
2016-06-19 15:49:01 -04:00
while (! isdelim(peek(pic, port))) {
c = next(pic, port);
2014-08-25 00:38:09 -04:00
len += 1;
buf = pic_realloc(pic, buf, len + 1);
2016-02-21 04:28:59 -05:00
buf[len - 1] = case_fold(c, p);
buf[len] = 0;
2014-08-25 00:38:09 -04:00
}
2016-03-03 05:42:18 -05:00
str = pic_str_value(pic, buf, len);
2014-08-25 00:38:09 -04:00
pic_free(pic, buf);
2016-03-03 05:42:18 -05:00
return str;
2014-08-25 00:38:09 -04:00
}
static pic_value
2016-06-19 15:49:01 -04:00
read_symbol(pic_state *pic, pic_value port, int c, struct reader_control *p)
2014-08-25 00:38:09 -04:00
{
2016-06-19 15:49:01 -04:00
return pic_intern(pic, read_atom(pic, port, c, p));
2014-08-25 00:38:09 -04:00
}
static pic_value
2016-06-19 15:49:01 -04:00
read_number(pic_state *pic, pic_value port, int c, struct reader_control *p)
2014-08-25 00:38:09 -04:00
{
2016-06-19 15:49:01 -04:00
pic_value str = read_atom(pic, port, c, p), num;
2014-08-25 00:38:09 -04:00
2016-03-03 05:42:18 -05:00
num = pic_funcall(pic, "picrin.base", "string->number", 1, str);
if (! pic_false_p(pic, num)) {
return num;
2014-08-25 00:38:09 -04:00
}
2016-03-03 05:42:18 -05:00
return pic_intern(pic, str);
2014-08-25 00:38:09 -04:00
}
2016-03-03 05:42:18 -05:00
static unsigned
2016-06-19 15:49:01 -04:00
read_uinteger(pic_state *pic, pic_value port, int c, struct reader_control *PIC_UNUSED(p))
2014-08-25 00:38:09 -04:00
{
2016-03-03 05:42:18 -05:00
unsigned u = 0;
2014-08-25 00:38:09 -04:00
2016-03-03 05:42:18 -05:00
if (! isdigit(c)) {
read_error(pic, "expected one or more digits", pic_list(pic, 1, pic_char_value(pic, c)));
2014-08-25 00:38:09 -04:00
}
2016-03-03 05:42:18 -05:00
u = c - '0';
2016-06-19 15:49:01 -04:00
while (isdigit(c = peek(pic, port))) {
u = u * 10 + next(pic, port) - '0';
2014-08-25 00:38:09 -04:00
}
2016-03-03 05:42:18 -05:00
return u;
2014-08-25 00:38:09 -04:00
}
static pic_value
2016-06-19 15:49:01 -04:00
read_true(pic_state *pic, pic_value port, int c, struct reader_control *PIC_UNUSED(p))
2014-08-25 00:38:09 -04:00
{
2016-06-19 15:49:01 -04:00
if ((c = peek(pic, port)) == 'r') {
if (! expect(pic, port, "rue")) {
read_error(pic, "unexpected character while reading #true", pic_nil_value(pic));
}
} else if (! isdelim(c)) {
2016-02-18 12:29:40 -05:00
read_error(pic, "non-delimiter character given after #t", pic_list(pic, 1, pic_char_value(pic, c)));
}
2014-08-25 00:38:09 -04:00
return pic_true_value(pic);
2014-08-25 00:38:09 -04:00
}
static pic_value
2016-06-19 15:49:01 -04:00
read_false(pic_state *pic, pic_value port, int c, struct reader_control *PIC_UNUSED(p))
2014-08-25 00:38:09 -04:00
{
2016-06-19 15:49:01 -04:00
if ((c = peek(pic, port)) == 'a') {
if (! expect(pic, port, "alse")) {
read_error(pic, "unexpected character while reading #false", pic_nil_value(pic));
}
} else if (! isdelim(c)) {
2016-02-18 12:29:40 -05:00
read_error(pic, "non-delimiter character given after #f", pic_list(pic, 1, pic_char_value(pic, c)));
}
2014-08-25 00:38:09 -04:00
return pic_false_value(pic);
2014-08-25 00:38:09 -04:00
}
static pic_value
2016-06-19 15:49:01 -04:00
read_char(pic_state *pic, pic_value port, int c, struct reader_control *PIC_UNUSED(p))
2014-08-25 00:38:09 -04:00
{
2016-06-19 15:49:01 -04:00
c = next(pic, port);
2014-08-25 00:38:09 -04:00
2016-06-19 15:49:01 -04:00
if (! isdelim(peek(pic, port))) {
2014-08-25 00:38:09 -04:00
switch (c) {
2016-02-18 12:29:40 -05:00
default: read_error(pic, "unexpected character after char literal", pic_list(pic, 1, pic_char_value(pic, c)));
2016-06-19 15:49:01 -04:00
case 'a': c = '\a'; if (! expect(pic, port, "larm")) goto fail; break;
case 'b': c = '\b'; if (! expect(pic, port, "ackspace")) goto fail; break;
case 'd': c = 0x7F; if (! expect(pic, port, "elete")) goto fail; break;
case 'e': c = 0x1B; if (! expect(pic, port, "scape")) goto fail; break;
2014-08-25 00:38:09 -04:00
case 'n':
2016-06-19 15:49:01 -04:00
if ((c = peek(pic, port)) == 'e') {
2014-08-25 00:38:09 -04:00
c = '\n';
2016-06-19 15:49:01 -04:00
if (! expect(pic, port, "ewline"))
2014-08-25 00:38:09 -04:00
goto fail;
} else {
c = '\0';
2016-06-19 15:49:01 -04:00
if (! expect(pic, port, "ull"))
2014-08-25 00:38:09 -04:00
goto fail;
}
break;
2016-06-19 15:49:01 -04:00
case 'r': c = '\r'; if (! expect(pic, port, "eturn")) goto fail; break;
case 's': c = ' '; if (! expect(pic, port, "pace")) goto fail; break;
case 't': c = '\t'; if (! expect(pic, port, "ab")) goto fail; break;
2014-08-25 00:38:09 -04:00
}
}
return pic_char_value(pic, (char)c);
2014-08-25 00:38:09 -04:00
fail:
2016-02-18 12:29:40 -05:00
read_error(pic, "unexpected character while reading character literal", pic_list(pic, 1, pic_char_value(pic, c)));
2014-08-25 00:38:09 -04:00
}
static pic_value
2016-06-19 15:49:01 -04:00
read_string(pic_state *pic, pic_value port, int c, struct reader_control *PIC_UNUSED(p))
2014-08-25 00:38:09 -04:00
{
char *buf;
2015-08-26 06:04:27 -04:00
int size, cnt;
2016-02-19 13:26:52 -05:00
pic_value str;
2014-08-25 00:38:09 -04:00
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 */
2016-06-19 15:49:01 -04:00
while ((c = next(pic, port)) != '"') {
2014-08-25 00:38:09 -04:00
if (c == '\\') {
2016-06-19 15:49:01 -04:00
switch (c = next(pic, port)) {
2014-08-25 00:38:09 -04:00
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';
str = pic_str_value(pic, buf, cnt);
2014-08-25 00:38:09 -04:00
pic_free(pic, buf);
2016-02-19 13:26:52 -05:00
return str;
2014-08-25 00:38:09 -04:00
}
static pic_value
2016-06-19 15:49:01 -04:00
read_pipe(pic_state *pic, pic_value port, int c, struct reader_control *PIC_UNUSED(p))
2014-08-25 00:38:09 -04:00
{
char *buf;
2015-08-26 06:04:27 -04:00
int size, cnt;
2016-02-20 01:31:14 -05:00
pic_value 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;
2016-06-19 15:49:01 -04:00
while ((c = next(pic, port)) != '|') {
2014-08-25 00:38:09 -04:00
if (c == '\\') {
2016-06-19 15:49:01 -04:00
switch ((c = next(pic, port))) {
2014-08-25 00:38:09 -04:00
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;
2016-06-19 15:49:01 -04:00
while ((HEX_BUF[i++] = (char)next(pic, port)) != ';') {
2014-08-25 00:38:09 -04:00
if (i >= sizeof HEX_BUF)
2016-02-18 12:29:40 -05:00
read_error(pic, "expected ';'", pic_list(pic, 1, pic_char_value(pic, HEX_BUF[sizeof(HEX_BUF) - 1])));
2014-08-25 00:38:09 -04:00
}
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';
2016-02-07 14:10:22 -05:00
sym = pic_intern_cstr(pic, buf);
2014-08-25 00:38:09 -04:00
pic_free(pic, buf);
2016-02-20 01:31:14 -05:00
return sym;
2014-08-25 00:38:09 -04:00
}
static pic_value
2016-06-19 15:49:01 -04:00
read_blob(pic_state *pic, pic_value port, int c, struct reader_control *p)
2014-08-25 00:38:09 -04:00
{
int nbits, n;
2016-02-18 09:59:33 -05:00
int len;
2014-09-27 07:43:31 -04:00
unsigned char *dat;
2016-02-19 09:22:41 -05:00
pic_value blob;
2014-08-25 00:38:09 -04:00
nbits = 0;
2016-06-19 15:49:01 -04:00
while (isdigit(c = next(pic, port))) {
2014-08-25 00:38:09 -04:00
nbits = 10 * nbits + c - '0';
}
if (nbits != 8) {
2016-02-18 12:29:40 -05:00
read_error(pic, "unsupported bytevector bit width", pic_list(pic, 1, pic_int_value(pic, nbits)));
2014-08-25 00:38:09 -04:00
}
if (c != '(') {
2016-02-18 12:29:40 -05:00
read_error(pic, "expected '(' character", pic_list(pic, 1, pic_char_value(pic, c)));
2014-08-25 00:38:09 -04:00
}
len = 0;
dat = NULL;
2016-06-19 15:49:01 -04:00
c = next(pic, port);
while ((c = skip(pic, port, c)) != ')') {
n = read_uinteger(pic, port, c, p);
2014-08-25 00:38:09 -04:00
if (n < 0 || (1 << nbits) <= n) {
2016-02-18 12:29:40 -05:00
read_error(pic, "invalid element in bytevector literal", pic_list(pic, 1, pic_int_value(pic, n)));
2014-08-25 00:38:09 -04:00
}
len += 1;
dat = pic_realloc(pic, dat, len);
2014-09-27 07:43:31 -04:00
dat[len - 1] = (unsigned char)n;
2016-06-19 15:49:01 -04:00
c = next(pic, port);
2014-08-25 00:38:09 -04:00
}
2016-02-18 09:59:33 -05:00
blob = pic_blob_value(pic, dat, len);
2014-08-25 00:38:09 -04:00
pic_free(pic, dat);
2016-02-19 09:22:41 -05:00
return blob;
2014-08-25 00:38:09 -04:00
}
2015-06-09 03:19:57 -04:00
static pic_value
2016-06-19 15:49:01 -04:00
read_undef_or_blob(pic_state *pic, pic_value port, int c, struct reader_control *p)
2015-06-09 03:19:57 -04:00
{
2016-06-19 15:49:01 -04:00
if ((c = peek(pic, port)) == 'n') {
if (! expect(pic, port, "ndefined")) {
read_error(pic, "unexpected character while reading #undefined", pic_nil_value(pic));
2015-06-09 03:19:57 -04:00
}
return pic_undef_value(pic);
2015-06-09 03:19:57 -04:00
}
if (! isdigit(c)) {
2016-02-18 12:29:40 -05:00
read_error(pic, "expect #undefined or #u8(...), but illegal character given", pic_list(pic, 1, pic_char_value(pic, c)));
2015-06-09 03:19:57 -04:00
}
2016-06-19 15:49:01 -04:00
return read_blob(pic, port, 'u', p);
2015-06-09 03:19:57 -04:00
}
2014-08-25 00:38:09 -04:00
static pic_value
2016-06-19 15:49:01 -04:00
read_pair(pic_state *pic, pic_value port, int c, struct reader_control *p)
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:
2016-06-19 15:49:01 -04:00
c = skip(pic, port, ' ');
2014-08-25 00:38:09 -04:00
if (c == tCLOSE) {
return pic_nil_value(pic);
2014-08-25 00:38:09 -04:00
}
2016-06-19 15:49:01 -04:00
if (c == '.' && isdelim(peek(pic, port))) {
cdr = read_value(pic, port, next(pic, port), p);
2014-08-25 00:38:09 -04:00
closing:
2016-06-19 15:49:01 -04:00
if ((c = skip(pic, port, ' ')) != tCLOSE) {
if (pic_invalid_p(pic, read_nullable(pic, port, c, p))) {
2014-08-25 00:38:09 -04:00
goto closing;
}
read_error(pic, "unmatched parenthesis", pic_nil_value(pic));
2014-08-25 00:38:09 -04:00
}
return cdr;
}
else {
2016-06-19 15:49:01 -04:00
car = read_nullable(pic, port, c, p);
2014-08-25 00:38:09 -04:00
if (pic_invalid_p(pic, car)) {
2014-08-25 00:38:09 -04:00
goto retry;
}
2016-06-19 15:49:01 -04:00
cdr = read_pair(pic, port, '(', p);
2014-08-25 00:38:09 -04:00
return pic_cons(pic, car, cdr);
}
}
static pic_value
2016-06-19 15:49:01 -04:00
read_vector(pic_state *pic, pic_value port, int c, struct reader_control *p)
2014-08-25 00:38:09 -04:00
{
2016-02-19 07:56:45 -05:00
pic_value list, it, elem, vec;
2015-08-26 06:04:27 -04:00
int i = 0;
2014-08-25 00:38:09 -04:00
2016-06-19 15:49:01 -04:00
list = read_value(pic, port, c, p);
2014-08-25 00:38:09 -04:00
2016-02-19 03:38:49 -05:00
vec = pic_make_vec(pic, pic_length(pic, list), NULL);
2015-07-12 19:28:21 -04:00
pic_for_each (elem, list, it) {
2016-02-19 07:56:45 -05:00
pic_vec_set(pic, vec, i++, elem);
2015-07-12 19:28:21 -04:00
}
2016-02-19 07:56:45 -05:00
return vec;
2014-08-25 00:38:09 -04:00
}
static pic_value
2016-06-19 15:49:01 -04:00
read_label_set(pic_state *pic, pic_value port, int i, struct reader_control *p)
2014-08-25 00:38:09 -04:00
{
2016-02-21 04:28:59 -05:00
khash_t(read) *h = &p->labels;
2014-08-25 00:38:09 -04:00
pic_value val;
2016-02-21 04:28:59 -05:00
int c, ret, it;
2015-06-24 18:34:10 -04:00
it = kh_put(read, h, i, &ret);
2014-08-25 00:38:09 -04:00
2016-06-19 15:49:01 -04:00
switch ((c = skip(pic, port, ' '))) {
2015-01-25 22:29:29 -05:00
case '(':
2014-08-25 00:38:09 -04:00
{
pic_value tmp;
kh_val(h, it) = val = pic_cons(pic, pic_undef_value(pic), pic_undef_value(pic));
2014-08-25 00:38:09 -04:00
2016-06-19 15:49:01 -04:00
tmp = read_value(pic, port, c, p);
2016-02-19 08:09:06 -05:00
pic_pair_ptr(pic, val)->car = pic_car(pic, tmp);
pic_pair_ptr(pic, val)->cdr = pic_cdr(pic, tmp);
2014-08-25 00:38:09 -04:00
return val;
}
case '#':
{
bool vect;
2016-06-19 15:49:01 -04:00
if (peek(pic, port) == '(') {
2014-08-25 00:38:09 -04:00
vect = true;
} else {
vect = false;
}
if (vect) {
2016-02-19 07:56:45 -05:00
pic_value tmp;
2014-08-25 00:38:09 -04:00
2016-02-19 07:56:45 -05:00
kh_val(h, it) = val = pic_make_vec(pic, 0, NULL);
2014-08-25 00:38:09 -04:00
2016-06-19 15:49:01 -04:00
tmp = read_value(pic, port, c, p);
2016-02-19 07:56:45 -05:00
PIC_SWAP(pic_value *, pic_vec_ptr(pic, tmp)->data, pic_vec_ptr(pic, val)->data);
PIC_SWAP(int, pic_vec_ptr(pic, tmp)->len, pic_vec_ptr(pic, val)->len);
2014-08-25 00:38:09 -04:00
return val;
}
2016-06-19 05:27:24 -04:00
/* fall through */
2014-08-25 00:38:09 -04:00
}
default:
{
2016-06-19 15:49:01 -04:00
kh_val(h, it) = val = read_value(pic, port, c, p);
2014-08-25 00:38:09 -04:00
return val;
}
}
}
static pic_value
2016-06-19 15:49:01 -04:00
read_label_ref(pic_state *pic, pic_value PIC_UNUSED(port), int i, struct reader_control *p)
2014-08-25 00:38:09 -04:00
{
2016-02-21 04:28:59 -05:00
khash_t(read) *h = &p->labels;
2016-02-20 11:52:34 -05:00
int it;
2014-08-25 00:38:09 -04:00
2015-06-24 18:34:10 -04:00
it = kh_get(read, h, i);
if (it == kh_end(h)) {
2016-02-18 12:29:40 -05:00
read_error(pic, "label of given index not defined", pic_list(pic, 1, pic_int_value(pic, i)));
2014-08-25 00:38:09 -04:00
}
2015-06-24 18:34:10 -04:00
return kh_val(h, it);
2014-08-25 00:38:09 -04:00
}
static pic_value
2016-06-19 15:49:01 -04:00
read_label(pic_state *pic, pic_value port, int c, struct reader_control *p)
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';
2016-06-19 15:49:01 -04:00
} while (isdigit(c = next(pic, port)));
2014-08-25 00:38:09 -04:00
if (c == '=') {
2016-06-19 15:49:01 -04:00
return read_label_set(pic, port, i, p);
2014-08-25 00:38:09 -04:00
}
if (c == '#') {
2016-06-19 15:49:01 -04:00
return read_label_ref(pic, port, i, p);
2014-08-25 00:38:09 -04:00
}
read_error(pic, "broken label expression", pic_nil_value(pic));
2014-08-25 00:38:09 -04:00
}
static pic_value
2016-06-19 15:49:01 -04:00
read_unmatch(pic_state *pic, pic_value PIC_UNUSED(port), int PIC_UNUSED(c), struct reader_control *PIC_UNUSED(p))
2014-08-25 00:38:09 -04:00
{
read_error(pic, "unmatched parenthesis", pic_nil_value(pic));
2014-08-25 00:38:09 -04:00
}
static pic_value
2016-06-19 15:49:01 -04:00
read_dispatch(pic_state *pic, pic_value port, int c, struct reader_control *p)
2014-08-25 00:38:09 -04:00
{
2016-06-19 15:49:01 -04:00
c = next(pic, port);
2014-08-25 00:38:09 -04:00
if (c == EOF) {
read_error(pic, "unexpected EOF", pic_nil_value(pic));
2014-08-25 00:38:09 -04:00
}
2016-02-21 04:28:59 -05:00
if (reader_dispatch[c] == NULL) {
2016-02-18 12:29:40 -05:00
read_error(pic, "invalid character at the seeker head", pic_list(pic, 1, pic_char_value(pic, c)));
2014-08-25 00:38:09 -04:00
}
2016-06-19 15:49:01 -04:00
return reader_dispatch[c](pic, port, c, p);
}
2014-08-25 00:38:09 -04:00
static pic_value
2016-06-19 15:49:01 -04:00
read_nullable(pic_state *pic, pic_value port, int c, struct reader_control *p)
{
2016-06-19 15:49:01 -04:00
c = skip(pic, port, c);
2014-08-25 00:38:09 -04:00
if (c == EOF) {
read_error(pic, "unexpected EOF", pic_nil_value(pic));
2014-08-25 00:38:09 -04:00
}
2016-02-21 04:28:59 -05:00
if (reader_table[c] == NULL) {
2016-02-18 12:29:40 -05:00
read_error(pic, "invalid character at the seeker head", pic_list(pic, 1, pic_char_value(pic, c)));
2014-08-25 00:38:09 -04:00
}
2016-06-19 15:49:01 -04:00
return reader_table[c](pic, port, c, p);
2014-08-25 00:38:09 -04:00
}
static pic_value
2016-06-19 15:49:01 -04:00
read_value(pic_state *pic, pic_value port, int c, struct reader_control *p)
2014-08-25 00:38:09 -04:00
{
pic_value val;
retry:
2016-06-19 15:49:01 -04:00
val = read_nullable(pic, port, c, p);
2014-08-25 00:38:09 -04:00
if (pic_invalid_p(pic, val)) {
2016-06-19 15:49:01 -04:00
c = next(pic, port);
2014-08-25 00:38:09 -04:00
goto retry;
}
return val;
}
static void
2016-02-21 04:28:59 -05:00
reader_table_init(void)
2014-08-25 00:38:09 -04:00
{
int c;
2016-02-21 04:28:59 -05:00
for (c = 0; c < 256; ++c) {
reader_table[c] = NULL;
}
for (c = 0; c < 256; ++c) {
reader_dispatch[c] = NULL;
}
2014-08-25 00:38:09 -04:00
/* default reader */
for (c = 1; c < 256; ++c) {
2016-02-21 04:28:59 -05:00
reader_table[c] = read_symbol;
}
2016-02-21 04:28:59 -05:00
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_pair;
reader_table['#'] = read_dispatch;
2016-03-03 05:42:18 -05:00
reader_table['+'] = read_number;
reader_table['-'] = read_number;
for (c = '0'; c <= '9'; ++c) {
2016-02-21 04:28:59 -05:00
reader_table[c] = read_number;
2014-08-25 00:38:09 -04:00
}
2016-02-21 04:28:59 -05: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;
reader_dispatch['\''] = read_syntax_quote;
reader_dispatch['`'] = read_syntax_quasiquote;
reader_dispatch[','] = read_syntax_unquote;
reader_dispatch['\\'] = read_char;
reader_dispatch['('] = read_vector;
reader_dispatch['u'] = read_undef_or_blob;
/* read labels */
for (c = '0'; c <= '9'; ++c) {
2016-02-21 04:28:59 -05:00
reader_dispatch[c] = read_label;
2014-08-25 00:38:09 -04:00
}
}
2016-02-21 04:28:59 -05:00
static void
2016-02-21 05:19:35 -05:00
reader_init(pic_state *PIC_UNUSED(pic), struct reader_control *p)
{
2016-02-21 04:28:59 -05:00
p->typecase = CASE_DEFAULT;
kh_init(read, &p->labels);
}
2016-02-21 04:28:59 -05:00
static void
reader_destroy(pic_state *pic, struct reader_control *p)
{
2016-02-21 04:28:59 -05:00
kh_destroy(read, &p->labels);
}
2014-08-25 00:38:09 -04:00
pic_value
2016-02-20 02:51:24 -05:00
pic_read(pic_state *pic, pic_value port)
2014-08-25 00:38:09 -04:00
{
2016-02-21 04:28:59 -05:00
struct reader_control p;
2016-02-19 02:17:13 -05:00
size_t ai = pic_enter(pic);
2014-08-25 00:38:09 -04:00
pic_value val;
2015-06-28 13:04:55 -04:00
int c;
pic_value e;
2014-08-25 00:38:09 -04:00
2016-02-21 04:28:59 -05:00
reader_init(pic, &p);
2014-08-25 00:38:09 -04:00
2016-02-21 04:28:59 -05:00
pic_try {
2016-06-19 15:49:01 -04:00
while ((c = skip(pic, port, next(pic, port))) != EOF) {
val = read_nullable(pic, port, c, &p);
2016-02-21 04:28:59 -05:00
if (! pic_invalid_p(pic, val)) {
break;
}
pic_leave(pic, ai);
}
if (c == EOF) {
val = pic_eof_object(pic);
2015-06-28 13:04:55 -04:00
}
}
pic_catch(e) {
2016-02-21 04:28:59 -05:00
reader_destroy(pic, &p);
pic_raise(pic, e);
2014-08-25 00:38:09 -04:00
}
2016-02-19 02:17:13 -05:00
pic_leave(pic, ai);
return pic_protect(pic, val);
2014-08-25 00:38:09 -04:00
}
pic_value
pic_read_cstr(pic_state *pic, const char *str)
{
2016-06-19 15:49:01 -04:00
pic_value port = pic_fmemopen(pic, str, strlen(str), "r");
pic_value form, e;
2014-08-25 00:38:09 -04:00
2015-06-26 10:45:56 -04:00
pic_try {
form = pic_read(pic, port);
}
pic_catch(e) {
2016-06-19 15:49:01 -04:00
pic_fclose(pic, port);
pic_raise(pic, e);
2015-06-26 10:45:56 -04:00
}
2014-08-25 00:38:09 -04:00
2016-06-19 15:49:01 -04:00
pic_fclose(pic, port);
2015-05-28 10:28:55 -04:00
return form;
2014-08-25 00:38:09 -04:00
}
static pic_value
pic_read_read(pic_state *pic)
{
2016-02-20 02:51:24 -05:00
pic_value port = pic_stdin(pic);
2014-08-25 00:38:09 -04:00
pic_get_args(pic, "|p", &port);
return pic_read(pic, port);
}
void
pic_init_read(pic_state *pic)
{
2016-02-21 04:28:59 -05:00
reader_table_init();
2014-08-31 22:37:52 -04:00
pic_defun(pic, "read", pic_read_read);
2014-08-25 00:38:09 -04:00
}