Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Branch: master
Fetching contributors…

Cannot retrieve contributors at this time

617 lines (537 sloc) 14.078 kB
#include <stdio.h>
#include <stdlib.h>
#include <ctype.h>
#include "object.h"
#include "mem.h"
#include "reader.h"
#include "log.h"
#include "sstream.h"
#include "sform.h"
#include "gc.h"
#include "objstream.h"
static int is_delimiter(int c) {
return isspace(c) || c == EOF ||
c == '(' || c == ')' ||
c == '"' || c == ';';
}
static int peek(FILE *in) {
int c;
c = getc(in);
ungetc(c, in);
return c;
}
static void skip_whitespace(FILE *in) {
int c;
while ((c = getc(in)) != EOF) {
if (isspace(c)) {
continue;
} else if (c == ';') {
/* Skip line comment */
while (((c = getc(in)) != EOF) && (c != '\n'));
continue;
}
ungetc(c, in);
break;
}
}
static object* parse_number(FILE *in, long sign) {
int c;
char is_double = 0;
object *p;
char *str_num;
sstream *stream;
stream = sstream_new(-1);
if (stream == NULL) {
return NULL;
}
while (isdigit(c = getc(in))) {
sstream_append(stream, c);
}
if (c == '.' && isdigit(peek(in))) {
/* flonum */
is_double = 1;
sstream_append(stream, c);
while (isdigit(c = getc(in))) {
sstream_append(stream, c);
}
}
if (is_delimiter(c)) {
ungetc(c, in);
str_num = sstream_cstr(stream);
if (is_double) {
double d;
d = atof(str_num);
d *= sign;
p = make_flonum(d);
} else {
long n;
n = atol(str_num);
n *= sign;
p = make_fixnum(n);
}
sc_free(str_num);
} else {
p = NULL;
fprintf(stderr,
"number not followed by delimiter `%c\n", c);
}
sstream_dispose(stream);
return p;
}
static int is_number_start(int c, int ahead) {
return (isdigit(c) ||
((c == '-' || c == '+') && isdigit(ahead)));
}
static int is_boolean_start(int c, int ahead) {
return c == '#' && ahead != '\\' && ahead != '(';
}
static object* parse_boolean(FILE *in) {
int c, next;
object *obj = NULL;
next = getc(in);
c = peek(in);
if ((next == 't' || next == 'f') && is_delimiter(c)) {
obj = make_boolean(next);
} else {
fprintf(stderr, "unexpected `%c\n", next);
}
return obj;
}
static int is_character_start(int c, int ahead) {
return c == '#' && ahead == '\\';
}
static object* try_character(FILE *in, char *name, char val) {
char *s = name + 1;
while (*s != '\0' && peek(in) == *s) {
s++;
getc(in);
}
if (*s == '\0' && is_delimiter(peek(in))) {
return make_character(val);
}
return NULL;
}
static object* try_parse_character(int c, int ahead, FILE *in) {
object *obj = NULL;
switch (c) {
case EOF:
fprintf(stderr, "%s", "incomplete character literal\n");
break;
case LINEFEED:
case TAB:
case SPACE:
case RETURN:
fprintf(stderr, "%s", "spaces are not allowed in character literal\n");
break;
case 'n':
if (ahead == 'u') {
obj = try_character(in, "nul", NUL);
} else if (ahead == 'e') {
obj = try_character(in, "newline", NEWLINE);
}
break;
case 't':
if (ahead == 'a') {
obj = try_character(in, "tab", TAB);
}
break;
case 'l':
if (ahead == 'i') {
obj = try_character(in, "linefeed", LINEFEED);
}
break;
case 'r':
if (ahead == 'e') {
obj = try_character(in, "return", RETURN);
}
break;
case 's':
if (ahead == 'p') {
obj = try_character(in, "space", SPACE);
}
break;
}
return obj;
}
static object* parse_character(FILE *in) {
int c, ahead;
object *obj;
c = getc(in);
ahead = peek(in);
obj = try_parse_character(c, ahead, in);
if (obj == NULL && is_delimiter(ahead) && !isspace(c)) {
obj = make_character(c);
}
if (obj == NULL && !isspace(c)) {
fprintf(stderr, "bad character literal `%c\n", ahead);
}
return obj;
}
static int is_string_start(int c) {
return c == '"';
}
static int get_escape_char(FILE *in, char *p) {
char c;
c = getc(in);
switch (c) {
case 'a':
*p = '\a';
return 0;
case 'b':
*p = '\b';
return 0;
case 't':
*p = '\t';
return 0;
case 'n':
*p = '\n';
return 0;
case 'v':
*p = '\v';
return 0;
case 'f':
*p = '\f';
return 0;
case 'r':
*p = '\r';
return 0;
case '"':
*p = '"';
return 0;
case '\\':
*p = '\\';
return 0;
}
/* continue line
* eat whitespace before and after newline */
if (isspace(c)) {
while (c != '\n') {
c = getc(in);
if (!isspace(c)) {
break;
}
}
if (c == '\n') {
while (isspace(c = peek(in)) && c != '\n') {
getc(in);
}
*p = '\0';
} else {
return -1;
}
} else {
return -1;
}
return 0;
}
static object* parse_string(FILE *in) {
object *obj = NULL;
sstream *stream;
char *str;
char c;
stream = sstream_new(-1);
if (stream == NULL) {
fprintf(stderr, "%s", "no memory\n");
return NULL;
}
for (;;) {
c = getc(in);
if (c == '"') {
/* end of string found */
str = sstream_cstr(stream);
if (str == NULL) {
fprintf(stderr, "%s", "no memory\n");
} else {
obj = make_string(str);
sc_free(str);
}
break;
} else if (c == '\\') {
/* transform escape sequence */
char x;
char next;
next = peek(in);
if (get_escape_char(in, &x) != 0) {
fprintf(stderr, "unknown escape sequence `%c\n", next);
break;
}
if (x != '\0' && sstream_append(stream, x) != 0) {
fprintf(stderr, "%s", "internal error\n");
break;
}
} else if (c == EOF) {
fprintf(stderr, "%s", "EOF encounted\n");
break;
} else {
/* normal charaters */
if (sstream_append(stream, c) != 0) {
fprintf(stderr, "%s", "internal error\n");
break;
}
}
}
sstream_dispose(stream);
return obj;
}
static int is_list_start(int c) {
return c == '(';
}
static object* parse_list(FILE *in) {
int c;
object *car_obj, *cdr_obj;
object *list;
skip_whitespace(in);
c = peek(in);
if (c == ')') {
getc(in);
return get_empty_list();
}
car_obj = sc_read(in);
if (car_obj == NULL) {
return NULL;
}
skip_whitespace(in);
c = peek(in);
if (c == '.') {
/* improper list */
getc(in);
c = peek(in);
if (!is_delimiter(c)) {
fprintf(stderr, "%s `%c\n",
"dot not followed by delimiter", c);
return NULL;
}
gc_protect(car_obj);
cdr_obj = sc_read(in);
gc_abandon();
if (cdr_obj == NULL) {
return NULL;
}
skip_whitespace(in);
c = getc(in);
if (c != ')') {
fprintf(stderr, "%s `%c\n",
"missing close parentheses", c);
return NULL;
}
gc_protect(car_obj);
gc_protect(cdr_obj);
list = cons(car_obj, cdr_obj);
gc_abandon();
gc_abandon();
return list;
} else {
/* proper list */
gc_protect(car_obj);
cdr_obj = parse_list(in);
gc_abandon();
if (cdr_obj == NULL) {
return NULL;
}
gc_protect(car_obj);
gc_protect(cdr_obj);
list = cons(car_obj, cdr_obj);
gc_abandon();
gc_abandon();
return list;
}
/* should never get here */
return NULL;
}
static int is_symbol_start(int c, int ahead) {
if (isalpha(c) ||
((c == '+' || c == '-') && !isdigit(ahead)) ||
c == '!' || c == '$' || c == '%' || c == '&' ||
c == '*' || c == '.' || c == '/' || c == ':' ||
c == '<' || c == '=' || c == '>' || c == '?' ||
c == '@' || c == '^' || c == '_' || c == '~') {
return 1;
}
return 0;
}
static int is_symbol_char(int c) {
if (isalpha(c) || isdigit(c) || c == '+' || c == '-' ||
c == '!' || c == '$' || c == '%' || c == '&' ||
c == '*' || c == '.' || c == '/' || c == ':' ||
c == '<' || c == '=' || c == '>' || c == '?' ||
c == '@' || c == '^' || c == '_' || c == '~') {
return 1;
}
return 0;
}
static object* parse_symbol(FILE *in) {
object *obj = NULL;
int c;
sstream *stream;
stream = sstream_new(-1);
if (stream == NULL) {
fprintf(stderr, "%s", "no memory for stream\n");
return NULL;
}
for (;;) {
c = getc(in);
if (is_symbol_char(c)) {
int ret;
ret = sstream_append(stream, c);
if (ret != 0) {
fprintf(stderr, "%s", "internal error\n");
break;
}
} else {
if (is_delimiter(c)) {
char *sym;
ungetc(c, in);
sym = sstream_cstr(stream);
if (sym == NULL) {
fprintf(stderr, "%s", "internal error\n");
} else {
obj = make_symbol(sym);
sc_free(sym);
}
} else {
fprintf(stderr, "%s `%c\n",
"unexpected input", c);
}
break;
}
}
sstream_dispose(stream);
return obj;
}
static int is_quote_start(int c) {
return c == '\'';
}
static object* parse_quote_form(FILE *in) {
object *quote, *obj, *cdr_obj;
quote = get_quote_symbol();
cdr_obj = sc_read(in);
if (cdr_obj == NULL) {
obj = NULL;
} else {
gc_protect(cdr_obj);
obj = cons(quote, cons(cdr_obj, get_empty_list()));
gc_abandon();
}
return obj;
}
static int is_quasiquote_start(int c) {
return c == '`';
}
static object* parse_quasiquote_form(FILE *in) {
object *quasiquote, *obj, *cdr_obj;
cdr_obj = sc_read(in);
if (cdr_obj == NULL) {
obj = NULL;
} else {
quasiquote = get_quasiquote_symbol();
gc_protect(cdr_obj);
obj = cons(quasiquote, cons(cdr_obj, get_empty_list()));
gc_abandon();
}
return obj;
}
static int is_unquote_start(int c) {
return c == ',';
}
static object* parse_unquote_form(FILE *in) {
int c = peek(in);
object *unquote, *obj, *cdr_obj;
if (c == '@') {
unquote = get_unquotesplicing_symbol();
getc(in);
} else {
unquote = get_unquote_symbol();
}
cdr_obj = sc_read(in);
if (cdr_obj == NULL) {
obj = NULL;
} else {
gc_protect(cdr_obj);
obj = cons(unquote, cons(cdr_obj, get_empty_list()));
gc_abandon();
}
return obj;
}
int is_vector_start(int c, int ahead) {
return c == '#' && ahead == '(';
}
object* parse_vector(FILE *in) {
objstream *stream;
object *obj;
object **buf;
int ret;
stream = objstream_new(-1);
if (stream == NULL) {
fprintf(stdout, "null");
return NULL;
}
for(;;) {
skip_whitespace(in);
if (peek(in) == ')') {
getc(in);
break;
}
obj = sc_read(in);
if (obj == NULL) {
objstream_dispose(stream);
return NULL;
}
ret = objstream_append(stream, obj);
if (ret != 0) {
objstream_dispose(stream);
return NULL;
}
}
if (!is_delimiter(peek(in))) {
fprintf(stdout, "vector not followed by delimiter `%c\n", peek(in));
objstream_dispose(stream);
return NULL;
}
buf = objstream_trim(stream, &ret);
obj = make_vector(buf, ret);
objstream_dispose(stream);
return obj;
}
object* sc_read(FILE *in) {
int c;
object *obj;
skip_whitespace(in);
c = getc(in);
if (is_number_start(c, peek(in))) {
long sign = 1;
if (c == '-') {
sign = -1;
}
if (isdigit(c)) {
ungetc(c, in);
}
obj = parse_number(in, sign);
} else if (is_boolean_start(c, peek(in))) {
obj = parse_boolean(in);
} else if (is_character_start(c, peek(in))) {
getc(in);
obj = parse_character(in);
} else if (is_string_start(c)) {
obj = parse_string(in);
} else if (is_list_start(c)) {
obj = parse_list(in);
} else if (is_vector_start(c, peek(in))) {
getc(in);
obj = parse_vector(in);
} else if (is_symbol_start(c, peek(in))) {
ungetc(c, in);
obj = parse_symbol(in);
} else if (is_quote_start(c)) {
obj = parse_quote_form(in);
} else if (is_quasiquote_start(c)) {
obj = parse_quasiquote_form(in);
} else if (is_unquote_start(c)) {
obj = parse_unquote_form(in);
} else if (c == EOF) {
obj = get_eof_object();
} else {
fprintf(stderr, "bad input, at `%c\n", c);
obj = NULL;
}
return obj;
}
Jump to Line
Something went wrong with that request. Please try again.