Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-23 20:15:06 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions
chibi-scheme/sexp.c
Alex Shinn fdbf99b433 local variable references work
2009-03-26 01:34:47 +09:00

875 lines
23 KiB
C
Raw Blame History

/* sexp.c -- standalone sexp library implementation */
/* Copyright (c) 2009 Alex Shinn. All rights reserved. */
/* BSD-style license: http://synthcode.com/license.txt */
#include "sexp.h"
/* optional huffman-compressed immediate symbols */
#ifdef USE_HUFF_SYMS
struct huff_entry {
unsigned char len;
unsigned short bits;
};
#include "sexp-hufftabs.c"
static struct huff_entry huff_table[] = {
#include "sexp-huff.c"
};
#endif
static int sexp_initialized_p = 0;
static sexp the_dot_symbol;
static sexp the_quote_symbol;
static sexp the_quasiquote_symbol;
static sexp the_unquote_symbol;
static sexp the_unquote_splicing_symbol;
static sexp the_read_error_symbol;
static sexp the_empty_vector;
static char sexp_separators[] = {
/* 1 2 3 4 5 6 7 8 9 a b c d e f */
0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1, 0, 0, /* x0_ */
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* x1_ */
1, 0, 1, 0, 0, 0, 0, 1, 1, 1, 0, 0, 1, 0, 0, 0, /* x2_ */
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, /* x3_ */
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* x4_ */
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 1, 0, 0, /* x5_ */
};
#define digit_value(c) (((c)<='9') ? ((c) - '0') : ((toupper(c) - 'A') + 10))
static int is_separator(int c) {
/* return (!((c-9)&(~3))) | (~(c^4)); */
return 0<c && c<0x60 && sexp_separators[c];
}
static sexp* symbol_table = NULL;
static unsigned long symbol_table_primes[] = {
97, 389, 1543, 6151, 12289, 24593, 49157, 98317, 196613, 393241,
786433, 1572869, 3145739, 6291469, 12582917, 25165843, 50331653,
100663319, 201326611, 402653189, 805306457, 1610612741};
static int symbol_table_prime_index = 0;
static int symbol_table_count = 0;
sexp sexp_alloc_tagged(size_t size, sexp_uint_t tag) {
sexp res = (sexp) sexp_alloc(size);
if (! res)
errx(EX_OSERR, "out of memory: couldn't allocate %ld bytes for %ld",
size ,tag);
sexp_pointer_tag(res) = tag;
return res;
}
#if ! USE_BOEHM
void sexp_deep_free (sexp obj) {
int len, i;
sexp *elts;
if (sexp_pointerp(obj)) {
switch (sexp_pointer_tag(obj)) {
case SEXP_PAIR:
sexp_deep_free(sexp_car(obj));
sexp_deep_free(sexp_cdr(obj));
break;
case SEXP_VECTOR:
len = sexp_vector_length(obj);
elts = sexp_vector_data(obj);
for (i=0; i<len; i++)
sexp_deep_free(elts[i]);
sexp_free(elts);
break;
case SEXP_STRING:
case SEXP_SYMBOL:
sexp_free(sexp_string_data(obj));
break;
}
sexp_free(obj);
}
}
#endif
/***************************** exceptions *****************************/
sexp sexp_make_exception(sexp kind, sexp message, sexp irritants,
sexp file, sexp line) {
sexp exn = sexp_alloc_type(exception, SEXP_EXCEPTION);
sexp_exception_kind(exn) = kind;
sexp_exception_message(exn) = message;
sexp_exception_irritants(exn) = irritants;
sexp_exception_file(exn) = file;
sexp_exception_line(exn) = line;
return exn;
}
sexp sexp_print_exception(sexp exn, sexp out) {
sexp ls;
sexp_write_string("ERROR", out);
if (sexp_integerp(sexp_exception_line(exn))
&& sexp_exception_line(exn) > sexp_make_integer(0)) {
sexp_write_string(" on line ", out);
sexp_write(sexp_exception_line(exn), out);
}
if (sexp_stringp(sexp_exception_file(exn))) {
sexp_write_string(" of file ", out);
sexp_write_string(sexp_string_data(sexp_exception_file(exn)), out);
}
sexp_write_string(": ", out);
sexp_write_string(sexp_string_data(sexp_exception_message(exn)), out);
if (sexp_pairp(sexp_exception_irritants(exn))) {
if (sexp_nullp(sexp_cdr(sexp_exception_irritants(exn)))) {
sexp_write_string(": ", out);
sexp_write(sexp_car(sexp_exception_irritants(exn)), out);
sexp_write_string("\n", out);
} else {
sexp_write_string("\n", out);
for (ls=sexp_exception_irritants(exn);
sexp_pairp(ls); ls=sexp_cdr(ls)) {
sexp_write_string(" ", out);
sexp_write(sexp_car(ls), out);
sexp_write_string("\n", out);
}
}
}
return SEXP_UNDEF;
}
static sexp sexp_read_error(char *message, sexp irritants, sexp port) {
return sexp_make_exception(the_read_error_symbol, sexp_make_string(message),
irritants,
sexp_make_string(sexp_port_name(port)),
sexp_make_integer(sexp_port_line(port)));
}
/*************************** list utilities ***************************/
sexp sexp_cons(sexp head, sexp tail) {
sexp pair = sexp_alloc_type(pair, SEXP_PAIR);
sexp_car(pair) = head;
sexp_cdr(pair) = tail;
return pair;
}
int sexp_listp (sexp obj) {
while (sexp_pairp(obj))
obj = sexp_cdr(obj);
return (obj == SEXP_NULL);
}
int sexp_list_index (sexp ls, sexp elt) {
int i=0;
while (sexp_pairp(ls)) {
if (sexp_car(ls) == elt)
return i;
ls = sexp_cdr(ls);
i++;
}
return -1;
}
sexp sexp_memq (sexp x, sexp ls) {
while (sexp_pairp(ls))
if (x == sexp_car(ls))
return ls;
else
ls = sexp_cdr(ls);
return SEXP_FALSE;
}
sexp sexp_assq (sexp x, sexp ls) {
while (sexp_pairp(ls))
if (x == sexp_caar(ls))
return ls;
else
ls = sexp_cdr(ls);
return SEXP_FALSE;
}
sexp sexp_lset_diff(sexp a, sexp b) {
sexp res = SEXP_NULL;
for ( ; sexp_pairp(a); a=sexp_cdr(a))
if (sexp_list_index(b, sexp_car(a)) < 0)
res = sexp_cons(sexp_car(a), res);
return res;
}
/* sexp sexp_lset_union(sexp a, sexp b) { */
/* if (! sexp_pairp(b)) */
/* return a; */
/* for ( ; sexp_pairp(a); a=sexp_cdr(a)) */
/* sexp_insert(sexp_car(a), b); */
/* return b; */
/* } */
sexp sexp_reverse(sexp ls) {
sexp res = SEXP_NULL;
for ( ; sexp_pairp(ls); ls=sexp_cdr(ls))
res = sexp_cons(sexp_car(ls), res);
return res;
}
sexp sexp_nreverse(sexp ls) {
sexp a, b, tmp;
if (ls == SEXP_NULL) {
return ls;
} else if (! sexp_pairp(ls)) {
return SEXP_ERROR;
} else {
b = ls;
a = sexp_cdr(ls);
sexp_cdr(b) = SEXP_NULL;
for ( ; sexp_pairp(a); b=a, a=tmp) {
tmp = sexp_cdr(a);
sexp_cdr(a) = b;
}
return b;
}
}
sexp sexp_append(sexp a, sexp b) {
for (a=sexp_reverse(a); sexp_pairp(a); a=sexp_cdr(a))
b = sexp_cons(sexp_car(a), b);
return b;
}
sexp sexp_length(sexp ls) {
sexp_uint_t res=0;
for ( ; sexp_pairp(ls); res++, ls=sexp_cdr(ls))
;
return sexp_make_integer(res);
}
/********************* strings, symbols, vectors **********************/
sexp sexp_make_flonum(double f) {
sexp x = sexp_alloc_type(flonum, SEXP_FLONUM);
sexp_flonum_value(x) = f;
return x;
}
sexp sexp_make_string(char *str) {
sexp s = sexp_alloc_type(string, SEXP_STRING);
sexp_uint_t len = strlen(str);
char *mystr = sexp_alloc(len+1);
memcpy(mystr, str, len+1);
sexp_string_length(s) = len;
sexp_string_data(s) = mystr;
return s;
}
#define FNV_PRIME 16777619
#define FNV_OFFSET_BASIS 2166136261uL
int sexp_string_hash(char *str, int acc) {
while (*str) {acc *= FNV_PRIME; acc ^= *str++;}
return acc;
}
sexp sexp_intern(char *str) {
struct huff_entry he;
sexp_uint_t len, res=FNV_OFFSET_BASIS, space=3, newbits, i, d, cell;
char c, *mystr, *p=str;
sexp sym, *newtable;
#if USE_HUFF_SYMS
res = 0;
for ( ; (c=*p); p++) {
he = huff_table[(unsigned char)c];
newbits = he.len;
if ((space+newbits) > (sizeof(sexp)*8)) {
goto normal_intern;
}
res |= (((sexp_uint_t) he.bits) << space);
space += newbits;
}
return (sexp) (res + SEXP_ISYMBOL_TAG);
#endif
normal_intern:
res = sexp_string_hash(p, res);
d = symbol_table_primes[symbol_table_prime_index];
cell = res % d;
for (i=0; i<d; i++) {
if (! symbol_table[cell]) {
break;
} else if (strncmp(str,
sexp_symbol_data(symbol_table[cell]),
sexp_symbol_length(symbol_table[cell])) == 0) {
return symbol_table[cell];
}
cell = (cell * res + 1) % d;
}
symbol_table_count++;
if (symbol_table_count*5 > d*4) {
fprintf(stderr, "resizing symbol table!!!!!\n");
newtable = sexp_alloc(symbol_table_primes[symbol_table_prime_index++]
* sizeof(sexp));
/* XXXX rehash */
sexp_free(symbol_table);
symbol_table = newtable;
}
sym = sexp_alloc_type(symbol, SEXP_SYMBOL);
len = strlen(str);
mystr = sexp_alloc(len+1);
memcpy(mystr, str, len+1);
mystr[len]=0;
sexp_symbol_length(sym) = len;
sexp_symbol_data(sym) = mystr;
symbol_table[cell] = sym;
return symbol_table[cell];
}
sexp sexp_make_vector(sexp len, sexp dflt) {
sexp v, *x;
int i, clen = sexp_unbox_integer(len);
if (! clen) return the_empty_vector;
v = sexp_alloc_type(vector, SEXP_VECTOR);
x = (sexp*) sexp_alloc(clen*sizeof(sexp));
for (i=0; i<clen; i++) {
x[i] = dflt;
}
sexp_vector_length(v) = clen;
sexp_vector_data(v) = x;
return v;
}
sexp sexp_list_to_vector(sexp ls) {
sexp x, vec = sexp_make_vector(sexp_length(ls), SEXP_UNDEF);
sexp *elts = sexp_vector_data(vec);
int i;
for (i=0, x=ls; sexp_pairp(x); i++, x=sexp_cdr(x))
elts[i] = sexp_car(x);
return vec;
}
sexp sexp_vector(int count, ...) {
sexp vec = sexp_make_vector(sexp_make_integer(count), SEXP_UNDEF);
sexp *elts = sexp_vector_data(vec);
va_list ap;
int i;
va_start(ap, count);
for (i=0; i<count; i++)
elts[i] = va_arg(ap, sexp);
va_end(ap);
return vec;
}
/************************ reading and writing *************************/
#if USE_STRING_STREAMS
int sstream_read(void *vec, char *dst, int n) {
int len = (int) sexp_vector_ref((sexp) vec, sexp_make_integer(1));
int pos = (int) sexp_vector_ref((sexp) vec, sexp_make_integer(2));
if (pos >= len) return 0;
if (n > (len - pos)) n = (len - pos);
memcpy(dst+pos, sexp_vector_ref((sexp) vec, sexp_make_integer(0)), n);
sexp_vector_set((sexp) vec, sexp_make_integer(2), (sexp)n);
return n;
}
int sstream_write(void *vec, const char *src, int n) {
return n;
}
off_t sstream_seek(void *vec, off_t offset, int whence) {
int pos;
if (whence == SEEK_SET) {
pos = offset;
} else if (whence == SEEK_CUR) {
pos = (int) sexp_vector_ref((sexp) vec, sexp_make_integer(2)) + offset;
} else { /* SEEK_END */
pos = (int) sexp_vector_ref((sexp) vec, sexp_make_integer(1)) + offset;
}
sexp_vector_set((sexp) vec, sexp_make_integer(2), (sexp)pos);
return pos;
}
int sstream_close(void *vec) {
sexp_deep_free((sexp)vec);
return 0;
}
sexp sexp_make_input_string_port(sexp str) {
FILE *in = fmemopen(sexp_string_data(str), sexp_string_length(str), "r");
return sexp_make_input_port(in);
}
sexp sexp_make_output_string_port() {
return SEXP_ERROR;
}
sexp sexp_get_output_string(sexp port) {
return SEXP_ERROR;
}
#endif
sexp sexp_make_input_port(FILE* in) {
sexp p = sexp_alloc_type(port, SEXP_IPORT);
sexp_port_stream(p) = in;
sexp_port_line(p) = 0;
return p;
}
sexp sexp_make_output_port(FILE* out) {
sexp p = sexp_alloc_type(port, SEXP_OPORT);
sexp_port_stream(p) = out;
sexp_port_line(p) = 0;
return p;
}
void sexp_write (sexp obj, sexp out) {
unsigned long len, c, res;
long i=0;
sexp x, *elts;
char *str=NULL;
if (! obj) {
sexp_write_string("#<null>", out);
} else if (sexp_pointerp(obj)) {
switch (sexp_pointer_tag(obj)) {
case SEXP_PAIR:
sexp_write_char('(', out);
sexp_write(sexp_car(obj), out);
for (x=sexp_cdr(obj); sexp_pairp(x); x=sexp_cdr(x)) {
sexp_write_char(' ', out);
sexp_write(sexp_car(x), out);
}
if (! sexp_nullp(x)) {
sexp_write_string(" . ", out);
sexp_write(x, out);
}
sexp_write_char(')', out);
break;
case SEXP_VECTOR:
len = sexp_vector_length(obj);
elts = sexp_vector_data(obj);
if (len == 0) {
sexp_write_string("#()", out);
} else {
sexp_write_string("#(", out);
sexp_write(elts[0], out);
for (i=1; i<len; i++) {
sexp_write_char(' ', out);
sexp_write(elts[i], out);
}
sexp_write_char(')', out);
}
break;
case SEXP_FLONUM:
sexp_printf(out, "%g", sexp_flonum_value(obj)); break;
case SEXP_PROCEDURE:
sexp_printf(out, "#<procedure: %p>", obj); break;
case SEXP_IPORT:
sexp_write_string("#<input-port>", out); break;
case SEXP_OPORT:
sexp_write_string("#<output-port>", out); break;
case SEXP_CORE:
sexp_write_string("#<core-form>", out); break;
case SEXP_OPCODE:
sexp_write_string("#<opcode>", out); break;
case SEXP_BYTECODE:
sexp_write_string("#<bytecode>", out); break;
case SEXP_ENV:
sexp_write_string("#<env>", out); break;
case SEXP_EXCEPTION:
sexp_write_string("#<exception>", out); break;
case SEXP_MACRO:
sexp_write_string("#<macro>", out); break;
case SEXP_LAMBDA:
sexp_write_string("#<lambda>", out); break;
case SEXP_REF:
sexp_write_string("#<ref: ", out);
sexp_write(sexp_ref_name(obj), out);
sexp_write_string(">", out);
break;
case SEXP_STRING:
sexp_write_char('"', out);
i = sexp_string_length(obj);
str = sexp_string_data(obj);
/* ... FALLTHROUGH ... */
case SEXP_SYMBOL:
if (! sexp_stringp(obj)) {
i = sexp_symbol_length(obj);
str = sexp_symbol_data(obj);
}
for ( ; i>0; str++, i--) {
if (str[0] == '\\')
sexp_write_char('\\', out);
sexp_write_char(str[0], out);
}
if (sexp_stringp(obj))
sexp_write_char('"', out);
break;
}
} else if (sexp_integerp(obj)) {
sexp_printf(out, "%ld", sexp_unbox_integer(obj));
} else if (sexp_charp(obj)) {
if ((33 <= sexp_unbox_character(obj)) && (sexp_unbox_character(obj) < 127))
sexp_printf(out, "#\\%c", sexp_unbox_character(obj));
else
sexp_printf(out, "#\\x%02d", sexp_unbox_character(obj));
} else if (sexp_symbolp(obj)) {
#if USE_HUFF_SYMS
if (((sexp_uint_t)obj&7)==7) {
c = ((sexp_uint_t)obj)>>3;
while (c) {
#include "sexp-unhuff.c"
sexp_write_char(res, out);
}
}
#endif
} else {
switch ((sexp_uint_t) obj) {
case (sexp_uint_t) SEXP_NULL:
sexp_write_string("()", out); break;
case (sexp_uint_t) SEXP_TRUE:
sexp_write_string("#t", out); break;
case (sexp_uint_t) SEXP_FALSE:
sexp_write_string("#f", out); break;
case (sexp_uint_t) SEXP_EOF:
sexp_write_string("#<eof>", out); break;
case (sexp_uint_t) SEXP_UNDEF:
sexp_write_string("#<undef>", out); break;
case (sexp_uint_t) SEXP_ERROR:
sexp_write_string("#<error>", out); break;
default:
sexp_printf(out, "#<invalid: %p>", obj);
}
}
}
char* sexp_read_string(sexp in) {
char *buf, *tmp, *res;
int c, len, size=128;
buf = sexp_alloc(size); /* XXXX grow! */
tmp = buf;
for (c=sexp_read_char(in); c != '"'; c=sexp_read_char(in)) {
if (c == EOF) {
sexp_free(buf);
return NULL;
} else if (c == '\\') {
c=sexp_read_char(in);
switch (c) {
case 'n': c = '\n'; break;
case 't': c = '\t'; break;
}
*tmp++ = c;
} else {
*tmp++ = c;
}
}
*tmp++ = '\0';
len = tmp - buf;
res = sexp_alloc(len);
memcpy(res, buf, len);
sexp_free(buf);
return res;
}
char* sexp_read_symbol(sexp in, int init) {
char *buf, *tmp, *res;
int c, len, size=128;
buf = sexp_alloc(size);
tmp = buf;
if (init != EOF)
*tmp++ = init;
while (1) {
c=sexp_read_char(in);
if (c == EOF || is_separator(c)) {
sexp_push_char(c, in);
break;
}
*tmp++ = c;
}
*tmp++ = '\0';
len = tmp - buf;
res = sexp_alloc(len);
memcpy(res, buf, len);
sexp_free(buf);
return res;
}
sexp sexp_read_float_tail(sexp in, long whole) {
double res = 0.0, scale=0.1;
int c;
for (c=sexp_read_char(in); isdigit(c); c=sexp_read_char(in), scale*=0.1)
res += digit_value(c)*scale;
sexp_push_char(c, in);
return sexp_make_flonum(whole + res);
}
sexp sexp_read_number(sexp in, int base) {
sexp tmp;
long res = 0, negativep = 0, c;
c = sexp_read_char(in);
if (c == '-') {
negativep = 1;
} else if (isdigit(c)) {
res = c - '0';
}
for (c=sexp_read_char(in); isxdigit(c); c=sexp_read_char(in))
res = res * base + digit_value(c);
if (c=='.') {
if (base != 10) {
return sexp_read_error("decimal found in non-base 10", SEXP_NULL, in);
}
tmp = sexp_read_float_tail(in, res);
if (sexp_exceptionp(tmp)) return tmp;
if (negativep && sexp_flonump(tmp))
sexp_flonum_value(tmp) = -1 * sexp_flonum_value(tmp);
return tmp;
} else {
sexp_push_char(c, in);
}
return sexp_make_integer(negativep ? -res : res);
}
sexp sexp_read_raw (sexp in) {
sexp res, tmp, tmp2;
char *str;
int c1, c2;
scan_loop:
switch (c1 = sexp_read_char(in)) {
case EOF:
res = SEXP_EOF;
break;
case ';':
sexp_port_line(in)++;
while ((c1 = sexp_read_char(in)) != EOF)
if (c1 == '\n')
break;
/* ... FALLTHROUGH ... */
case ' ':
case '\t':
case '\r':
goto scan_loop;
case '\n':
sexp_port_line(in)++;
goto scan_loop;
case '\'':
res = sexp_read(in);
res = sexp_list2(the_quote_symbol, res);
break;
case '`':
res = sexp_read(in);
res = sexp_list2(the_quasiquote_symbol, res);
break;
case ',':
if ((c1 = sexp_read_char(in)) == '@') {
res = sexp_read(in);
res = sexp_list2(the_unquote_splicing_symbol, res);
} else {
sexp_push_char(c1, in);
res = sexp_read(in);
res = sexp_list2(the_unquote_symbol, res);
}
break;
case '"':
str = sexp_read_string(in);
res = sexp_make_string(str);
sexp_free(str);
break;
case '(':
res = SEXP_NULL;
tmp = sexp_read_raw(in);
while ((tmp != SEXP_ERROR) && (tmp != SEXP_EOF) && (tmp != SEXP_CLOSE)) {
if (tmp == SEXP_RAWDOT) {
if (res == SEXP_NULL) {
return sexp_read_error("dot before any elements in list",
SEXP_NULL, in);
} else {
tmp = sexp_read_raw(in);
if (sexp_read_raw(in) != SEXP_CLOSE) {
sexp_deep_free(res);
return sexp_read_error("multiple tokens in dotted tail",
SEXP_NULL, in);
} else {
tmp2 = res;
res = sexp_nreverse(res);
sexp_cdr(tmp2) = tmp;
return res;
}
}
} else {
res = sexp_cons(tmp, res);
tmp = sexp_read_raw(in);
}
}
if (tmp != SEXP_CLOSE) {
sexp_deep_free(res);
return sexp_read_error("missing trailing ')'", SEXP_NULL, in);
}
res = (sexp_pairp(res) ? sexp_nreverse(res) : res);
break;
case '#':
switch (c1=sexp_read_char(in)) {
case 'b':
res = sexp_read_number(in, 2); break;
case 'o':
res = sexp_read_number(in, 8); break;
case 'd':
res = sexp_read_number(in, 10); break;
case 'x':
res = sexp_read_number(in, 16); break;
/* case 'e': */
/* case 'i': */
case 'f':
case 't':
c2 = sexp_read_char(in);
if (c2 == EOF || is_separator(c2)) {
res = (c1 == 't' ? SEXP_TRUE : SEXP_FALSE);
} else {
return sexp_read_error("invalid syntax #%c%c",
sexp_list2(sexp_make_character(c1),
sexp_make_character(c2)),
in);
}
sexp_push_char(c2, in);
break;
case ';':
sexp_read_raw(in);
goto scan_loop;
case '\\':
c1 = sexp_read_char(in);
c2 = sexp_read_char(in);
if (c2 == EOF || is_separator(c2)) {
sexp_push_char(c2, in);
res = sexp_make_character(c1);
} else if ((c1 == 'x' || c1 == 'X') && isxdigit(c2)) {
c1 = sexp_read_char(in);
res = sexp_make_character(16 * digit_value(c2) + digit_value(c1));
} else {
str = sexp_read_symbol(in, c1);
if (strcasecmp(str, "space") == 0)
res = sexp_make_character(' ');
else if (strcasecmp(str, "newline") == 0)
res = sexp_make_character('\r');
else if (strcasecmp(str, "return") == 0)
res = sexp_make_character('\r');
else if (strcasecmp(str, "tab") == 0)
res = sexp_make_character('\t');
else {
return sexp_read_error("unknown character name",
sexp_list1(sexp_make_string(str)),
in);
}
}
break;
case '(':
sexp_push_char(c1, in);
res = sexp_read(in);
if (! sexp_listp(res)) {
if (! sexp_exceptionp(res)) {
sexp_deep_free(res);
return sexp_read_error("dotted list not allowed in vector syntax",
SEXP_NULL,
in);
}
} else {
res = sexp_list_to_vector(res);
}
break;
default:
return sexp_read_error("invalid # syntax",
sexp_list1(sexp_make_character(c1)), in);
}
break;
case '.':
c1 = sexp_read_char(in);
if (c1 == EOF || is_separator(c1)) {
res = SEXP_RAWDOT;
} else if (isdigit(c1)) {
sexp_push_char(c1,in );
res = sexp_read_float_tail(in, 0);
} else {
sexp_push_char(c1, in);
str = sexp_read_symbol(in, '.');
res = sexp_intern(str);
sexp_free(str);
}
break;
case ')':
res = SEXP_CLOSE;
break;
case '+':
case '-':
c2 = sexp_read_char(in);
if (c2 == '.' || isdigit(c2)) {
sexp_push_char(c2, in);
res = sexp_read_number(in, 10);
if (sexp_exceptionp(res)) return res;
if (c1 == '-') res = sexp_fx_mul(res, -1);
} else {
sexp_push_char(c2, in);
str = sexp_read_symbol(in, c1);
res = sexp_intern(str);
sexp_free(str);
}
break;
case '0': case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9':
sexp_push_char(c1, in);
res = sexp_read_number(in, 10);
break;
default:
str = sexp_read_symbol(in, c1);
res = sexp_intern(str);
sexp_free(str);
break;
}
return res;
}
sexp sexp_read (sexp in) {
sexp res = sexp_read_raw(in);
if (res == SEXP_CLOSE)
return sexp_read_error("too many ')'s", SEXP_NULL, in);
if (res == SEXP_RAWDOT)
return sexp_read_error("unexpected '.'", SEXP_NULL, in);
return res;
}
sexp sexp_read_from_string(char *str) {
sexp s = sexp_make_string(str);
sexp in = sexp_make_input_string_port(s);
sexp res = sexp_read(in);
sexp_deep_free(s);
sexp_deep_free(in);
return res;
}
void sexp_init() {
if (! sexp_initialized_p) {
sexp_initialized_p = 1;
#if USE_BOEHM
GC_init();
#endif
symbol_table = sexp_alloc(symbol_table_primes[0]*sizeof(sexp));
the_dot_symbol = sexp_intern(".");
the_quote_symbol = sexp_intern("quote");
the_quasiquote_symbol = sexp_intern("quasiquote");
the_unquote_symbol = sexp_intern("unquote");
the_unquote_splicing_symbol = sexp_intern("unquote-splicing");
the_read_error_symbol = sexp_intern("read-error");
the_empty_vector = sexp_alloc_type(vector, SEXP_VECTOR);
sexp_vector_length(the_empty_vector) = 0;
sexp_vector_data(the_empty_vector) = NULL;
}
}
Reference in a new issue View git blame Copy permalink