+++ /dev/null
-/*
- * Copyright © 2016 Keith Packard <keithp@keithp.com>
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation, either version 2 of the License, or
- * (at your option) any later version.
- *
- * This program is distributed in the hope that it will be useful, but
- * WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- * General Public License for more details.
- */
-
-#include "ao_scheme.h"
-#include "ao_scheme_read.h"
-#include <math.h>
-#include <stdlib.h>
-
-static const uint16_t lex_classes[128] = {
- IGNORE, /* ^@ */
- IGNORE, /* ^A */
- IGNORE, /* ^B */
- IGNORE, /* ^C */
- IGNORE, /* ^D */
- IGNORE, /* ^E */
- IGNORE, /* ^F */
- IGNORE, /* ^G */
- IGNORE, /* ^H */
- WHITE, /* ^I */
- WHITE, /* ^J */
- WHITE, /* ^K */
- WHITE, /* ^L */
- WHITE, /* ^M */
- IGNORE, /* ^N */
- IGNORE, /* ^O */
- IGNORE, /* ^P */
- IGNORE, /* ^Q */
- IGNORE, /* ^R */
- IGNORE, /* ^S */
- IGNORE, /* ^T */
- IGNORE, /* ^U */
- IGNORE, /* ^V */
- IGNORE, /* ^W */
- IGNORE, /* ^X */
- IGNORE, /* ^Y */
- IGNORE, /* ^Z */
- IGNORE, /* ^[ */
- IGNORE, /* ^\ */
- IGNORE, /* ^] */
- IGNORE, /* ^^ */
- IGNORE, /* ^_ */
- PRINTABLE|WHITE, /* */
- PRINTABLE, /* ! */
- PRINTABLE|STRINGC, /* " */
- PRINTABLE, /* # */
- PRINTABLE, /* $ */
- PRINTABLE, /* % */
- PRINTABLE, /* & */
- PRINTABLE|SPECIAL, /* ' */
- PRINTABLE|SPECIAL, /* ( */
- PRINTABLE|SPECIAL, /* ) */
- PRINTABLE, /* * */
- PRINTABLE|SIGN, /* + */
- PRINTABLE|SPECIAL_QUASI, /* , */
- PRINTABLE|SIGN, /* - */
- PRINTABLE|SPECIAL|FLOATC, /* . */
- PRINTABLE, /* / */
- PRINTABLE|DIGIT, /* 0 */
- PRINTABLE|DIGIT, /* 1 */
- PRINTABLE|DIGIT, /* 2 */
- PRINTABLE|DIGIT, /* 3 */
- PRINTABLE|DIGIT, /* 4 */
- PRINTABLE|DIGIT, /* 5 */
- PRINTABLE|DIGIT, /* 6 */
- PRINTABLE|DIGIT, /* 7 */
- PRINTABLE|DIGIT, /* 8 */
- PRINTABLE|DIGIT, /* 9 */
- PRINTABLE, /* : */
- PRINTABLE|COMMENT, /* ; */
- PRINTABLE, /* < */
- PRINTABLE, /* = */
- PRINTABLE, /* > */
- PRINTABLE, /* ? */
- PRINTABLE, /* @ */
- PRINTABLE|ALPHA|HEX_LETTER, /* A */
- PRINTABLE|ALPHA|HEX_LETTER, /* B */
- PRINTABLE|ALPHA|HEX_LETTER, /* C */
- PRINTABLE|ALPHA|HEX_LETTER, /* D */
- PRINTABLE|ALPHA|FLOATC|HEX_LETTER,/* E */
- PRINTABLE|ALPHA|HEX_LETTER, /* F */
- PRINTABLE|ALPHA, /* G */
- PRINTABLE|ALPHA, /* H */
- PRINTABLE|ALPHA, /* I */
- PRINTABLE|ALPHA, /* J */
- PRINTABLE|ALPHA, /* K */
- PRINTABLE|ALPHA, /* L */
- PRINTABLE|ALPHA, /* M */
- PRINTABLE|ALPHA, /* N */
- PRINTABLE|ALPHA, /* O */
- PRINTABLE|ALPHA, /* P */
- PRINTABLE|ALPHA, /* Q */
- PRINTABLE|ALPHA, /* R */
- PRINTABLE|ALPHA, /* S */
- PRINTABLE|ALPHA, /* T */
- PRINTABLE|ALPHA, /* U */
- PRINTABLE|ALPHA, /* V */
- PRINTABLE|ALPHA, /* W */
- PRINTABLE|ALPHA, /* X */
- PRINTABLE|ALPHA, /* Y */
- PRINTABLE|ALPHA, /* Z */
- PRINTABLE, /* [ */
- PRINTABLE, /* \ */
- PRINTABLE, /* ] */
- PRINTABLE, /* ^ */
- PRINTABLE, /* _ */
- PRINTABLE|SPECIAL_QUASI, /* ` */
- PRINTABLE|ALPHA|HEX_LETTER, /* a */
- PRINTABLE|ALPHA|HEX_LETTER, /* b */
- PRINTABLE|ALPHA|HEX_LETTER, /* c */
- PRINTABLE|ALPHA|HEX_LETTER, /* d */
- PRINTABLE|ALPHA|FLOATC|HEX_LETTER,/* e */
- PRINTABLE|ALPHA|HEX_LETTER, /* f */
- PRINTABLE|ALPHA, /* g */
- PRINTABLE|ALPHA, /* h */
- PRINTABLE|ALPHA, /* i */
- PRINTABLE|ALPHA, /* j */
- PRINTABLE|ALPHA, /* k */
- PRINTABLE|ALPHA, /* l */
- PRINTABLE|ALPHA, /* m */
- PRINTABLE|ALPHA, /* n */
- PRINTABLE|ALPHA, /* o */
- PRINTABLE|ALPHA, /* p */
- PRINTABLE|ALPHA, /* q */
- PRINTABLE|ALPHA, /* r */
- PRINTABLE|ALPHA, /* s */
- PRINTABLE|ALPHA, /* t */
- PRINTABLE|ALPHA, /* u */
- PRINTABLE|ALPHA, /* v */
- PRINTABLE|ALPHA, /* w */
- PRINTABLE|ALPHA, /* x */
- PRINTABLE|ALPHA, /* y */
- PRINTABLE|ALPHA, /* z */
- PRINTABLE, /* { */
- PRINTABLE, /* | */
- PRINTABLE, /* } */
- PRINTABLE, /* ~ */
- IGNORE, /* ^? */
-};
-
-static int lex_unget_c;
-
-#ifndef ao_scheme_getc
-#define ao_scheme_getc(f) getc(f)
-#endif
-
-static inline int
-lex_get(FILE *in)
-{
- int c;
- if (lex_unget_c) {
- c = lex_unget_c;
- lex_unget_c = 0;
- } else {
- c = ao_scheme_getc(in);
- }
- return c;
-}
-
-static inline void
-lex_unget(int c)
-{
- if (c != EOF)
- lex_unget_c = c;
-}
-
-static uint16_t lex_class;
-
-static int
-lexc(FILE *in)
-{
- int c;
- do {
- c = lex_get(in);
- if (c == EOF) {
- c = 0;
- lex_class = ENDOFFILE;
- } else {
- lex_class = PRINTABLE;
- if (c <= 0x7f)
- lex_class = lex_classes[c];
- }
- } while (lex_class & IGNORE);
- return c;
-}
-
-static int
-lex_quoted(FILE *in)
-{
- int c;
- int v;
- int count;
-
- c = lex_get(in);
- if (c == EOF) {
- eof:
- lex_class = ENDOFFILE;
- return 0;
- }
- lex_class = 0;
- c &= 0x7f;
- switch (c) {
- case 'a':
- return '\a';
- case 'b':
- return '\b';
- case 't':
- return '\t';
- case 'n':
- return '\n';
- case 'r':
- return '\r';
- case 'f':
- return '\f';
- case 'v':
- return '\v';
- case '0':
- case '1':
- case '2':
- case '3':
- case '4':
- case '5':
- case '6':
- case '7':
- v = c - '0';
- count = 1;
- while (count <= 3) {
- c = lex_get(in);
- if (c == EOF)
- goto eof;
- c &= 0x7f;
- if (c < '0' || '7' < c) {
- lex_unget(c);
- break;
- }
- v = (v << 3) + c - '0';
- ++count;
- }
- return v;
- default:
- return c;
- }
-}
-
-#ifndef AO_SCHEME_TOKEN_MAX
-#define AO_SCHEME_TOKEN_MAX 128
-#endif
-
-static char token_string[AO_SCHEME_TOKEN_MAX];
-static int32_t token_int;
-static int token_len;
-
-static void start_token(void) {
- token_len = 0;
-}
-
-static void add_token(int c) {
- if (c && token_len < AO_SCHEME_TOKEN_MAX - 1)
- token_string[token_len++] = c;
-}
-
-static void end_token(void) {
- token_string[token_len] = '\0';
-}
-
-#ifdef AO_SCHEME_FEATURE_FLOAT
-static float token_float;
-
-struct namedfloat {
- const char *name;
- float value;
-};
-
-static const struct namedfloat namedfloats[] = {
- { .name = "+inf.0", .value = INFINITY },
- { .name = "-inf.0", .value = -INFINITY },
- { .name = "+nan.0", .value = NAN },
- { .name = "-nan.0", .value = NAN },
-};
-
-#define NUM_NAMED_FLOATS (sizeof namedfloats / sizeof namedfloats[0])
-#endif
-
-static int
-parse_int(FILE *in, int base)
-{
- int cval;
- int c;
-
- token_int = 0;
- for (;;) {
- c = lexc(in);
- if ((lex_class & HEX_DIGIT) == 0) {
- lex_unget(c);
- return NUM;
- }
- if ('0' <= c && c <= '9')
- cval = c - '0';
- else
- cval = (c | ('a' - 'A')) - 'a' + 10;
- token_int = token_int * base + cval;
- }
- return NUM;
-}
-
-static int
-_lex(FILE *in)
-{
- int c;
-
- start_token();
- for (;;) {
- c = lexc(in);
- if (lex_class & ENDOFFILE)
- return END;
-
- if (lex_class & WHITE)
- continue;
-
- if (lex_class & COMMENT) {
- while ((c = lexc(in)) != '\n') {
- if (lex_class & ENDOFFILE)
- return END;
- }
- continue;
- }
-
- if (lex_class & SPECIAL) {
- switch (c) {
- case '(':
- case '[':
- return OPEN;
- case ')':
- case ']':
- return CLOSE;
- case '\'':
- return QUOTE;
- case '.':
- return DOT;
-#ifdef AO_SCHEME_FEATURE_QUASI
- case '`':
- return QUASIQUOTE;
- case ',':
- c = lexc(in);
- if (c == '@') {
- return UNQUOTE_SPLICING;
- } else {
- lex_unget(c);
- return UNQUOTE;
- }
-#endif
- }
- }
- if (c == '#') {
- c = lexc(in);
- switch (c) {
- case 't':
- return TRUE_TOKEN;
- case 'f':
- return FALSE_TOKEN;
-#ifdef AO_SCHEME_FEATURE_VECTOR
- case '(':
- return OPEN_VECTOR;
-#endif
- case '\\':
- for (;;) {
- c = lexc(in);
- if (token_len == 0) {
- add_token(c);
- if (!(lex_class & ALPHA))
- break;
- } else {
- if (lex_class & ALPHA)
- add_token(c);
- else {
- lex_unget(c);
- break;
- }
- }
- }
- end_token();
- if (token_len == 1)
- token_int = token_string[0];
- else if (!strcmp(token_string, "space"))
- token_int = ' ';
- else if (!strcmp(token_string, "newline"))
- token_int = '\n';
- else if (!strcmp(token_string, "tab"))
- token_int = '\t';
- else if (!strcmp(token_string, "return"))
- token_int = '\r';
- else if (!strcmp(token_string, "formfeed"))
- token_int = '\f';
- else {
- ao_scheme_error(AO_SCHEME_INVALID, "invalid character token #\\%s", token_string);
- continue;
- }
- return NUM;
- case 'x':
- return parse_int(in, 16);
- case 'o':
- return parse_int(in, 8);
- case 'b':
- return parse_int(in, 2);
- }
- }
- if (lex_class & STRINGC) {
- for (;;) {
- c = lexc(in);
- if (c == '\\')
- c = lex_quoted(in);
- if (lex_class & (STRINGC|ENDOFFILE)) {
- end_token();
- return STRING;
- }
- add_token(c);
- }
- }
- if (lex_class & PRINTABLE) {
-#ifdef AO_SCHEME_FEATURE_FLOAT
- int isfloat = 1;
- int epos = 0;
-#endif
- int hasdigit = 0;
- int isneg = 0;
- int isint = 1;
-
- token_int = 0;
- for (;;) {
- if (!(lex_class & NUMBER)) {
- isint = 0;
-#ifdef AO_SCHEME_FEATURE_FLOAT
- isfloat = 0;
-#endif
- } else {
-#ifdef AO_SCHEME_FEATURE_FLOAT
- if (!(lex_class & INTEGER))
- isint = 0;
- if (token_len != epos &&
- (lex_class & SIGN))
- {
- isint = 0;
- isfloat = 0;
- }
-#endif
- if (c == '-')
- isneg = 1;
-#ifdef AO_SCHEME_FEATURE_FLOAT
- if (c == '.' && epos != 0)
- isfloat = 0;
- if (c == 'e' || c == 'E') {
- if (token_len == 0)
- isfloat = 0;
- else
- epos = token_len + 1;
- }
-#endif
- if (lex_class & DIGIT) {
- hasdigit = 1;
- if (isint)
- token_int = token_int * 10 + c - '0';
- }
- }
- add_token (c);
- c = lexc (in);
- if ((lex_class & (NOTNAME))
-#ifdef AO_SCHEME_FEATURE_FLOAT
- && (c != '.' || !isfloat)
-#endif
- ) {
-#ifdef AO_SCHEME_FEATURE_FLOAT
- unsigned int u;
-#endif
- lex_unget(c);
- end_token ();
- if (isint && hasdigit) {
- if (isneg)
- token_int = -token_int;
- return NUM;
- }
-#ifdef AO_SCHEME_FEATURE_FLOAT
- if (isfloat && hasdigit) {
- token_float = strtof(token_string, NULL);
- return FLOAT;
- }
- for (u = 0; u < NUM_NAMED_FLOATS; u++)
- if (!strcmp(namedfloats[u].name, token_string)) {
- token_float = namedfloats[u].value;
- return FLOAT;
- }
-#endif
- return NAME;
- }
- }
- }
- }
-}
-
-static inline int lex(FILE *in)
-{
- int parse_token = _lex(in);
- RDBGI("token %d \"%s\"\n", parse_token, token_string);
- return parse_token;
-}
-
-static int parse_token;
-
-int ao_scheme_read_list;
-struct ao_scheme_cons *ao_scheme_read_cons;
-struct ao_scheme_cons *ao_scheme_read_cons_tail;
-struct ao_scheme_cons *ao_scheme_read_stack;
-static int ao_scheme_read_state;
-
-#define READ_IN_QUOTE 0x01
-#define READ_SAW_DOT 0x02
-#define READ_DONE_DOT 0x04
-#define READ_SAW_VECTOR 0x08
-
-static int
-push_read_stack(int read_state)
-{
- RDBGI("push read stack %p 0x%x\n", ao_scheme_read_cons, read_state);
- RDBG_IN();
- if (ao_scheme_read_list) {
- ao_scheme_read_stack = ao_scheme_cons_cons(ao_scheme_cons_poly(ao_scheme_read_cons),
- ao_scheme_cons(ao_scheme_int_poly(read_state),
- ao_scheme_cons_poly(ao_scheme_read_stack)));
- if (!ao_scheme_read_stack)
- return 0;
- } else
- ao_scheme_read_state = read_state;
- ao_scheme_read_cons = NULL;
- ao_scheme_read_cons_tail = NULL;
- return 1;
-}
-
-static int
-pop_read_stack(void)
-{
- int read_state = 0;
- if (ao_scheme_read_list) {
- ao_scheme_read_cons = ao_scheme_poly_cons(ao_scheme_read_stack->car);
- ao_scheme_read_stack = ao_scheme_poly_cons(ao_scheme_read_stack->cdr);
- read_state = ao_scheme_poly_int(ao_scheme_read_stack->car);
- ao_scheme_read_stack = ao_scheme_poly_cons(ao_scheme_read_stack->cdr);
- for (ao_scheme_read_cons_tail = ao_scheme_read_cons;
- ao_scheme_read_cons_tail && ao_scheme_read_cons_tail->cdr;
- ao_scheme_read_cons_tail = ao_scheme_poly_cons(ao_scheme_read_cons_tail->cdr))
- ;
- } else {
- read_state = ao_scheme_read_state;
- ao_scheme_read_cons = NULL;
- ao_scheme_read_cons_tail = NULL;
- ao_scheme_read_stack = NULL;
- ao_scheme_read_state = 0;
- }
- RDBG_OUT();
- RDBGI("pop read stack %p %d\n", ao_scheme_read_cons, read_state);
- return read_state;
-}
-
-#ifdef AO_SCHEME_FEATURE_VECTOR
-#define is_open(t) ((t) == OPEN || (t) == OPEN_VECTOR)
-#else
-#define is_open(t) ((t) == OPEN)
-#endif
-
-ao_poly
-ao_scheme_read(FILE *in)
-{
- struct ao_scheme_atom *atom;
- struct ao_scheme_string *string;
- int read_state;
- ao_poly v = AO_SCHEME_NIL;
-
- ao_scheme_read_list = 0;
- read_state = 0;
- ao_scheme_read_cons = ao_scheme_read_cons_tail = ao_scheme_read_stack = NULL;
- for (;;) {
- parse_token = lex(in);
- while (is_open(parse_token)) {
-#ifdef AO_SCHEME_FEATURE_VECTOR
- if (parse_token == OPEN_VECTOR)
- read_state |= READ_SAW_VECTOR;
-#endif
- if (!push_read_stack(read_state))
- return AO_SCHEME_NIL;
- ao_scheme_read_list++;
- read_state = 0;
- parse_token = lex(in);
- }
-
- switch (parse_token) {
- case END:
- default:
- if (ao_scheme_read_list)
- ao_scheme_error(AO_SCHEME_EOF, "unexpected end of file");
- return _ao_scheme_atom_eof;
- break;
- case NAME:
- atom = ao_scheme_atom_intern(token_string);
- if (atom)
- v = ao_scheme_atom_poly(atom);
- else
- v = AO_SCHEME_NIL;
- break;
- case NUM:
- v = ao_scheme_integer_poly(token_int);
- break;
-#ifdef AO_SCHEME_FEATURE_FLOAT
- case FLOAT:
- v = ao_scheme_float_get(token_float);
- break;
-#endif
- case TRUE_TOKEN:
- v = _ao_scheme_bool_true;
- break;
- case FALSE_TOKEN:
- v = _ao_scheme_bool_false;
- break;
- case STRING:
- string = ao_scheme_string_new(token_string);
- if (string)
- v = ao_scheme_string_poly(string);
- else
- v = AO_SCHEME_NIL;
- break;
- case QUOTE:
-#ifdef AO_SCHEME_FEATURE_QUASI
- case QUASIQUOTE:
- case UNQUOTE:
- case UNQUOTE_SPLICING:
-#endif
- if (!push_read_stack(read_state))
- return AO_SCHEME_NIL;
- ao_scheme_read_list++;
- read_state = READ_IN_QUOTE;
- switch (parse_token) {
- case QUOTE:
- v = _ao_scheme_atom_quote;
- break;
-#ifdef AO_SCHEME_FEATURE_QUASI
- case QUASIQUOTE:
- v = _ao_scheme_atom_quasiquote;
- break;
- case UNQUOTE:
- v = _ao_scheme_atom_unquote;
- break;
- case UNQUOTE_SPLICING:
- v = _ao_scheme_atom_unquote2dsplicing;
- break;
-#endif
- }
- break;
- case CLOSE:
- if (!ao_scheme_read_list) {
- v = AO_SCHEME_NIL;
- break;
- }
- v = ao_scheme_cons_poly(ao_scheme_read_cons);
- --ao_scheme_read_list;
- read_state = pop_read_stack();
-#ifdef AO_SCHEME_FEATURE_VECTOR
- if (read_state & READ_SAW_VECTOR) {
- v = ao_scheme_vector_poly(ao_scheme_list_to_vector(ao_scheme_poly_cons(v)));
- read_state &= ~READ_SAW_VECTOR;
- }
-#endif
- break;
- case DOT:
- if (!ao_scheme_read_list) {
- ao_scheme_error(AO_SCHEME_INVALID, ". outside of cons");
- return AO_SCHEME_NIL;
- }
- if (!ao_scheme_read_cons) {
- ao_scheme_error(AO_SCHEME_INVALID, ". first in cons");
- return AO_SCHEME_NIL;
- }
- read_state |= READ_SAW_DOT;
- continue;
- }
-
- /* loop over QUOTE ends */
- for (;;) {
- if (!ao_scheme_read_list)
- return v;
-
- if (read_state & READ_DONE_DOT) {
- ao_scheme_error(AO_SCHEME_INVALID, ". not last in cons");
- return AO_SCHEME_NIL;
- }
-
- if (read_state & READ_SAW_DOT) {
- read_state |= READ_DONE_DOT;
- ao_scheme_read_cons_tail->cdr = v;
- } else {
- struct ao_scheme_cons *read = ao_scheme_cons_cons(v, AO_SCHEME_NIL);
- if (!read)
- return AO_SCHEME_NIL;
-
- if (ao_scheme_read_cons_tail)
- ao_scheme_read_cons_tail->cdr = ao_scheme_cons_poly(read);
- else
- ao_scheme_read_cons = read;
- ao_scheme_read_cons_tail = read;
- }
-
- if (!(read_state & READ_IN_QUOTE) || !ao_scheme_read_cons->cdr)
- break;
-
- v = ao_scheme_cons_poly(ao_scheme_read_cons);
- --ao_scheme_read_list;
- read_state = pop_read_stack();
- }
- }
- return v;
-}
projects / fw / altos / blobdiff